diff options
| author | Luc Maranget <luc.maranget@inria.fr> | 2008-10-14 07:37:28 +0000 |
|---|---|---|
| committer | Luc Maranget <luc.maranget@inria.fr> | 2008-10-14 07:37:28 +0000 |
| commit | 30324d6b928ea56455557231dcb366afad6ea4fd (patch) | |
| tree | 5c1e8d1edb2cdcf4093ba4c00150689e690872f6 | |
| parent | 80b8675a58d6fe32629708ce33723422fc6d9af4 (diff) | |
| download | ocaml-30324d6b928ea56455557231dcb366afad6ea4fd.tar.gz | |
premier commit 311
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/jocamltrunk@9081 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
294 files changed, 11074 insertions, 6298 deletions
@@ -1,3 +1,13 @@ +utils/agraph.cmi: +utils/ccomp.cmi: +utils/clflags.cmi: +utils/config.cmi: +utils/consistbl.cmi: +utils/extarray.cmi: +utils/misc.cmi: +utils/tbl.cmi: +utils/terminfo.cmi: +utils/warnings.cmi: utils/agraph.cmo: utils/extarray.cmi utils/agraph.cmi utils/agraph.cmx: utils/extarray.cmx utils/agraph.cmi utils/ccomp.cmo: utils/misc.cmi utils/config.cmi utils/clflags.cmi \ @@ -20,8 +30,11 @@ utils/terminfo.cmo: utils/terminfo.cmi utils/terminfo.cmx: utils/terminfo.cmi utils/warnings.cmo: utils/warnings.cmi utils/warnings.cmx: utils/warnings.cmi +parsing/asttypes.cmi: parsing/lexer.cmi: parsing/parser.cmi parsing/location.cmi +parsing/linenum.cmi: parsing/location.cmi: utils/warnings.cmi +parsing/longident.cmi: parsing/parse.cmi: parsing/parsetree.cmi parsing/parser.cmi: parsing/parsetree.cmi parsing/parsetree.cmi: parsing/longident.cmi parsing/location.cmi \ @@ -56,12 +69,14 @@ parsing/printast.cmx: parsing/parsetree.cmi parsing/longident.cmx \ parsing/location.cmx parsing/asttypes.cmi parsing/printast.cmi parsing/syntaxerr.cmo: parsing/location.cmi parsing/syntaxerr.cmi parsing/syntaxerr.cmx: parsing/location.cmx parsing/syntaxerr.cmi +typing/annot.cmi: parsing/location.cmi typing/btype.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi typing/ctype.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi \ typing/env.cmi parsing/asttypes.cmi typing/datarepr.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi typing/env.cmi: typing/types.cmi typing/path.cmi parsing/longident.cmi \ - typing/ident.cmi utils/consistbl.cmi + typing/ident.cmi utils/consistbl.cmi typing/annot.cmi +typing/ident.cmi: typing/includeclass.cmi: typing/types.cmi typing/typedtree.cmi typing/env.cmi \ typing/ctype.cmi typing/includecore.cmi: typing/types.cmi typing/typedtree.cmi \ @@ -78,16 +93,17 @@ typing/parmatch.cmi: typing/types.cmi typing/typedtree.cmi \ parsing/location.cmi typing/env.cmi typing/path.cmi: typing/ident.cmi typing/predef.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi +typing/primitive.cmi: typing/printtyp.cmi: typing/types.cmi typing/path.cmi typing/outcometree.cmi \ parsing/longident.cmi typing/ident.cmi -typing/stypes.cmi: typing/typedtree.cmi parsing/location.cmi +typing/stypes.cmi: typing/typedtree.cmi parsing/location.cmi typing/annot.cmi typing/subst.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi typing/typeclass.cmi: typing/types.cmi typing/typedtree.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi typing/typecore.cmi: typing/types.cmi typing/typedtree.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ - typing/ident.cmi typing/env.cmi parsing/asttypes.cmi + typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/annot.cmi typing/typedecl.cmi: typing/types.cmi typing/path.cmi parsing/parsetree.cmi \ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ typing/env.cmi @@ -120,11 +136,13 @@ typing/datarepr.cmx: typing/types.cmx typing/predef.cmx utils/misc.cmx \ typing/env.cmo: typing/types.cmi utils/tbl.cmi typing/subst.cmi \ typing/predef.cmi typing/path.cmi utils/misc.cmi parsing/longident.cmi \ typing/ident.cmi typing/datarepr.cmi utils/consistbl.cmi utils/config.cmi \ - utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/env.cmi + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \ + typing/env.cmi typing/env.cmx: typing/types.cmx utils/tbl.cmx typing/subst.cmx \ typing/predef.cmx typing/path.cmx utils/misc.cmx parsing/longident.cmx \ typing/ident.cmx typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \ - utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/env.cmi + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \ + typing/env.cmi typing/ident.cmo: typing/ident.cmi typing/ident.cmx: typing/ident.cmi typing/includeclass.cmo: typing/types.cmi typing/printtyp.cmi \ @@ -153,10 +171,10 @@ typing/joinmatching.cmx: typing/typedtree.cmx typing/parmatch.cmx \ utils/agraph.cmx typing/joinmatching.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 \ @@ -188,9 +206,9 @@ typing/printtyp.cmx: typing/types.cmx typing/primitive.cmx typing/predef.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ typing/printtyp.cmi typing/stypes.cmo: typing/typedtree.cmi typing/printtyp.cmi \ - parsing/location.cmi utils/clflags.cmi typing/stypes.cmi + parsing/location.cmi utils/clflags.cmi typing/annot.cmi typing/stypes.cmi typing/stypes.cmx: typing/typedtree.cmx typing/printtyp.cmx \ - parsing/location.cmx utils/clflags.cmx typing/stypes.cmi + parsing/location.cmx utils/clflags.cmx typing/annot.cmi typing/stypes.cmi typing/subst.cmo: typing/types.cmi utils/tbl.cmi typing/path.cmi \ utils/misc.cmi typing/ident.cmi typing/btype.cmi typing/subst.cmi typing/subst.cmx: typing/types.cmx utils/tbl.cmx typing/path.cmx \ @@ -215,14 +233,16 @@ typing/typecore.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \ typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/joinmatching.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \ - typing/btype.cmi parsing/asttypes.cmi typing/typecore.cmi + typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \ + typing/typecore.cmi typing/typecore.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ typing/typejoin.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/joinmatching.cmx \ typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \ - typing/btype.cmx parsing/asttypes.cmi typing/typecore.cmi + typing/btype.cmx 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 \ @@ -253,7 +273,7 @@ typing/typemod.cmo: typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \ parsing/parsetree.cmi typing/mtype.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/includemod.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \ - utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \ typing/typemod.cmi typing/typemod.cmx: typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \ typing/typecore.cmx typing/typeclass.cmx typing/subst.cmx \ @@ -261,7 +281,7 @@ typing/typemod.cmx: typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \ parsing/parsetree.cmi typing/mtype.cmx utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx typing/includemod.cmx \ typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \ - utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \ typing/typemod.cmi typing/types.cmo: typing/primitive.cmi typing/path.cmi utils/misc.cmi \ parsing/location.cmi typing/ident.cmi parsing/asttypes.cmi \ @@ -284,9 +304,12 @@ typing/unused_var.cmx: utils/warnings.cmx parsing/parsetree.cmi \ parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \ typing/unused_var.cmi bytecomp/bytegen.cmi: bytecomp/lambda.cmi bytecomp/instruct.cmi +bytecomp/bytelibrarian.cmi: bytecomp/bytelink.cmi: bytecomp/symtable.cmi bytecomp/cmo_format.cmi bytecomp/bytepackager.cmi: typing/ident.cmi +bytecomp/bytesections.cmi: bytecomp/cmo_format.cmi: bytecomp/lambda.cmi typing/ident.cmi +bytecomp/dll.cmi: bytecomp/emitcode.cmi: bytecomp/instruct.cmi bytecomp/cmo_format.cmi bytecomp/instruct.cmi: typing/types.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi @@ -294,9 +317,12 @@ bytecomp/lambda.cmi: typing/types.cmi typing/primitive.cmi typing/path.cmi \ parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi bytecomp/matching.cmi: typing/typedtree.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi +bytecomp/meta.cmi: bytecomp/printinstr.cmi: bytecomp/instruct.cmi bytecomp/printlambda.cmi: bytecomp/lambda.cmi +bytecomp/runtimedef.cmi: bytecomp/simplif.cmi: bytecomp/lambda.cmi +bytecomp/switch.cmi: bytecomp/symtable.cmi: typing/ident.cmi bytecomp/cmo_format.cmi bytecomp/translclass.cmi: typing/typedtree.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi @@ -305,19 +331,19 @@ bytecomp/translcore.cmi: typing/types.cmi typing/typedtree.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi bytecomp/transljoin.cmi: typing/typedtree.cmi typing/primitive.cmi \ typing/path.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.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/types.cmi typing/typedtree.cmi typing/path.cmi \ bytecomp/lambda.cmi typing/env.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 @@ -348,13 +374,13 @@ bytecomp/bytesections.cmo: utils/config.cmi bytecomp/bytesections.cmi bytecomp/bytesections.cmx: utils/config.cmx bytecomp/bytesections.cmi bytecomp/dll.cmo: utils/misc.cmi utils/config.cmi bytecomp/dll.cmi bytecomp/dll.cmx: utils/misc.cmx utils/config.cmx bytecomp/dll.cmi -bytecomp/emitcode.cmo: bytecomp/translmod.cmi bytecomp/opcodes.cmo \ - utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \ +bytecomp/emitcode.cmo: bytecomp/translmod.cmi typing/primitive.cmi \ + bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \ bytecomp/instruct.cmi typing/env.cmi utils/config.cmi \ bytecomp/cmo_format.cmi utils/clflags.cmi typing/btype.cmi \ parsing/asttypes.cmi bytecomp/emitcode.cmi -bytecomp/emitcode.cmx: bytecomp/translmod.cmx bytecomp/opcodes.cmx \ - utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \ +bytecomp/emitcode.cmx: bytecomp/translmod.cmx typing/primitive.cmx \ + bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \ bytecomp/instruct.cmx typing/env.cmx utils/config.cmx \ bytecomp/cmo_format.cmi utils/clflags.cmx typing/btype.cmx \ parsing/asttypes.cmi bytecomp/emitcode.cmi @@ -370,16 +396,22 @@ bytecomp/lambda.cmx: typing/types.cmx typing/primitive.cmx typing/path.cmx \ parsing/asttypes.cmi bytecomp/lambda.cmi bytecomp/matching.cmo: typing/types.cmi bytecomp/typeopt.cmi \ typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \ - typing/primitive.cmi typing/predef.cmi typing/parmatch.cmi utils/misc.cmi \ - parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ - typing/btype.cmi parsing/asttypes.cmi bytecomp/matching.cmi + typing/primitive.cmi typing/predef.cmi typing/path.cmi \ + typing/parmatch.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + bytecomp/matching.cmi bytecomp/matching.cmx: typing/types.cmx bytecomp/typeopt.cmx \ typing/typedtree.cmx bytecomp/switch.cmx bytecomp/printlambda.cmx \ - typing/primitive.cmx typing/predef.cmx typing/parmatch.cmx utils/misc.cmx \ - parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ - typing/btype.cmx parsing/asttypes.cmi bytecomp/matching.cmi + typing/primitive.cmx typing/predef.cmx typing/path.cmx \ + typing/parmatch.cmx utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + bytecomp/matching.cmi bytecomp/meta.cmo: bytecomp/meta.cmi bytecomp/meta.cmx: bytecomp/meta.cmi +bytecomp/opcodes.cmo: +bytecomp/opcodes.cmx: bytecomp/printinstr.cmo: bytecomp/printlambda.cmi parsing/location.cmi \ bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \ bytecomp/printinstr.cmi @@ -423,27 +455,27 @@ bytecomp/translclass.cmx: typing/types.cmx bytecomp/typeopt.cmx \ bytecomp/translcore.cmo: typing/types.cmi bytecomp/typeopt.cmi \ typing/typejoin.cmi typing/typedtree.cmi bytecomp/translobj.cmi \ bytecomp/transljoin.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 \ + 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/typejoin.cmx typing/typedtree.cmx bytecomp/translobj.cmx \ bytecomp/transljoin.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 \ + 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/transljoin.cmo: typing/types.cmi bytecomp/typeopt.cmi \ typing/typejoin.cmi typing/typedtree.cmi typing/primitive.cmi \ - utils/misc.cmi parsing/longident.cmi bytecomp/lambda.cmi typing/ident.cmi \ - typing/env.cmi utils/clflags.cmi parsing/asttypes.cmi \ - bytecomp/transljoin.cmi + utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/clflags.cmi \ + parsing/asttypes.cmi bytecomp/transljoin.cmi bytecomp/transljoin.cmx: typing/types.cmx bytecomp/typeopt.cmx \ typing/typejoin.cmx typing/typedtree.cmx typing/primitive.cmx \ - utils/misc.cmx parsing/longident.cmx bytecomp/lambda.cmx typing/ident.cmx \ - typing/env.cmx utils/clflags.cmx parsing/asttypes.cmi \ - bytecomp/transljoin.cmi + utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ + bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/clflags.cmx \ + parsing/asttypes.cmi bytecomp/transljoin.cmi bytecomp/translmod.cmo: typing/types.cmi typing/typedtree.cmi \ bytecomp/translobj.cmi bytecomp/transljoin.cmi bytecomp/translcore.cmi \ bytecomp/translclass.cmi typing/printtyp.cmi typing/primitive.cmi \ @@ -475,13 +507,16 @@ bytecomp/typeopt.cmx: typing/types.cmx typing/typedtree.cmx \ bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ parsing/asttypes.cmi bytecomp/typeopt.cmi asmcomp/asmgen.cmi: bytecomp/lambda.cmi asmcomp/cmm.cmi +asmcomp/asmlibrarian.cmi: asmcomp/asmlink.cmi: asmcomp/compilenv.cmi +asmcomp/asmpackager.cmi: asmcomp/clambda.cmi: bytecomp/lambda.cmi typing/ident.cmi \ asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/closure.cmi: bytecomp/lambda.cmi asmcomp/clambda.cmi -asmcomp/cmmgen.cmi: asmcomp/cmm.cmi asmcomp/clambda.cmi +asmcomp/cmmgen.cmi: asmcomp/compilenv.cmi asmcomp/cmm.cmi asmcomp/clambda.cmi asmcomp/cmm.cmi: typing/ident.cmi asmcomp/debuginfo.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 @@ -506,24 +541,26 @@ asmcomp/selectgen.cmi: utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ asmcomp/selection.cmi: asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/spill.cmi: asmcomp/mach.cmi asmcomp/split.cmi: asmcomp/mach.cmi -asmcomp/arch.cmo: 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/arch.cmo: +asmcomp/arch.cmx: +asmcomp/asmgen.cmo: bytecomp/translmod.cmi asmcomp/split.cmi \ + asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \ + asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \ + asmcomp/printlinear.cmi asmcomp/printcmm.cmi typing/primitive.cmi \ + utils/misc.cmi asmcomp/mach.cmi asmcomp/liveness.cmi \ 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 @@ -607,15 +644,13 @@ asmcomp/emitaux.cmx: asmcomp/reg.cmx asmcomp/linearize.cmx \ asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ asmcomp/emitaux.cmi asmcomp/emit.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ - asmcomp/mach.cmi parsing/location.cmi asmcomp/linearize.cmi \ - asmcomp/emitaux.cmi asmcomp/debuginfo.cmi utils/config.cmi \ - asmcomp/compilenv.cmi asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo \ - asmcomp/emit.cmi + asmcomp/mach.cmi asmcomp/linearize.cmi asmcomp/emitaux.cmi \ + asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \ + asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emit.cmi asmcomp/emit.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ - asmcomp/mach.cmx parsing/location.cmx asmcomp/linearize.cmx \ - asmcomp/emitaux.cmx asmcomp/debuginfo.cmx utils/config.cmx \ - asmcomp/compilenv.cmx asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx \ - asmcomp/emit.cmi + asmcomp/mach.cmx asmcomp/linearize.cmx asmcomp/emitaux.cmx \ + asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ + asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emit.cmi asmcomp/interf.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/interf.cmi asmcomp/interf.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ @@ -661,9 +696,9 @@ asmcomp/reloadgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/reloadgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/reloadgen.cmi asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ - asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/reload.cmi + asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/reload.cmi asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \ - asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/reload.cmi + asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/reload.cmi asmcomp/schedgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ asmcomp/schedgen.cmi @@ -680,10 +715,10 @@ asmcomp/selectgen.cmx: utils/tbl.cmx asmcomp/reg.cmx asmcomp/proc.cmx \ asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selectgen.cmi asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi asmcomp/proc.cmi \ utils/misc.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ - asmcomp/arch.cmo asmcomp/selection.cmi + utils/clflags.cmi asmcomp/arch.cmo asmcomp/selection.cmi asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx asmcomp/proc.cmx \ utils/misc.cmx asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ - asmcomp/arch.cmx asmcomp/selection.cmi + utils/clflags.cmx asmcomp/arch.cmx asmcomp/selection.cmi asmcomp/spill.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/spill.cmi asmcomp/spill.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ @@ -693,21 +728,27 @@ asmcomp/split.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/split.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/split.cmi driver/compile.cmi: typing/env.cmi +driver/errors.cmi: +driver/main_args.cmi: +driver/main.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 \ @@ -734,18 +775,18 @@ driver/main.cmx: utils/warnings.cmx utils/misc.cmx driver/main_args.cmx \ bytecomp/bytelibrarian.cmx driver/main.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 \ @@ -778,10 +819,16 @@ driver/pparse.cmx: utils/misc.cmx parsing/location.cmx utils/clflags.cmx \ utils/ccomp.cmx driver/pparse.cmi toplevel/genprintval.cmi: typing/types.cmi typing/path.cmi \ typing/outcometree.cmi typing/env.cmi +toplevel/opttopdirs.cmi: parsing/longident.cmi +toplevel/opttoploop.cmi: utils/warnings.cmi typing/types.cmi typing/path.cmi \ + parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \ + parsing/location.cmi typing/env.cmi +toplevel/opttopmain.cmi: toplevel/topdirs.cmi: parsing/longident.cmi toplevel/toploop.cmi: utils/warnings.cmi typing/types.cmi typing/path.cmi \ parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \ parsing/location.cmi typing/env.cmi +toplevel/topmain.cmi: toplevel/trace.cmi: typing/types.cmi typing/path.cmi parsing/longident.cmi \ typing/env.cmi toplevel/expunge.cmo: bytecomp/symtable.cmi bytecomp/runtimedef.cmi \ @@ -796,6 +843,48 @@ toplevel/genprintval.cmx: typing/types.cmx typing/printtyp.cmx \ typing/predef.cmx typing/path.cmx typing/outcometree.cmi utils/misc.cmx \ parsing/longident.cmx typing/ident.cmx typing/env.cmx typing/datarepr.cmx \ typing/ctype.cmx typing/btype.cmx toplevel/genprintval.cmi +toplevel/opttopdirs.cmo: utils/warnings.cmi typing/types.cmi \ + typing/printtyp.cmi typing/path.cmi toplevel/opttoploop.cmi \ + utils/misc.cmi parsing/longident.cmi typing/ident.cmi typing/env.cmi \ + typing/ctype.cmi utils/config.cmi utils/clflags.cmi asmcomp/asmlink.cmi \ + toplevel/opttopdirs.cmi +toplevel/opttopdirs.cmx: utils/warnings.cmx typing/types.cmx \ + typing/printtyp.cmx typing/path.cmx toplevel/opttoploop.cmx \ + utils/misc.cmx parsing/longident.cmx typing/ident.cmx typing/env.cmx \ + typing/ctype.cmx utils/config.cmx utils/clflags.cmx asmcomp/asmlink.cmx \ + toplevel/opttopdirs.cmi +toplevel/opttoploop.cmo: utils/warnings.cmi typing/unused_var.cmi \ + typing/types.cmi typing/typemod.cmi typing/typedtree.cmi \ + typing/typecore.cmi bytecomp/translmod.cmi bytecomp/simplif.cmi \ + typing/printtyp.cmi bytecomp/printlambda.cmi parsing/printast.cmi \ + typing/predef.cmi typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \ + typing/outcometree.cmi driver/opterrors.cmi driver/optcompile.cmi \ + typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/lexer.cmi bytecomp/lambda.cmi \ + typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi utils/config.cmi \ + asmcomp/compilenv.cmi utils/clflags.cmi typing/btype.cmi \ + asmcomp/asmlink.cmi asmcomp/asmgen.cmi toplevel/opttoploop.cmi +toplevel/opttoploop.cmx: utils/warnings.cmx typing/unused_var.cmx \ + typing/types.cmx typing/typemod.cmx typing/typedtree.cmx \ + typing/typecore.cmx bytecomp/translmod.cmx bytecomp/simplif.cmx \ + typing/printtyp.cmx bytecomp/printlambda.cmx parsing/printast.cmx \ + typing/predef.cmx typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \ + typing/outcometree.cmi driver/opterrors.cmx driver/optcompile.cmx \ + typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx parsing/lexer.cmx bytecomp/lambda.cmx \ + typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx utils/config.cmx \ + asmcomp/compilenv.cmx utils/clflags.cmx typing/btype.cmx \ + asmcomp/asmlink.cmx asmcomp/asmgen.cmx toplevel/opttoploop.cmi +toplevel/opttopmain.cmo: utils/warnings.cmi asmcomp/printmach.cmi \ + toplevel/opttoploop.cmi toplevel/opttopdirs.cmi driver/opterrors.cmi \ + utils/misc.cmi utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo \ + toplevel/opttopmain.cmi +toplevel/opttopmain.cmx: utils/warnings.cmx asmcomp/printmach.cmx \ + toplevel/opttoploop.cmx toplevel/opttopdirs.cmx driver/opterrors.cmx \ + utils/misc.cmx utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx \ + toplevel/opttopmain.cmi +toplevel/opttopstart.cmo: toplevel/opttopmain.cmi +toplevel/opttopstart.cmx: toplevel/opttopmain.cmx toplevel/topdirs.cmo: utils/warnings.cmi typing/types.cmi toplevel/trace.cmi \ toplevel/toploop.cmi bytecomp/symtable.cmi typing/printtyp.cmi \ typing/path.cmi bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi \ @@ -1,23 +1,2378 @@ -- Several alteration of scheduling, so as to - limit pending signals, <= threads in pool and <= tasks in pool. - -- Added 'JoinFifo' and 'JoinCount' in standard library. +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 must correspond to a valid identifier + (no more "test-me.ml" or "my file.ml".) +* 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. +- With -dtypes, record (in .annot files) which function calls + are tail calls. +- All compiler error messages now include a file name and location. +- 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 with 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: debunking 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. + +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 some 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 LabelTk library. + + +Objective Caml 3.10.2: +---------------------- + +Bug fixes: +- PR#1217 (partial) Typo in ocamldep man page +- PR#3952 (partial) ocamlopt: allocation problems on ARM +- PR#4339 (continued) ocamlopt: problems on HPPA +- PR#4455 str.mli not installed under Windows +- PR#4473 crash when accessing float array with polymorphic method +- PR#4480 runtime would not compile without gcc extensions +- PR#4481 wrong typing of exceptions with object arguments +- PR#4490 typo in error message +- Random crash on 32-bit when major_heap_increment >= 2^22 +- Big performance bug in Weak hashtables +- Small bugs in the make-package-macosx script +- Bug in typing of polymorphic variants (reported on caml-list) + +Objective Caml 3.10.1: +---------------------- + +Bug fixes: +- PR#3830 small bugs in docs +- PR#4053 compilers: improved compilation time for large variant types +- PR#4174 ocamlopt: fixed ocamlopt -nopervasives +- PR#4199 otherlibs: documented a small problem in Unix.utimes +- PR#4280 camlp4: parsing of identifier (^) +- PR#4281 camlp4: parsing of type constraint +- PR#4285 runtime: cannot compile under AIX +- PR#4286 ocamlbuild: cannot compile under AIX and SunOS +- PR#4288 compilers: including a functor application with side effects +- PR#4295 camlp4 toplevel: synchronization after an error +- PR#4300 ocamlopt: crash with backtrace and illegal array access +- PR#4302 camlp4: list comprehension parsing problem +- PR#4304 ocamlbuild: handle -I correctly +- PR#4305 stdlib: alignment of Arg.Symbol +- PR#4307 camlp4: assertion failure +- PR#4312 camlp4: accept "let _ : int = 1" +- PR#4313 ocamlbuild: -log and missing directories +- PR#4315 camlp4: constraints in classes +- PR#4316 compilers: crash with recursive modules and Lazy +- PR#4318 ocamldoc: installation problem with Cygwin (tentative fix) +- PR#4322 ocamlopt: stack overflow under Windows +- PR#4325 compilers: wrong error message for unused var +- PR#4326 otherlibs: marshal Big_int on win64 +- PR#4327 ocamlbuild: make emacs look for .annot in _build directory +- PR#4328 camlp4: stack overflow with nil nodes +- PR#4331 camlp4: guards on fun expressions +- PR#4332 camlp4: parsing of negative 32/64 bit numbers +- PR#4336 compilers: unsafe recursive modules +- PR#4337 (note) camlp4: invalid character escapes +- PR#4339 ocamlopt: problems on HP-UX (tentative fix) +- PR#4340 camlp4: wrong pretty-printing of optional arguments +- PR#4348 ocamlopt: crash on Mac Intel +- PR#4349 camlp4: bug in private type definitions +- PR#4350 compilers: type errors with records and polymorphic variants +- PR#4352 compilers: terminal recursion under Windows (tentative fix) +- PR#4354 ocamlcp: mismatch with ocaml on polymorphic let +- PR#4358 ocamlopt: float constants wrong on ARM +- PR#4360 ocamldoc: string inside comment +- PR#4365 toplevel: wrong pretty-printing of polymorphic variants +- PR#4373 otherlibs: leaks in win32unix +- PR#4374 otherlibs: threads module not initialized +- PR#4375 configure: fails to build on bytecode-only architectures +- PR#4377 runtime: finalisation of infix pointers +- PR#4378 ocamlbuild: typo in plugin.ml +- PR#4379 ocamlbuild: problem with plugins under Windows +- PR#4382 compilers: typing of polymorphic record fields +- PR#4383 compilers: including module with private type +- PR#4385 stdlib: Int32/Int64.format are unsafe +- PR#4386 otherlibs: wrong signal numbers with Unix.sigprocmask etc. +- PR#4387 ocamlbuild: build directory not used properly +- PR#4392 ocamldep: optional argument of class +- PR#4394 otherlibs: infinite loops in Str +- PR#4397 otherlibs: wrong size for flag arrays in win32unix +- PR#4402 ocamldebug: doesn't work with -rectypes +- PR#4410 ocamlbuild: problem with plugin and -build +- PR#4411 otherlibs: crash with Unix.access under Windows +- PR#4412 stdlib: marshalling broken on 64 bit architectures +- PR#4413 ocamlopt: crash on AMD64 with out-of-bound access and reraise +- PR#4417 camlp4: pretty-printing of unary minus +- PR#4419 camlp4: problem with constraint in type class +- PR#4426 compilers: problem with optional labels +- PR#4427 camlp4: wrong pretty-printing of lists of functions +- PR#4433 ocamlopt: fails to build on MacOSX 10.5 +- PR#4435 compilers: crash with objects +- PR#4439 fails to build on MacOSX 10.5 +- PR#4441 crash when build on sparc64 linux +- PR#4442 stdlib: crash with weak pointers +- PR#4446 configure: fails to detect X11 on MacOSX 10.5 +- PR#4448 runtime: huge page table on 64-bit architectures +- PR#4450 compilers: stack overflow with recursive modules +- PR#4470 compilers: type-checking of recursive modules too restrictive +- PR#4472 configure: autodetection of libX11.so on Fedora x86_64 +- printf: removed (partially implemented) positional specifications +- polymorphic < and <= comparisons: some C compiler optimizations + were causing incorrect results when arguments are incomparable + +New features: +- made configure script work on PlayStation 3 +- ARM port: brought up-to-date for Debian 4.0 (Etch) +- many other small changes and bugfixes in camlp4, ocamlbuild, labltk, + emacs files + + +Objective Caml 3.10.0: +---------------------- + +(Changes that can break existing programs are marked with a "*" ) + +Language features: +- Added virtual instance variables in classes "val virtual v : t" +* Changed the behaviour of instance variable overriding; the new + definition replaces the old one, rather than creating a new + variable. + +New tools: +- ocamlbuild: compilation manager for OCaml applications and libraries. + See draft documentation at http://gallium.inria.fr/~pouillar/ +* Camlp4: heavily revised implementation, new API. + +New ports: +- MacOS X PowerPC 64 bits. +- MS Windows 64 bits (x64) using the Microsoft PSDK toolchain. +- MS Windows 32 bits using the Visual Studio 2005 toolchain. + +Compilers: +- Faster type-checking of functor applications. +- Referencing an interface compiled with -rectypes from a module + not compiled with -rectypes is now an error. +- Revised the "fragile matching" warning. + +Native-code compiler: +- Print a stack backtrace on an uncaught exception. + (Compile and link with ocamlopt -g; execute with OCAMLRUNPARAM=b.) + Supported on Intel/AMD in 32 and 64 bits, PPC in 32 and 64 bits. +- Stack overflow detection on MS Windows 32 bits (courtesy O. Andrieu). +- Stack overflow detection on MacOS X PPC and Intel. +- Intel/AMD 64 bits: generate position-independent code by default. +- Fixed bug involving -for-pack and missing .cmx files (PR#4124). +- Fixed bug causing duplication of literals (PR#4152). + +Run-time system: +- C/Caml interface functions take "char const *" arguments + instead of "char *" when appropriate. +- Faster string comparisons (fast case if strings are ==). + +Standard library: +- Refined typing of format strings (type format6). +- Printf, Format: new function ifprintf that consumes its arguments + and prints nothing (useful to print conditionally). +- Scanf: + new function format_from_string to convert a string to a format string; + new %r conversion to accomodate user defined scanners. +- Filename: improved Win32 implementation of Filename.quote. +- List: List.nth now tail-recursive. +- Sys: added Sys.is_directory. Some functions (e.g. Sys.command) that + could incorrectly raise Sys_io_blocked now raise Sys_error as intended. +- 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 + the start position of the data in the mapped file. +- Dynlink: now defines only two modules, Dynlink and Dynlinkaux (internal), + reducing risks of name conflicts with user modules. +- Labltk under Win32: now uses Tcl/Tk 8.4 instead of 8.3 by default. +- VM threads: improved performance of I/O operations (less polling). +- Unix: new function Unix.isatty. +- Unix emulation under Win32: + fixed incorrect error reporting in several functions (PR#4097); + better handling of channels opened on sockets (PR#4098); + fixed GC bug in Unix.system (PR#4112). + +Documentation generator (OCamldoc): +- correctly handle '?' in value names (PR#4215) +- new option -hide-warnings not to print ocamldoc warnings + +Lexer generator (ocamllex): improved error reporting. + +License: fixed a typo in the "special exception" to the LGPL. + + +Objective Caml 3.09.3: +---------------------- + +Bug fixes: +- ocamldoc: -using modtype constraint to filter module elements displayed + in doc PR#4016 +- ocamldoc: error in merging of top dependencies of modules PR#4007 +- ocamldoc: -dot-colors has no effect PR#3981 +- ocamdloc: missing crossref in text from intro files PR#4066 +- compilers: segfault with recursive modules PR#4008 +- compilers: infinite loop when compiling objects PR#4018 +- compilers: bad error message when signature mismatch PR#4001 +- compilers: infinite loop with -rectypes PR#3999 +- compilers: contravariance bug in private rows +- compilers: unsafe cast with polymorphic exception PR#4002 +- native compiler: bad assembly code generated for AMD64 PR#4067 +- native compiler: stack alignment problems on MacOSX/i386 PR#4036 +- stdlib: crash in marshalling PR#4030 +- stdlib: crash when closing a channel twice PR#4039 +- stdlib: memory leak in Sys.readdir PR#4093 +- C interface: better definition of CAMLreturn PR#4068 +- otherlibs/unix: crash in gethostbyname PR#3043 +- tools: subtle problem with unset in makefile PR#4048 +- camlp4: install pa_o_fast.o PR#3812 +- camlp4: install more modules PR#3689 + +New features: +- ocamldoc: name resolution in cross-referencing {!name}: if name is not + found, then it is searched in the parent module/class, and in the parent + of the parent, and so on until it is found. +- ocamldoc: new option -short-functors to use a short form to display + functors in html generator PR#4017 +- ocamlprof: added "-version" option + + + +Objective Caml 3.09.2: +---------------------- + +Bug fixes: +- Makefile: problem with "make world.opt" PR#3954 +- compilers: problem compiling several modules with one command line PR#3979 +- compilers,ocamldoc: error message that Emacs cannot parse +- compilers: crash when printing type error PR#3968 +- compilers: -dtypes wrong for monomorphic type variables PR#3894 +- compilers: wrong warning on optional arguments PR#3980 +- compilers: crash when wrong use of type constructor in let rec PR#3976 +- compilers: better wording of "statement never returns" warning PR#3889 +- runtime: inefficiency of signal handling PR#3990 +- runtime: crashes with I/O in multithread programs PR#3906 +- camlp4: empty file name in error messages PR#3886 +- camlp4: stack overflow PR#3948 +- otherlibs/labltk: ocamlbrowser ignores its command line options PR#3961 +- otherlibs/unix: Unix.times wrong under Mac OS X PR#3960 +- otherlibs/unix: wrong doc for execvp and execvpe PR#3973 +- otherlibs/win32unix: random crash in Unix.stat PR#3998 +- stdlib: update_mod not found under Windows PR#3847 +- stdlib: Filename.dirname/basename wrong on Win32 PR#3933 +- stdlib: incomplete documentation of Pervasives.abs PR#3967 +- stdlib: Printf bugs PR#3902, PR#3955 +- tools/checkstack.c: missing include +- yacc: crash when given argument "-" PR#3956 + +New features: +- ported to MacOS X on Intel PR#3985 +- configure: added support for GNU Hurd PR#3991 + +Objective Caml 3.09.1: +---------------------- + +Bug fixes: +- compilers: raise not_found with -principal PR#3855 +- compilers: assert failure in typeclass.cml PR#3856 +- compilers: assert failure in typing/ctype.ml PR#3909 +- compilers: fatal error exception Ctype.Unify PR#3918 +- compilers: spurious warning Y in objects PR#3868 +- compilers: spurious warning Z on loop index PR#3907 +- compilers: error message that emacs cannot parse +- ocamlopt: problems with -for-pack/-pack PR#3825, PR#3826, PR#3919 +- ocamlopt: can't produce shared libraries on x86_64 PR#3869, PR#3924 +- ocamlopt: float alignment problem on SPARC PR#3944 +- ocamlopt: can't compile on MIPS PR#3936 +- runtime: missing dependence for ld.conf +- runtime: missing dependence for .depend.nt PR#3880 +- runtime: memory leak in caml_register_named_value PR#3940 +- runtime: crash in Marshal.to_buffer PR#3879 +- stdlib: Sys.time giving wrong results on Mac OS X PR#3850 +- stdlib: Weak.get_copy causing random crashes in rare cases +- stdlib, debugger, labltk: use TMPDIR if set PR#3895 +- stdlib: scanf bug on int32 and nativeint PR#3932 +- camlp4: mkcamlp4 option parsing problem PR#3941 +- camlp4: bug in pretty-printing of lazy/assert/new +- camlp4: update the unmaintained makefile for _loc name +- ocamldoc: several fixes see ocamldoc/Changes.txt +- otherlibs/str: bug in long sequences of alternatives PR#3783 +- otherlibs/systhreads: deadlock in Windows PR#3910 +- tools: update dumpobj to handle new event format PR#3873 +- toplevel: activate warning Y in toplevel PR#3832 + +New features: +- otherlibs/labltk: browser uses menu bars instead of menu buttons + +Objective Caml 3.09.0: +---------------------- -- Started a bit of emacs mode. +(Changes that can break existing programs are marked with a "*" ) -- Added module 'JoinProc' in standard library. +Language features: +- Introduction of private row types, for abstracting the row in object + and variant types. -- Handle type constraints in join-patterns (slight change - in typecore). +Type checking: +- Polymorphic variants with at most one constructor [< `A of t] are no + longer systematically promoted to the exact type [`A of t]. This was + more confusing than useful, and created problems with private row + types. -- Unused var warning corrected. +Both compilers: +- Added warnings 'Y' and 'Z' for local variables that are bound but + never used. +- Added warning for some uses non-returning functions (e.g. raise), when they + are passed extra arguments, or followed by extra statements. +- Pattern matching: more prudent compilation in case of guards; fixed PR#3780. +- Compilation of classes: reduction in size of generated code. +- Compilation of "module rec" definitions: fixed a bad interaction with + structure coercion (to a more restrictive signature). -- In Join_space: rid_from_space catches Join_space.NoLink in all situations and - raises Join.Exit. -> site_of_addr raise Join.Exit when - remote site is dead. +Native-code compiler (ocamlopt): +* Revised implementation of the -pack option (packing of several compilation + units into one). The .cmx files that are to be packed with + "ocamlopt -pack -o P.cmx" must be compiled with "ocamlopt -for-pack P". + In exchange for this additional constraint, ocamlopt -pack is now + available on all platforms (no need for binutils). +* Fixed wrong evaluation order for arguments to certain inlined functions. +- Modified code generation for "let rec ... and ..." to reduce compilation + time (which was quadratic in the number of mutually-recursive functions). +- x86 port: support tail-calls for functions with up to 21 arguments. +- AMD64 port, Linux: recover from system stack overflow. +- Sparc port: more portable handling of out-of-bound conditions + on systems other than Solaris. -- Be more eager to fork (tasks were entered uselessly in pool) +Standard library: +- Pervasives: faster implementation of close_in, close_out. + set_binary_mode_{out,in} now working correctly under Cygwin. +- Printf: better handling of partial applications of the printf functions. +- Scanf: new function sscanf_format to read a format from a + string. The type of the resulting format is dynamically checked and + should be the type of the template format which is the second argument. +- Scanf: no more spurious lookahead attempt when the end of file condition + is set and a correct token has already been read and could be returned. -JoCaml 3.10.0: +Other libraries: +- System threads library: added Thread.sigmask; fixed race condition + in signal handling. +- Bigarray library: fixed bug in Array3.of_array. +- Unix library: use canonical signal numbers in results of Unix.wait*; + hardened Unix.establish_server against EINTR errors. + +Run-time system: +- Support platforms where sizeof(void *) = 8 and sizeof(long) = 4. +- Improved and cleaned up implementation of signal handling. + +Replay debugger: +- Improved handling of locations in source code. + +OCamldoc: +- extensible {foo } syntax +- user can give .txt files on the command line, containing ocamldoc formatted + text, to be able to include bigger texts out of source files +- -o option is now used by the html generator to indicate the prefix + of generated index files (to avoid conflict when a Index module exists + on case-insensitive file systems). + +Miscellaneous: +- Configuration information is installed in `ocamlc -where`/Makefile.config + and can be used by client Makefiles or shell scripts. + +Objective Caml 3.08.4: +---------------------- + +New features: +- configure: find X11 config in some 64-bit Linux distribs +- ocamldoc: (**/**) can be canceled with another (**/**) PR#3665 +- graphics: added resize_window +- graphics: check for invalid arguments to drawing primitives PR#3595 +- ocamlbrowser: use windows subsystem on mingw + +Bug fixes: +- ocamlopt: code generation problem on AMD64 PR#3640 +- wrong code generated for some classes PR#3576 +- fatal error when compiling some OO code PR#3745 +- problem with comparison on constant constructors PR#3608 +- camlp4: cryptic error message PR#3592 +- camlp4: line numbers in multi-line antiquotations PR#3549 +- camlp4: problem with make depend +- camlp4: parse error with :> PR#3561 +- camlp4: ident conversion problem with val/contents/contents__ +- camlp4: several small parsing problems PR#3688 +- ocamldebug: handling of spaces in executable file name PR#3736 +- emacs-mode: problem when caml-types-buffer is deleted by user PR#3704 +- ocamldoc: extra backslash in ocamldoc man page PR#3687 +- ocamldoc: improvements to HTML display PR#3698 +- ocamldoc: escaping of @ in info files +- ocamldoc: escaping of . and \ in man pages PR#3686 +- ocamldoc: better error reporting of misplaced comments +- graphics: fixed .depend file PR#3558 +- graphics: segfault with threads and graphics PR#3651 +- nums: several bugs: PR#3718, PR#3719, others +- nums: inline asm problems with gcc 4.0 PR#3604, PR#3637 +- threads: problem with backtrace +- unix: problem with getaddrinfo PR#3565 +- stdlib: documentation of Int32.rem and Int64.rem PR#3573 +- stdlib: documentation of List.rev_map2 PR#3685 +- stdlib: wrong order in Map.fold PR#3607 +- stdlib: documentation of maximum float array length PR#3714 +- better detection of cycles when using -rectypes +- missing case of module equality PR#3738 +- better error messages for unbound type variables +- stack overflow while printing type error message PR#3705 +- assert failure when typing some classes PR#3638 +- bug in type_approx +- better error messages related to type variance checking +- yacc: avoid name capture for idents of the Parsing module + + +Objective Caml 3.08.3: +---------------------- + +New features: +- support for ocamlopt -pack under Mac OS X (PR#2634, PR#3320) +- ignore unknown warning options for forward and backward compatibility +- runtime: export caml_compare_unordered (PR#3479) +- camlp4: install argl.* files (PR#3439) +- ocamldoc: add -man-section option +- labltk: add the "solid" relief option (PR#3343) + +Bug fixes: +- typing: fix unsoundness in type declaration variance inference. + Type parameters which are constrained must now have an explicit variant + annotation, otherwise they are invariant. This is not backward + compatible, so this might break code which either uses subtyping or + uses the relaxed value restriction (i.e. was not typable before 3.07) +- typing: erroneous partial match warning for polymorphic variants (PR#3424) +- runtime: handle the case of an empty command line (PR#3409, PR#3444) +- stdlib: make Sys.executable_name an absolute path in native code (PR#3303) +- runtime: fix memory leak in finalise.c +- runtime: auto-trigger compaction even if gc is called manually (PR#3392) +- stdlib: fix segfault in Obj.dup on zero-sized values (PR#3406) +- camlp4: correct parsing of the $ identifier (PR#3310, PR#3469) +- windows (MS tools): use link /lib instead of lib (PR#3333) +- windows (MS tools): change default install destination +- autoconf: better checking of SSE2 instructions (PR#3329, PR#3330) +- graphics: make close_graph close the X display as well as the window (PR#3312) +- num: fix big_int_of_string (empty string) (PR#3483) +- num: fix big bug on 64-bit architecture (PR#3299) +- str: better documentation of string_match and string_partial_match (PR#3395) +- unix: fix file descriptor leak in Unix.accept (PR#3423) +- unix: miscellaneous clean-ups +- unix: fix documentation of Unix.tm (PR#3341) +- graphics: fix problem when allocating lots of images under Windows (PR#3433) +- compiler: fix error message with -pack when .cmi is missing (PR#3028) +- cygwin: fix problem with compilation of camlheader (PR#3485) +- stdlib: Filename.basename doesn't return an empty string any more (PR#3451) +- stdlib: better documentation of Open_excl flag (PR#3450) +- ocamlcp: accept -thread option (PR#3511) +- ocamldep: handle spaces in file names (PR#3370) +- compiler: remove spurious warning in pattern-matching on variants (PR#3424) +- windows: better handling of InterpreterPath registry entry (PR#3334, PR#3432) + + +Objective Caml 3.08.2: +---------------------- + +Bug fixes: +- runtime: memory leak when unmarshalling big data structures (PR#3247) +- camlp4: incorrect line numbers in errors (PR#3188) +- emacs: xemacs-specific code, wrong call to "sit-for" +- ocamldoc: "Lexing: empty token" (PR#3173) +- unix: problem with close_process_* (PR#3191) +- unix: possible coredumps (PR#3252) +- stdlib: wrong order in Set.fold (PR#3161) +- ocamlcp: array out of bounds in profiled programs (PR#3267) +- yacc: problem with polymorphic variant types for grammar entries (PR#3033) + +Misc: +- export <caml/printexc.h> for caml_format_exception (PR#3080) +- clean up caml_search_exe_in_path (maybe PR#3079) +- camlp4: new function "make_lexer" for new-style locations +- unix: added missing #includes (PR#3088) + + +Objective Caml 3.08.1: +---------------------- + +Licence: +- The emacs files are now under GPL +- Slightly relaxed some conditions of the QPL + +Bug fixes: +- ld.conf now generated at compile-time instead of install-time +- fixed -pack on Windows XP (PR#2935) +- fixed Obj.tag (PR#2946) +- added support for multiple dlopen in Darwin +- run ranlib when installing camlp4 libraries (PR#2944) +- link camlp4opt with -linkall (PR#2949) +- camlp4 parsing of patterns now conforms to normal parsing (PR#3015) +- install camlp4 *.cmx files (PR#2955) +- fixed handling of linefeed in string constants in camlp4 (PR#3074) +- ocamldoc: fixed display of class parameters in HTML and LaTeX (PR#2994) +- ocamldoc: fixed display of link to class page in html (PR#2994) +- Windows toplevel GUI: assorted fixes (including PR#2932) + +Misc: +- added -v option to ocamllex +- ocamldoc: new -intf and -impl options supported (PR#3036) + +Objective Caml 3.08.0: ---------------------- - First public release + +(Changes that can break existing programs are marked with a "*" ) + +Language features: +- Support for immediate objects, i.e. objects defined without going + through a class. (Syntax is "object <fields and methods> end".) + +Type-checking: +- When typing record construction and record patterns, can omit + the module qualification on all labels except one. I.e. + { M.l1 = ...; l2 = ... } is interpreted as { M.l1 = ...; M.l2 = ... } + +Both compilers: +- More compact compilation of classes. +- Much more efficient handling of class definitions inside functors + or local modules. +- Simpler representation for method tables. Objects can now be marshaled + between identical programs with the flag Marshal.Closures. +- Improved error messages for objects and variants. +- Improved printing of inferred module signatures (toplevel and ocamlc -i). + Recursion between type, class, class type and module definitions is now + correctly printed. +- The -pack option now accepts compiled interfaces (.cmi files) in addition + to compiled implementations (.cmo or .cmx). +* A compile-time error is signaled if an integer literal exceeds the + range of representable integers. +- Fixed code generation error for "module rec" definitions. +- The combination of options -c -o sets the name of the generated + .cmi / .cmo / .cmx files. + +Bytecode compiler: +- Option -output-obj is now compatible with Dynlink and + with embedded toplevels. + +Native-code compiler: +- Division and modulus by zero correctly raise exception Division_by_zero + (instead of causing a hardware trap). +- Improved compilation time for the register allocation phase. +- The float constant -0.0 was incorrectly treated as +0.0 on some processors. +- AMD64: fixed bugs in asm glue code for GC invocation and exception raising + from C. +- IA64: fixed incorrect code generated for "expr mod 1". +- PowerPC: minor performance tweaks for the G4 and G5 processors. + +Standard library: +* Revised handling of NaN floats in polymorphic comparisons. + The polymorphic boolean-valued comparisons (=, <, >, etc) now treat + NaN as uncomparable, as specified by the IEEE standard. + The 3-valued comparison (compare) treats NaN as equal to itself + and smaller than all other floats. As a consequence, x == y + no longer implies x = y but still implies compare x y = 0. +* String-to-integer conversions now fail if the result overflows + the range of integers representable in the result type. +* All array and string access functions now raise + Invalid_argument("index out of bounds") when a bounds check fails. + In earlier releases, different exceptions were raised + in bytecode and native-code. +- Module Buffer: new functions Buffer.sub, Buffer.nth +- Module Int32: new functions Int32.bits_of_float, Int32.float_of_bits. +- Module Map: new functions is_empty, compare, equal. +- Module Set: new function split. +* Module Gc: in-order finalisation, new function finalise_release. + +Other libraries: +- The Num library: complete reimplementation of the C/asm lowest + layer to work around potential licensing problems. + Improved speed on the PowerPC and AMD64 architectures. +- The Graphics library: improved event handling under MS Windows. +- The Str library: fixed bug in "split" functions with nullable regexps. +- The Unix library: + . Added Unix.single_write. + . Added support for IPv6. + . Bug fixes in Unix.closedir. + . Allow thread switching on Unix.lockf. + +Runtime System: +* Name space depollution: all global C identifiers are now prefixed + with "caml" to avoid name clashes with other libraries. This + includes the "external" primitives of the standard runtime. + +Ports: +- Windows ports: many improvements in the OCamlWin toplevel application + (history, save inputs to file, etc). Contributed by Christopher A. Watford. +- Native-code compilation supported for HPPA/Linux. Contributed by Guy Martin. +- Removed support for MacOS9. Mac OS 9 is obsolete and the port was not + updated since 3.05. +- Removed ocamlopt support for HPPA/Nextstep and Power/AIX. + +Ocamllex: +- #line directives in the input file are now accepted. +- Added character set concatenation operator "cset1 # cset2". + +Ocamlyacc: +- #line directives in the input file are now accepted. + +Camlp4: +* Support for new-style locations (line numbers, not just character numbers). +- See camlp4/CHANGES and camlp4/ICHANGES for more info. + + +Objective Caml 3.07: +-------------------- + +Language features: +- Experimental support for recursive module definitions + module rec A : SIGA = StructA and B : SIGB = StructB and ... +- Support for "private types", or more exactly concrete data types + with private constructors or labels. These data types can be + de-structured normally in pattern matchings, but values of these + types cannot be constructed directly outside of their defining module. +- Added integer literals of types int32, nativeint, int64 + (written with an 'l', 'n' or 'L' suffix respectively). + +Type-checking: +- Allow polymorphic generalization of covariant parts of expansive + expressions. For instance, if f: unit -> 'a list, "let x = f ()" + gives "x" the generalized type forall 'a. 'a list, instead of '_a list + as before. +- The typing of polymorphic variants in pattern matching has changed. + It is intended to be more regular, sticking to the principle of "closing + only the variants which would be otherwise incomplete". Two potential + consequences: (1) some types may be left open which were closed before, + and the resulting type might not match the interface anymore (expected to + be rare); (2) in some cases an incomplete match may be generated. +- Lots of bug fixes in the handling of polymorphism and recursion inside + types. +- Added a new "-dtypes" option to ocamlc/ocamlopt, and an emacs extension + "emacs/caml-types.el". The compiler option saves inferred type information + to file *.annot, and the emacs extension allows the user to look at the + type of any subexpression in the source file. Works even in the case + of a type error (all the types computed up to the error are available). + This new feature is also supported by ocamlbrowser. +- Disable "method is overriden" warning when the method was explicitly + redefined as virtual beforehand (i.e. not through inheritance). Typing + and semantics are unchanged. + +Both compilers: +- Added option "-dtypes" to dump detailed type information to a file. +- The "-i" option no longer generates compiled files, it only prints + the inferred types. +- The sources for the module named "Mod" can be placed either in Mod.ml or + in mod.ml. +- Compilation of "let rec" on non-functional values: tightened some checks, + relaxed some other checks. +- Fixed wrong code that was generated for "for i = a to max_int" + or "for i = a downto min_int". +- An explicit interface Mod.mli can now be provided for the module obtained + by ocamlc -pack -o Mod.cmo ... or ocamlopt -pack -o Mod.cmx ... +- Revised internal handling of source code locations, now handles + preprocessed code better. +- Pattern-matching bug on float literals fixed. +- Minor improvements on pattern-matching over variants. +- More efficient compilation of string comparisons and the "compare" function. +- More compact code generated for arrays of constants. +- Fixed GC bug with mutable record fields of type "exn". +- Added warning "E" for "fragile patterns": pattern matchings that would + not be flagged as partial if new constructors were added to the data type. + +Bytecode compiler: +- Added option -vmthread to select the threads library with VM-level + scheduling. The -thread option now selects the system threads library. + +Native-code compiler: +- New port: AMD64 (Opteron). +- Fixed instruction selection bug on expressions of the kind (raise Exn)(arg). +- Several bug fixes in ocamlopt -pack (tracking of imported modules, + command line too long). +- Signal handling bug fixed. +- x86 port: + Added -ffast-math option to use inline trigo and log functions. + Small performance tweaks for the Pentium 4. + Fixed illegal "imul" instruction generated by reloading phase. +- Sparc port: + Enhanced code generation for Sparc V8 (option -march=v8) and + Sparc V9 (option -march=v9). + Profiling support added for Solaris. +- PowerPC port: + Keep stack 16-aligned for compatibility with C calling conventions. + +Toplevel interactive system: +- Tightened interface consistency checks between .cmi files, .cm[oa] files + loaded by #load, and the running toplevel. +- #trace on mutually-recursive functions was broken, works again. +- Look for .ocamlinit file in home directory in addition to the current dir. + +Standard library: +- Match_failure and Assert_failure exceptions now report + (file, line, column), instead of (file, starting char, ending char). +- float_of_string, int_of_string: some ill-formed input strings were not + rejected. +- Added format concatenation, string_of_format, format_of_string. +- Module Arg: added new option handlers Set_string, Set_int, Set_float, + Symbol, Tuple. +- Module Format: tag handling is now turned off by default, + use [Format.set_tags true] to activate. +- Modules Lexing and Parsing: added better handling of positions + in source file. Added function Lexing.flush_input. +- Module Scanf: %n and %N formats to count characters / items read so far; + assorted bug fixes, %! to match end of input. New ``_'' special + flag to skip reresulting value. +- Module Format: tags are not activated by default. +- Modules Set and Map: fixed bugs causing trees to become unbalanced. +- Module Printf: less restrictive typing of kprintf. +- Module Random: better seeding; functions to generate random int32, int64, + nativeint; added support for explicit state management. +- Module Sys: added Sys.readdir for reading the contents of a directory. + +Runtime system: +- output_value/input_value: fixed bug with large blocks (>= 4 Mwords) + produced on a 64-bit platform and incorrectly read back on a 32-bit + platform. +- Fixed memory compaction bug involving input_value. +- Added MacOS X support for dynamic linking of C libraries. +- Improved stack backtraces on uncaught exceptions. +- Fixed float alignment problem on Sparc V9 with gcc 3.2. + +Other libraries: +- Dynlink: + By default, dynamically-loaded code now has access to all + modules defined by the program; new functions Dynlink.allow_only + and Dynlink.prohibit implement access control. + Fixed Dynlink problem with files generated with ocamlc -pack. + Protect against references to modules not yet fully initialized. +- LablTK/CamlTK: added support for TCL/TK 8.4. +- Str: reimplemented regexp matching engine, now less buggy, faster, + and LGPL instead of GPL. +- Graphics: fixed draw_rect and fill_rect bug under X11. +- System threads and bytecode threads libraries can be both installed. +- System threads: better implementation of Thread.exit. +- Bytecode threads: fixed two library initialization bugs. +- Unix: make Unix.openfile blocking to account for named pipes; + GC bug in Unix.*stat fixed; fixed problem with Unix.dup2 on Windows. + +Ocamllex: +- Can name parts of the matched input text, e.g. + "0" (['0'-'7']+ as s) { ... s ... } + +Ocamldebug: +- Handle programs that run for more than 2^30 steps. + +Emacs mode: +- Added file caml-types.el to interactively display the type information + saved by option -dtypes. + +Win32 ports: +- Cygwin port: recognize \ as directory separator in addition to / +- MSVC port: ocamlopt -pack works provided GNU binutils are installed. +- Graphics library: fixed bug in Graphics.blit_image; improved event handling. + +OCamldoc: +- new ty_code field for types, to keep code of a type (with option -keep-code) +- new ex_code field for types, to keep code of an exception + (with option -keep-code) +- some fixes in html generation +- don't overwrite existing style.css file when generating HTML +- create the ocamldoc.sty file when generating LaTeX (if nonexistent) +- man pages are now installed in man/man3 rather than man/mano +- fix: empty [] in generated HTML indexes + + +Objective Caml 3.06: +-------------------- + +Type-checking: +- Apply value restriction to polymorphic record fields. + +Run-time system: +- Fixed GC bug affecting lazy values. + +Both compilers: +- Added option "-version" to print just the version number. +- Fixed wrong dependencies in .cmi generated with the -pack option. + +Native-code compiler: +- Fixed wrong return value for inline bigarray assignments. + +Libraries: +- Unix.getsockopt: make sure result is a valid boolean. + +Tools: +- ocamlbrowser: improved error reporting; small Win32 fixes. + +Windows ports: +- Fixed two problems with the Mingw port under Cygwin 1.3. + + +Objective Caml 3.05: +-------------------- + +Language features: +- Support for polymorphic methods and record fields. +- Allows _ separators in integer and float literals, e.g. 1_000_000. + +Type-checker: +- New flag -principal to enforce principality of type inference. +- Fixed subtle typing bug with higher-order functors. +- Fixed several complexity problems; changed (again) the behaviour of + simple coercions. +- Fixed various bugs with objects and polymorphic variants. +- Improved some error messages. + +Both compilers: +- Added option "-pack" to assemble several compilation units as one unit + having the given units as sub-modules. +- More precise detection of unused sub-patterns in "or" patterns. +- Warnings for ill-formed \ escapes in string and character literals. +- Protect against spaces and other special characters in directory names. +- Added interface consistency check when building a .cma or .cmxa library. +- Minor reduction in code size for class initialization code. +- Added option "-nostdlib" to ignore standard library entirely. + +Bytecode compiler: +- Fixed issue with ocamlc.opt and dynamic linking. + +Native-code compiler: +- Added link-time check for multiply-defined module names. +- Fixed GC bug related to constant constructors of polymorphic variant types. +- Fixed compilation bug for top-level "include" statements. +- PowerPC port: work around limited range for relative branches, + thus removing assembler failures on large functions. +- IA64 port: fixed code generation bug for 3-way constructor matching. + +Toplevel interactive system: +- Can load object files given on command line before starting up. +- ocamlmktop: minimized possibility of name clashes with user-provided modules. + +Run-time system: +- Minor garbage collector no longer recursive. +- Better support for lazy data in the garbage collector. +- Fixed issues with the heap compactor. +- Fixed issues with finalized Caml values. +- The type "int64" is now supported on all platforms: we use software + emulation if the C compiler doesn't support 64-bit integers. +- Support for float formats that are neither big-endian nor little-endian + (one known example: the ARM). +- Fixed bug in callback*_exn functions in the exception-catching case. +- Work around gcc 2.96 bug on RedHat 7.2 and Mandrake 8.0, 8.1 among others. +- Stub DLLs now installed in subdir stublibs/ of standard library dir. + +Standard library: +- Protect against integer overflow in sub-string and sub-array bound checks. +- New module Complex implementing arithmetic over complex numbers. +- New module Scanf implementing format-based scanning a la scanf() in C. +- Module Arg: added alternate entry point Arg.parse_argv. +- Modules Char, Int32, Int64, Nativeint, String: added type "t" and function + "compare" so that these modules can be used directly with e.g. Set.Make. +- Module Digest: fixed issue with Digest.file on large files (>= 1Gb); + added Digest.to_hex. +- Module Filename: added Filename.open_temp_file to atomically create and + open the temp file; improved security of Filename.temp_file. +- Module Genlex: allow _ as first character of an identifier. +- Module Lazy: more efficient implementation. +- Module Lexing: improved performances for very large tokens. +- Module List: faster implementation of sorting functions. +- Module Printf: + added %S and %C formats (quoted, escaped strings and characters); + added kprintf (calls user-specified continuation on formatted string). +- Module Queue: faster implementation (courtesy of François Pottier). +- Module Random: added Random.bool. +- Module Stack: added Stack.is_empty. +- Module Pervasives: + added sub-module LargeFile to support files larger than 1Gb + (file offsets are int64 rather than int); + opening in "append" mode automatically sets "write" mode; + files are now opened in close-on-exec mode; + string_of_float distinguishes its output from a plain integer; + faster implementation of input_line for long lines. +- Module Sys: + added Sys.ocaml_version containing the OCaml version number; + added Sys.executable_name containing the (exact) path of the + file being executable; + Sys.argv.(0) is now unchanged w.r.t. what was provided as 0-th argument + by the shell. +- Module Weak: added weak hash tables. + +Other libraries: +- Bigarray: + support for bigarrays of complex numbers; + added functions Genarray.dims, + {Genarray,Array1,Array2,Array3}.{kind,layout}. +- Dynlink: fixed bug with loading of mixed-mode Caml/C libraries. +- LablTK: + now supports also the CamlTK API (no labels); + support for Activate and Deactivate events; + support for virtual events; + added UTF conversion; + export the tcl interpreter as caml value, to avoid DLL dependencies. +- Unix: + added sub-module LargeFile to support files larger than 1Gb + (file offsets are int64 rather than int); + added POSIX opening flags (O_NOCTTY, O_*SYNC); + use reentrant functions for gethostbyname and gethostbyaddr when available; + fixed bug in Unix.close_process and Unix.close_process_full; + removed some overhead in Unix.select. + +Tools: +- ocamldoc (the documentation generator) is now part of the distribution. +- Debugger: now supports the option -I +dir. +- ocamllex: supports the same identifiers as ocamlc; warns for + bad \ escapes in strings and characters. +- ocamlbrowser: + recenter the module boxes when showing a cross-reference; + include the current directory in the ocaml path. + +Windows port: +- Can now compile with Mingw (the GNU compilers without the Cygwin + runtime library) in addition to MSVC. +- Toplevel GUI: wrong filenames were given to #use and #load commands; + read_line() was buggy for short lines (2 characters or less). +- OCamlBrowser: now fully functional. +- Graphics library: fixed several bugs in event handling. +- Threads library: fixed preemption bug. +- Unix library: better handling of the underlying differences between + sockets and regular file descriptors; + added Unix.lockf and a better Unix.rename (thanks to Tracy Camp). +- LablTk library: fixed a bug in Fileinput + + +Objective Caml 3.04: +-------------------- + +Type-checker: +- Allowed coercing self to the type of the current class, avoiding + an obscure error message about "Self type cannot be unified..." + +Both compilers: +- Use OCAMLLIB environment variable to find standard library, falls + back on CAMLLIB if not defined. +- Report out-of-range ASCII escapes in character or string literals + such as "\256". + +Byte-code compiler: +- The -use-runtime and -make-runtime flags are back by popular demand + (same behavior as in 3.02). +- Dynamic loading (of the C part of mixed Caml/C libraries): arrange that + linking in -custom mode uses the static libraries for the C parts, + not the shared libraries, for maximal robustness and compatibility with + 3.02. + +Native-code compiler: +- Fixed bug in link-time consistency checking. + +Tools: +- ocamlyacc: added parser debugging support (set OCAMLRUNPARAM=p to get + a trace of the pushdown automaton actions). +- ocamlcp: was broken in 3.03 (Sys_error), fixed. + +Run-time system: +- More work on dynamic loading of the C part of mixed Caml/C libraries. +- On uncaught exception, flush output channels before printing exception + message and backtrace. +- Corrected several errors in exception backtraces. + +Standard library: +- Pervasives: integer division and modulus are now fully specified + on negative arguments (with round-towards-zero semantics). +- Pervasives.float_of_string: now raises Failure on ill-formed input. +- Pervasives: added useful float constants max_float, min_float, epsilon_float. +- printf functions in Printf and Format: added % formats for int32, nativeint, + int64; "*" in width and precision specifications now supported + (contributed by Thorsten Ohl). +- Added Hashtbl.copy, Stack.copy. +- Hashtbl: revised resizing strategy to avoid quadratic behavior + on Hashtbl.add. +- New module MoreLabels providing labelized versions of modules + Hashtbl, Map and Set. +- Pervasives.output_value and Marshal.to_* : improved hashing strategy + for internal data structures, avoid excessive slowness on + quasi-linearly-allocated inputs. + +Other libraries: +- Num: fixed bug in big integer exponentiation (Big_int.power_*). + +Windows port: +- New GUI for interactive toplevel (Jacob Navia). +- The Graphics library is now available for stand-alone executables + (Jacob Navia). +- Unix library: improved reporting of system error codes. +- Fixed error in "globbing" of * and ? patterns on command line. + +Emacs mode: small fixes; special color highlighting for ocamldoc comments. + +License: added special exception to the LGPL'ed code (libraries and + runtime system) allowing unrestricted linking, whether static or dynamic. + + +Objective Caml 3.03 ALPHA: +-------------------------- + +Language: +- Removed built-in syntactic sugar for streams and stream patterns + [< ... >], now supported via CamlP4, which is now included in the + distribution. +- Switched the default behaviour to labels mode (labels are compulsory), + but allows omitting labels when a function application is complete. + -nolabels mode is available but deprecated for programming. + (See also scrapelabels and addlabels tools below.) +- Removed all labels in the standard libraries, except labltk. + Labelized versions are kept for ArrayLabels, ListLabels, StringLabels + and UnixLabels. "open StdLabels" gives access to the first three. +- Extended polymorphic variant type syntax, allowing union types and + row abbreviations for both sub- and super-types. #t deprecated in types. +- See the Upgrading file for how to adapt to all the changes above. + +Type-checker: +- Fixed obscure bug in module typing causing the type-checker to loop + on signatures of the form + module type M + module A: sig module type T = sig module T: M end end + module B: A.T +- Improved efficiency of module type-checking via lazy computation of + certain signature summary information. +- An empty polymorphic variant type is now an error. + +Both compilers: +- Fixed wrong code generated for "struct include M ... end" when M + contains one or several "external" declarations. + +Byte-code compiler: +- Protect against VM stack overflow caused by module initialization code + with many local variables. +- Support for dynamic loading of the C part of mixed Caml/C libraries. +- Removed the -use-runtime and -make-runtime flags, obsoleted by dynamic + loading of C libraries. + +Native-code compiler: +- Attempt to recover gracefully from system stack overflow. Currently + works on x86 under Linux and BSD. +- Alpha: work around "as" bug in Tru64 5.1. + +Toplevel environment: +- Revised printing of inferred types and evaluation results + so that an external printer (e.g. Camlp4's) can be hooked in. + +Tools: +- The CamlP4 pre-processor-pretty-printer is now included in the standard + distribution. +- New tool ocamlmklib to help build mixed Caml/C libraries. +- New tool scrapelabels and addlabels, to either remove (non-optional) + labels in interfaces, or automatically add them in the definitions. + They provide easy transition from classic mode ocaml 3.02 sources, + depending on whether you want to keep labels or not. +- ocamldep: added -pp option to handle preprocessed source files. + +Run-time system: +- Support for dynamic loading of the C part of mixed Caml/C libraries. + Currently works under Linux, FreeBSD, Windows, Tru64, Solaris and Irix. +- Implemented registration of global C roots with a skip list, + runs much faster when there are many global C roots. +- Autoconfiguration script: fixed wrong detection of Mac OS X; problem + with the Sparc, gcc 3.0, and float alignment fixed. + +Standard library: +- Added Pervasives.flush_all to flush all opened output channels. + +Other libraries: +- All libraries revised to allow dynamic loading of the C part. +- Graphics under X Windows: revised event handling, should no longer lose + mouse events between two calls to wait_next_event(); wait_next_event() + now interruptible by signals. +- Bigarrays: fixed bug in marshaling of big arrays. + +Windows port: +- Fixed broken Unix.{get,set}sockopt* + + + +Objective Caml 3.02: +-------------------- + +Both compilers: +- Fixed embarrassing bug in pattern-matching compilation + (affected or-patterns containing variable bindings). +- More optimizations in pattern-matching compilation. + +Byte-code compiler: +- Protect against VM stack overflow caused by functions with many local + variables. + +Native-code compiler: +- Removed re-sharing of string literals, causes too many surprises with + in-place string modifications. +- Corrected wrong compilation of toplevel "include" statements. +- Fixed bug in runtime function "callbackN_exn". +- Signal handlers receive the conventional signal number as argument + instead of the system signal number (same behavior as with the + bytecode compiler). +- ARM port: fixed issue with immediate operand overflow in large functions. + +Toplevel environment: +- User-definer printers (for #install_printer) now receive as first argument + the pretty-printer formatter where to print their second argument. + Old printers (with only one argument) still supported for backward + compatibility. + +Standard library: +- Module Hashtbl: added Hashtbl.fold. + +Other libraries: +- Dynlink: better error reporting in add_interfaces for missing .cmi files. +- Graphics: added more drawing functions (multiple points, polygons, + multiple lines, splines). +- Bytecode threads: the module Unix is now thread-safe, ThreadUnix is + deprecated. Unix.exec* now resets standard descriptors to blocking mode. +- Native threads: fixed a context-switch-during-GC problem causing + certain C runtime functions to fail, most notably input_value. +- Unix.inet_addr_of_string: call inet_aton() when available so as to + handle correctly the address 255.255.255.255. +- Unix: added more getsockopt and setsockopt functions to get/set + options that have values other than booleans. +- Num: added documentation for the Big_int module. + +Tools: +- ocamldep: fixed wrong dependency issue with nested modules. + +Run-time system: +- Removed floating-point error at start-up on some non-IEEE platforms + (e.g. FreeBSD prior to 4.0R). +- Stack backtrace mechanism now works for threads that terminate on + an uncaught exception. + +Auto-configuration: +- Updated config.guess and config.sub scripts, should recognize a greater + number of recent platform. + +Windows port: +- Fixed broken Unix.waitpid. Unix.file_descr can now be compared or hashed. +- Toplevel application: issue with spaces in name of stdlib directory fixed. + +MacOS 9 port: +- Removed the last traces of support for 68k + + +Objective Caml 3.01: +-------------------- + +New language features: +- Variables are allowed in "or" patterns, e.g. + match l with [t] | [_;t] -> ... t ... +- "include <structure expression>" to re-export all components of a + structure inside another structure. +- Variance annotation on parameters of type declarations, e.g. + type (+'a,-'b,'c) t (covariant in 'a, contravariant in 'b, invariant in 'c) + +New ports: +- Intel IA64/Itanium under Linux (including the native-code compiler). +- Cygwin under MS Windows. This port is an alternative to the earlier + Windows port of OCaml, which relied on MS compilers; the Cygwin + Windows port does not need MS Visual C++ nor MASM, runs faster + in bytecode, and has a better implementation of the Unix library, + but currently lacks threads and COM component support. + +Type-checking: +- Relaxed "monomorphic restriction" on type constructors in a + mutually-recursive type definition, e.g. the following is again allowed + type u = C of int t | D of string t and 'a t = ... +- Fixed name-capture bug in "include SIG" and "SIG with ..." constructs. +- Improved implicit subtypes built by (... :> ty), closer to intuition. +- Several bug fixes in type-checking of variants. +- Typing of polymorphic variants is more restrictive: + do not allow conjunctive types inside the same pattern matching. + a type has either an upper bound, or all its tags are in the lower bound. + This may break some programs (this breaks lablgl-0.94). + +Both compilers: +- Revised compilation of pattern matching. +- Option -I +<subdir> to search a subdirectory <subdir> of the standard + library directory (i.e. write "ocamlc -I +labltk" instead of + "ocamlc -I /usr/local/lib/ocaml/labltk"). +- Option -warn-error to turn warnings into errors. +- Option -where to print the location of the standard library directory. +- Assertions are now type-checked even if the -noassert option is given, + thus -noassert can no longe change the types of modules. + +Bytecode compiler and bytecode interpreter: +- Print stack backtrace when a program aborts due to an uncaught exception + (requires compilation with -g and running with ocamlrun -b or + OCAMLRUNPARAM="b=1"). + +Native-code compiler: +- Better unboxing optimizations on the int32, int64, and nativeint types. +- Tail recursion preserved for functions having more parameters than + available registers (but tail calls to other functions are still + turned off if parameters do not fit entirely in registers). +- Fixed name-capture bug in function inlining. +- Improved spilling/reloading strategy for conditionals. +- IA32, Alpha: better alignment of branch targets. +- Removed spurious dependency on the -lcurses library. + +Toplevel environment: +- Revised handling of top-level value definitions, allows reclaimation + of definitions that are shadowed by later definitions with the same names. + (E.g. "let x = <big list>;; let x = 1;;" allows <big list> to be reclaimed.) +- Revised the tracing facility so that for standard library functions, + only calls from user code are traced, not calls from the system. +- Added a "*" prompt when within a comment. + +Runtime system: +- Fixed portability issue on bcopy() vs memmove(), affecting Linux RedHat 7.0 + in particular. +- Structural comparisons (=, <>, <, <=, >, >=, compare) reimplemented + so as to avoid overflowing the C stack. +- Input/output functions: arrange so that reads and writes on closed + in_channel or out_channel raise Sys_error immediately. + +Standard library: +- Module Gc: changed some counters to float in order to avoid overflow; + added alarms +- Module Hashtbl: added Hashtbl.replace. +- Module Int64: added bits_of_float, float_of_bits (access to IEEE 754 + representation of floats). +- Module List: List.partition now tail-rec; + improved memory behavior of List.stable_sort. +- Module Nativeint: added Nativeint.size (number of bits in a nativeint). +- Module Obj: fixed incorrect resizing of float arrays in Obj.resize. +- Module Pervasives: added float constants "infinity", "neg_infinity", "nan"; + added a "classify_float" function to test a float for NaN, infinity, etc. +- Pervasives.input_value: fixed bug affecting shared custom objects. +- Pervasives.output_value: fixed size bug affecting "int64" values. +- Pervasives.int_of_string, {Int32,Int64,Nativeint}.of_string: + fixed bug causing bad digits to be accepted without error. +- Module Random: added get_state and set_state to checkpoint the generator. +- Module Sys: signal handling functions are passed the system-independent + signal number rather than the raw system signal number whenever possible. +- Module Weak: added Weak.get_copy. + +Other libraries: +- Bigarray: added Bigarray.reshape to take a view of the elements of a + bigarray with different dimensions or number of dimensions; + fixed bug causing "get" operations to be unavailable in custom + toplevels including Bigarray. +- Dynlink: raise an error instead of crashing when the loaded module + refers to the not-yet-initialized module performing a dynlink operation. +- Bytecode threads: added a thread-safe version of the Marshal module; + fixed a rare GC bug in the thread scheduler. +- POSIX threads: fixed compilation problem with threads.cmxa. +- Both thread libraries: better tail-recursion in Event.sync. +- Num library: fixed bug in square roots (Nat.sqrt_nat, Big_int.sqrt_big_int). + +Tools: +- ocamldep: fixed missing dependencies on labels of record patterns and + record construction operations + +Win32 port: +- Unix.waitpid now implements the WNOHANG option. + +Mac OS ports: +- Mac OS X public beta is supported. +- Int64.format works on Mac OS 8/9. + + +Objective Caml 3.00: +-------------------- + +Language: +- OCaml/OLabl merger: + * Support for labeled and optional arguments for functions and classes. + * Support for variant types (sum types compared by structure). + See tutorial (chapter 2 of the OCaml manual) for more information. +- Syntactic change: "?" in stream error handlers changed to "??". +- Added exception renaming in structures (exception E = F). +- (OCaml 2.99/OLabl users only) Label syntax changed to preserve + backward compatibility with 2.0x (labeled function application + is f ~lbl:arg instead of f lbl:arg). A tool is provided to help + convert labelized programs to OCaml 3.00. + +Both compilers: +- Option -labels to select commuting label mode (labels are mandatory, + but labeled arguments can be passed in a different order than in + the definition of the function; in default mode, labels may be omitted, + but argument reordering is only allowed for optional arguments). +- Libraries (.cma and .cmxa files) now "remember" C libraries given + at library construction time, and add them back at link time. + Allows linking with e.g. just unix.cma instead of + unix.cma -custom -cclib -lunix +- Revised printing of error messages, now use Format.fprintf; no visible + difference for users, but could facilitate internationalization later. +- Fixed bug in unboxing of records containing only floats. +- Fixed typing bug involving applicative functors as components of modules. +- Better error message for inconsistencies between compiled interfaces. + +Bytecode compiler: +- New "modular" format for bytecode executables; no visible differences + for users, but will facilitate further extensions later. +- Fixed problems in signal handling. + +Native-code compiler: +- Profiling support on x86 under FreeBSD +- Open-coding and unboxing optimizations for the new integer types + int32, int64, nativeint, and for bigarrays. +- Fixed instruction selection bug with "raise" appearing in arguments + of strict operators, e.g. "1 + raise E". +- Better error message when linking incomplete/incorrectly ordered set + of .cmx files. +- Optimized scanning of global roots during GC, can reduce total running + time by up to 8% on GC-intensive programs. + +Interactive toplevel: +- Better printing of exceptions, including arguments, when possible. +- Fixed rare GC bug occurring during interpretation of scripts. +- Added consistency checks between interfaces and implementations + during #load. + +Run-time system: +- Added support for "custom" heap blocks (heap blocks carrying + C functions for finalization, comparison, hashing, serialization + and deserialization). +- Support for finalisation functions written in Caml. + +Standard library: +- New modules Int32, Int64, Nativeint for 32-bit, 64-bit and + platform-native integers +- Module Array: added Array.sort, Array.stable_sort. +- Module Gc: added Gc.finalise to attach Caml finalisation functions to + arbitrary heap-allocated data. +- Module Hashtbl: do not bomb when resizing very large table. +- Module Lazy: raise Lazy.Undefined when a lazy evaluation needs itself. +- Module List: added List.sort, List.stable_sort; fixed bug in List.rev_map2. +- Module Map: added mapi (iteration with key and data). +- Module Set: added iterators for_all, exists, filter, partition. +- Module Sort: still here but deprecated in favor of new sorting functions + in Array and List. +- Module Stack: added Stack.top +- Module String: fixed boundary condition on String.rindex_from +- Added labels on function arguments where appropriate. + +New libraries and tools: +- ocamlbrowser: graphical browser for OCaml sources and compiled interfaces, + supports cross-referencing, editing, running the toplevel. +- LablTK: GUI toolkit based on TK, using labeled and optional arguments, + easier to use than CamlTK. +- Bigarray: large, multi-dimensional numerical arrays, facilitate + interfacing with C/Fortran numerical code, efficient support for + advanced array operations such as slicing and memory-mapping of files. + +Other libraries: +- Bytecode threads: timer-based preemption was broken, works back again; + fixed bug in Pervasives.input_line; exported Thread.yield. +- System threads: several GC / reentrancy bugs fixed in buffered I/O + and Unix I/O; revised Thread.join implementation for strict POSIX + conformance; exported Thread.yield. +- Graphics: added support for double buffering; added, current_x, current_y, + rmoveto, rlineto, and draw_rect. +- Num: fixed bug in Num.float_of_num. +- Str: worked around potential symbol conflicts with C standard library. +- Dbm: fixed bug with Dbm.iter on empty database. + +New or updated ports: +- Alpha/Digital Unix: lifted 256M limitation on total memory space + induced by -taso +- Port to AIX 4.3 on PowerPC +- Port to HPUX 10 on HPPA +- Deprecated 680x0 / SunOS port + +Macintosh port: +- Implemented the Unix and Thread libraries. +- The toplevel application does not work on 68k Macintoshes; maybe + later if there's a demand. +- Added a new tool, ocamlmkappli, to build an application from a + program written in O'Caml. + + +Objective Caml 2.04: +-------------------- + +- C interface: corrected inconsistent change in the CAMLparam* macros. +- Fixed internal error in ocamlc -g. +- Fixed type-checking of "S with ...", where S is a module type name + abbreviating another module type name. +- ocamldep: fixed stdout/stderr mismatch after failing on one file. +- Random.self_init more random. +- Windows port: + - Toplevel application: fixed spurious crash on exit. + - Native-code compiler: fixed bug in assembling certain + floating-point constants (masm doesn't grok 2e5, wants 2.0e5). + +Objective Caml 2.03: +-------------------- + +New ports: +- Ported to BeOS / Intel x86 (bytecode and native-code). +- BSD / Intel x86 port now supports both a.out and ELF binary formats. +- Added support for {Net,Open}BSD / Alpha. +- Revamped Rhapsody port, now works on MacOS X server. + +Syntax: +- Warning for "(*)" and "*)" outside comment. +- Removed "#line LINENO", too ambiguous with a method invocation; + the equivalent "# LINENO" is still supported. + +Typing: +- When an incomplete pattern-matching is detected, report also a + value or value template that is not covered by the cases of + the pattern-matching. +- Several bugs in class type matching and in type error reporting fixed. +- Added an option -rectypes to support general recursive types, + not just those involving object types. + +Bytecode compiler: +- Minor cleanups in the bytecode emitter. +- Do not remove "let x = y" bindings in -g mode; makes it easier to + debug the code. + +Native-code compiler: +- Fixed bug in grouping of allocations performed in the same basic block. +- Fixed bug in constant propagation involving expressions containing + side-effects. +- Fixed incorrect code generation for "for" loops whose upper bound is + a reference assigned inside the loop. +- MIPS code generator: work around a bug in the IRIX 6 assembler. + +Toplevel: +- Fixed incorrect redirection of standard formatter to stderr + while executing toplevel scripts. + +Standard library: +- Added List.rev_map, List.rev_map2. +- Documentation of List functions now says which functions are + tail-rec, and how much stack space is needed for non-tailrec functions. +- Wrong type for Printf.bprintf fixed. +- Fixed weird behavior of Printf.sprintf and Printf.bprintf in case of + partial applications. +- Added Random.self_init, which initializes the PRNG from the system date. +- Sort.array: serious bugs fixed. +- Stream.count: fixed incorrect behavior with ocamlopt. + +Run-time system and external interface: +- Fixed weird behavior of signal handlers w.r.t. signal masks and exceptions + raised from the signal handler. +- Fixed bug in the callback*_exn() functions. + +Debugger: +- Fixed wrong printing of float record fields and elements of float arrays. +- Supports identifiers starting with '_'. + +Profiler: +- Handles .mli files, so ocamlcp can be used to replace ocamlc (e.g. in a + makefile). +- Now works on programs that use stream expressions and stream parsers. + +Other libraries: +- Graphics: under X11, treat all mouse buttons equally; fixed problem + with current font reverting to the default font when the graphics + window is resized. +- Str: fixed reentrancy bugs in Str.replace and Str.full_split. +- Bytecode threads: set standard I/O descriptors to non-blocking mode. +- OS threads: revised implementation of Thread.wait_signal. +- All threads: added Event.wrap_abort, Event.choose []. +- Unix.localtime, Unix.gmtime: check for errors. +- Unix.create_process: now supports arbitrary redirections of std descriptors. +- Added Unix.open_process_full. +- Implemented Unix.chmod under Windows. +- Big_int.square_big_int now gives the proper sign to its result. + +Others: +- ocamldep: don't stop at first error, skip to next file. +- Emacs mode: updated with Garrigue and Zimmerman's snapshot of 1999/10/18. +- configure script: added -prefix option. +- Windows toplevel application: fixed problem with graphics library + not loading properly. + + +Objective Caml 2.02: +-------------------- + +* Type system: + - Check that all components of a signature have unique names. + - Fixed bug in signature matching involving a type component and + a module component, both sharing an abstract type. + - Bug involving recursive classes constrained by a class type fixed. + - Fixed bugs in printing class types and in printing unification errors. + +* Compilation: + - Changed compilation scheme for "{r with lbl = e}" when r has many fields + so as to avoid code size explosion. + +* Native-code compiler: + - Better constant propagation in boolean expressions and in conditionals. + - Removal of unused arguments during function inlining. + - Eliminated redundant tagging/untagging in bit shifts. + - Static allocation of closures for functions without free variables, + reduces the size of initialization code. + - Revised compilation scheme for definitions at top level of compilation + units, so that top level functions have no free variables. + - Coalesced multiple allocations of heap blocks inside one expression + (e.g. x :: y :: z allocates the two conses in one step). + - Ix86: better handling of large integer constants in instruction selection. + - MIPS: fixed wrong asm generated for String.length "literal". + +* Standard library: + - Added the "ignore" primitive function, which just throws away its + argument and returns "()". It allows to write + "ignore(f x); y" if "f x" doesn't have type unit and you don't + want the warning caused by "f x; y". + - Added the "Buffer" module (extensible string buffers). + - Module Format: added formatting to buffers and to strings. + - Added "mem" functions (membership test) to Hashtbl and Map. + - Module List: added find, filter, partition. + Renamed remove and removeq to remove_assoc and remove_assq. + - Module Marshal: fixed bug in marshaling functions when passed functional + values defined by mutual recursion with other functions. + - Module Printf: added Printf.bprintf (print to extensible buffer); + added %i format as synonymous for %d (as per the docs). + - Module Sort: added Sort.array (Quicksort). + +* Runtime system: + - New callback functions for callbacks with arbitrary many arguments + and for catching Caml exceptions escaping from a callback. + +* The ocamldep dependency generator: now performs full parsing of the + sources, taking into account the scope of module bindings. + +* The ocamlyacc parser generator: fixed sentinel error causing wrong + tables to be generated in some cases. + +* The str library: + - Added split_delim, full_split as variants of split that control + more precisely what happens to delimiters. + - Added replace_matched for separate matching and replacement operations. + +* The graphics library: + - Bypass color lookup for 16 bpp and 32 bpp direct-color displays. + - Larger color cache. + +* The thread library: + - Bytecode threads: more clever use of non-blocking I/O, makes I/O + operations faster. + - POSIX threads: gcc-ism removed, should now compile on any ANSI C compiler. + - Both: avoid memory leak in the Event module when a communication + offer is never selected. + +* The Unix library: + - Fixed inversion of ctime and mtime in Unix.stat, Unix.fstat, Unix.lstat. + - Unix.establish_connection: properly reclaim socket if connect fails. + +* The DBM library: no longer crashes when calling Dbm.close twice. + +* Emacs mode: + - Updated with Garrigue and Zimmerman's latest version. + - Now include an "ocamltags" script for using etags on OCaml sources. + +* Win32 port: + - Fixed end-of-line bug in ocamlcp causing problems with generated sources. + + +Objective Caml 2.01: +-------------------- + +* Typing: + - Added warning for expressions of the form "a; b" where a does not have + type "unit"; catches silly mistake such as + "record.lbl = newval; ..." instead of "record.lbl <- newval; ...". + - Typing bug in "let module" fixed. + +* Compilation: + - Fixed bug in compilation of recursive and mutually recursive classes. + - Option -w to turn specific warnings on/off. + - Option -cc to choose the C compiler used with ocamlc -custom and ocamlopt. + +* Bytecode compiler and bytecode interpreter: + - Intel x86: removed asm declaration causing "fixed or forbidden register + spilled" error with egcs and gcc 2.8 (but not with gcc 2.7, go figure). + - Revised handling of debugging information, allows faster linking with -g. + +* Native-code compiler: + - Fixed bugs in integer constant propagation. + - Out-of-bound accesses in array and strings now raise an Invalid_argument + exception (like the bytecode system) instead of stopping the program. + - Corrected scheduling of bound checks. + - Port to the StrongARM under Linux (e.g. Corel Netwinder). + - I386: fixed bug in profiled code (ocamlopt -p). + - Mips: switched to -n32 model under IRIX; dropped the Ultrix port. + - Sparc: simplified the addressing modes, allows for better scheduling. + - Fixed calling convention bug for Pervasives.modf. + +* Toplevel: + - #trace works again. + - ocamlmktop: use matching ocamlc, not any ocamlc from the search path. + +* Memory management: + - Fixed bug in heap expansion that could cause the GC to loop. + +* C interface: + - New macros CAMLparam... and CAMLlocal... to simplify the handling + of local roots in C code. + - Simplified procedure for allocating and filling Caml blocks from C. + - Declaration of string_length in <caml/mlvalues.h>. + +* Standard library: + - Module Format: added {get,set}_all_formatter_output_functions, + formatter_of_out_channel, and the control sequence @<n> in printf. + - Module List: added mem_assoc, mem_assq, remove, removeq. + - Module Pervasives: added float_of_int (synonymous for float), + int_of_float (truncate), int_of_char (Char.code), char_of_int (Char.chr), + bool_of_string. + - Module String: added contains, contains_from, rcontains_from. + +* Unix library: + - Unix.lockf: added F_RLOCK, F_TRLOCK; use POSIX locks whenever available. + - Unix.tc{get,set}attr: added non-standard speeds 57600, 115200, 230400. + - Unix.chroot: added. + +* Threads: + - Bytecode threads: improved speed of I/O scheduling. + - Native threads: fixed a bug involving signals and exceptions + generated from C. + +* The "str" library: + - Added Str.string_partial_match. + - Bumped size of internal stack. + +* ocamlyacc: emit correct '# lineno' directive for prelude part of .mly file. + +* Emacs editing mode: updated with Jacques Garrigue's newest code. + +* Windows port: + - Added support for the "-cclib -lfoo" option (instead of + -cclib /full/path/libfoo.lib as before). + - Threads: fixed a bug at initialization time. + +* Macintosh port: source code for Macintosh application merged in. + + +Objective Caml 2.00: +-------------------- + +* Language: + - New class language. See http://caml.inria.fr/ocaml/refman/ + for a tutorial (chapter 2) and for the reference manual (section 4.9). + - Local module definitions "let module X = <module-expr> in <expr>". + - Record copying with update "{r with lbl1 = expr1; ...}". + - Array patterns "[|pat1; ...;patN|]" in pattern-matchings. + - New reserved keywords: "object", "initializer". + - No longer reserved: "closed", "protected". + +* Bytecode compiler: + - Use the same compact memory representations for float arrays, float + records and recursive closures as the native-code compiler. + - More type-dependent optimizations. + - Added the -use_runtime and -make_runtime flags to build separately + and reuse afterwards custom runtime systems + (inspired by Fabrice Le Fessant's patch). + +* Native-code compiler: + - Cross-module constant propagation of integer constants. + - More type-dependent optimizations. + - More compact code generated for "let rec" over data structures. + - Better code generated for "for" loops (test at bottom of code). + - More aggressive scheduling of stores. + - Added -p option for time profiling with gprof + (fully supported on Intel x86/Linux and Alpha/Digital Unix only) + (inspired by Aleksey Nogin's patch). + - A case of bad spilling with high register pressure fixed. + - Fixed GC bug when GC called from C without active Caml code. + - Alpha: $gp handling revised to follow Alpha's standard conventions, + allow running "atom" and "pixie" on ocamlopt-generated binaries. + - Intel x86: use movzbl and movsbl systematically to load 8-bit and 16-bit + quantities, no more hacks with partial registers (better for the + Pentium Pro, worse for the Pentium). + - PowerPC: more aggressive scheduling of return address reloading. + - Sparc: scheduling bug related to register pairs fixed. + +* Runtime system: + - Better printing of uncaught exceptions (print a fully qualified + name whenever possible). + +* New ports: + - Cray T3E (bytecode only) (in collaboration with CEA). + - PowerMac under Rhapsody. + - SparcStations under Linux. + +* Standard library: + - Added set_binary_mode_in and set_binary_mode_out in Pervasives + to toggle open channels between text and binary modes. + - output_value and input_value check that the given channel is in + binary mode. + - input_value no longer fails on very large marshalled data (> 16 Mbytes). + - Module Arg: added option Rest. + - Module Filename: temp_file no longer loops if temp dir doesn't exist. + - Module List: added rev_append (tail-rec alternative to @). + - Module Set: tell the truth about "elements" returning a sorted list; + added min_elt, max_elt, singleton. + - Module Sys: added Sys.time for simple measuring of CPU time. + +* ocamllex: + - Check for overflow when generating the tables for the automaton. + - Error messages in generated .ml file now point to .mll source. + - Added "let <id> = <regexp>" to name regular expressions + (inspired by Christian Lindig's patch). + +* ocamlyacc: + - Better error recovery in presence of EOF tokens. + - Error messages in generated .ml file now point to .mly source. + - Generated .ml file now type-safe even without the generated .mli file. + +* The Unix library: + - Use float instead of int to represent Unix times (number of seconds + from the epoch). This fixes a year 2005 problem on 32-bit platforms. + Functions affected: stat, lstat, fstat, time, gmtime, localtime, + mktime, utimes. + - Added putenv. + - Better handling of "unknown" error codes (EUNKNOWNERR). + - Fixed endianness bug in getservbyport. + - win32unix (the Win32 implementation of the Unix library) now has + the same interface as the unix implementation, this allows exchange + of compiled .cmo and .cmi files between Unix and Win32. + +* The thread libraries: + - Bytecode threads: bug with escaping exceptions fixed. + - System threads (POSIX, Win32): malloc/free bug fixed; signal bug fixed. + - Both: added Thread.wait_signal to wait synchronously for signals. + +* The graph library: bigger color cache. + +* The str library: added Str.quote, Str.regexp_string, + Str.regexp_string_case_fold. + +* Emacs mode: + - Fixed bug with paragraph fill. + - Fixed bug with next-error under Emacs 20. + + +Objective Caml 1.07: +-------------------- + +* Native-code compiler: + - Revised interface between generated code and GC, fixes serious GC + problems with signals and native threads. + - Added "-thread" option for compatibility with ocamlc. + +* Debugger: correctly print instance variables of objects. + +* Run-time system: ported to OpenBSD. + +* Standard library: fixed wrong interface for Marshal.to_buffer and + Obj.unmarshal. + +* Num library: added Intel x86 optimized asm code (courtesy of + Bernard Serpette). + +* Thread libraries: + - Native threads: fixed GC bugs and installation procedure. + - Bytecode threads: fixed problem with "Marshal" module. + - Both: added Event.always. + +* MS Windows port: better handling of long command lines in Sys.command + +Objective Caml 1.06: +-------------------- + +* Language: + - Added two new keywords: "assert" (check assertion) and "lazy" + (delay evaluation). + - Allow identifiers to start with "_" (such identifiers are treated + as lowercase idents). + +* Objects: + - Added "protected" methods (visible only from subclasses, can be hidden + in class type declared in module signature). + - Objects can be compared using generic comparison functions. + - Fixed compilation of partial application of object constructors. + +* Type system: + - Occur-check now more strict (all recursions must traverse an object). + - A few bugs fixed. + +* Run-time system: + - A heap compactor was implemented, so long-running programs can now + fight fragmentation. + - The meaning of the "space_overhead" parameter has changed. + - The macros Push_roots and Pop_roots are superseded by Begin_roots* and + End_roots. + - Bytecode executable includes list of primitives used, avoids crashes + on version mismatch. + - Reduced startup overhead for marshalling, much faster marshalling of + small objects. + - New exception Stack_overflow distinct from Out_of_memory. + - Maximum stack size configurable. + - I/O revised for compatibility with compactor and with native threads. + - All C code ANSIfied (new-style function declarations, etc). + - Threaded code work on all 64-bit processors, not just Alpha/Digital Unix. + - Better printing of uncaught exceptions. + +* Both compilers: + - Parsing: more detailed reporting of syntax errors (e.g. shows + unmatched opening parenthesis on missing closing parenthesis). + - Check consistency between interfaces (.cmi). + - Revised rules for determining dependencies between modules. + - Options "-verbose" for printing calls to C compiler, "-noassert" + for turning assertion checks off. + +* Native-code compiler: + - Machine-dependent parts rewritten using inheritance instead of + parameterized modules. + - GC bug in value let rec fixed. + - Port to Linux/Alpha. + - Sparc: cleaned up use of %g registers, now compatible with Solaris threads. + +* Top-level interactive system: + - Can execute Caml script files given on command line. + - Reads commands from ./.ocamlinit on startup. + - Now thread-compatible. + +* Standard library: + - New library module: Lazy (delayed computations). + - New library module: Marshal. Allows marshalling to strings and + transmission of closures between identical programs (SPMD parallelism). + - Filename: "is_absolute" is superseded by "is_implicit" and "is_relative". + To adapt old programs, change "is_absolute x" to "not (is_implicit x)" + (but the new "is_relative" is NOT the opposite of the old "is_absolute"). + - Array, Hashtbl, List, Map, Queue, Set, Stack, Stream: + the "iter" functions now take as argument a unit-returning function. + - Format: added "printf" interface to the formatter (see the documentation). + Revised behaviour of simple boxes: no more than one new line is output + when consecutive break hints should lead to multiple line breaks. + - Stream: revised implementation, renamed Parse_failure to Failure and + Parse_error to Error (don't you love gratuitous changes?). + - String: added index, rindex, index_from, rindex_from. + - Array: added mapi, iteri, fold_left, fold_right, init. + - Added Map.map, Set.subset, Printexc.to_string. + +* ocamllex: lexers generated by ocamllex can now handle all characters, + including '\000'. + +* ocamlyacc: fixed bug with function closures returned by parser rules. + +* Debugger: + - Revised generation of events. + - Break on function entrance. + - New commands start/previous. + - The command loadprinter now try to recursively load required + modules. + - Numerous small fixes. + +* External libraries: + - systhreads: can now use POSIX threads; POSIX and Win32 threads are + now supported by the native-code compiler. + - dbm and graph: work in native code. + - num: fixed bug in Nat.nat_of_string. + - str: fixed deallocation bug with case folding. + - win32unix: use Win32 handles instead of (buggy) VC++ emulation of Unix + file handles; added gettimeofday. + +* Emacs editing mode and debugger interface updated to July '97 version. + +Objective Caml 1.05: +-------------------- + +* Typing: fixed several bugs causing spurious type errors. + +* Native-code compiler: fixed instruction selection bug causing GC to +see ill-formed pointers; fixed callbacks to support invocation from a +main program in C. + +* Standard library: fixed String.lowercase; Weak now resists integers. + +* Toplevel: multiple phrases without intermediate ";;" now really supported; +fixed value printing problems where the wrong printer was selected. + +* Debugger: fixed printing problem with local references; revised +handling of checkpoints; various other small fixes. + +* Macintosh port: fixed signed division problem in bytecomp/emitcode.ml + +Objective Caml 1.04: +-------------------- + +* Replay debugger ported from Caml Light; added debugger support in + compiler (option -g) and runtime system. Debugger is alpha-quality + and needs testing. + +* Parsing: + - Support for "# linenum" directives. + - At toplevel, allow several phrases without intermediate ";;". + +* Typing: + - Allow constraints on datatype parameters, e.g. + type 'a foo = ... constraint 'a = 'b * 'c. + - Fixed bug in signature matching in presence of free type variables '_a. + - Extensive cleanup of internals of type inference. + +* Native-code compilation: + - Inlining of small functions at point of call (fairly conservative). + - MIPS code generator ported to SGI IRIX 6. + - Better code generated for large integer constants. + - Check for urgent GC when allocating large objects in major heap. + - PowerPC port: better scheduling, reduced TOC consumption. + - HPPA port: handle long conditional branches gracefully, + several span-dependent bugs fixed. + +* Standard library: + - More floating-point functions (all ANSI C float functions now available). + - Hashtbl: added functorial interface (allow providing own equality + and hash functions); rehash when resizing, avoid memory leak on + Hashtbl.remove. + - Added Char.uppercase, Char.lowercase, String.uppercase, String.lowercase, + String.capitalize, String.uncapitalize. + - New module Weak for manipulating weak pointers. + - New module Callback for registering closures and exceptions to be + used from C. + +* Foreign interface: + - Better support for callbacks (C calling Caml), exception raising + from C, and main() in C. Added function to remove a global root. + - Option -output-obj to package Caml code as a C library. + +* Thread library: fixed bug in timed_read and timed_write operations; + Lexing.from_function and Lexing.from_channel now reentrant. + +* Unix interface: renamed EACCESS to EACCES (the POSIX name); added setsid; + fixed bug in inet_addr_of_string for 64-bit platforms. + +* Ocamlyacc: default error function no longer prevents error recovery. + +* Ocamllex: fixed reentrancy problem w.r.t. exceptions during refill; + fixed output problem (\r\r\n) under Win32. + +* Macintosh port: + - The makefiles are provided for compiling and installing O'Caml on + a Macintosh with MPW 3.4.1. + - An application with the toplevel in a window is forthcoming. + +* Windows NT/95 port: updated toplevel GUI to that of Caml Light 0.73. + +* Emacs editing mode and debugger interface included in distribution. + + +Objective Caml 1.03: +-------------------- + +* Typing: + - bug with type names escaping their scope via unification with + non-generalized type variables '_a completely fixed; + - fixed bug in occur check : it was too restrictive; + - fixed bug of coercion operators; + - check that no two types of the same name are generated in a module + (there was no check for classes); + - "#install_printer" works again; + - fixed bug in printing of subtyping errors; + - in class interfaces, construct "method m" (without type) change + the status of method m from abstract to concrete; + - in a recursive definition of class interfaces, a class can now + inherit from a previous class; + - typing of a method make use of an eventual previously given type + of this method, yielding clearer type errors. + +* Compilation (ocamlc and ocamlopt): + - fixed bug in compilation of classes. + +* Native-code compilation: + - optimization of functions taking tuples of arguments; + - code emitter for the Motorola 680x0 processors (retrocomputing week); + - Alpha/OSF1: generate frame descriptors, avoids crashes when e.g. + exp() or log() cause a domain error; fixed bug with + String.length "literal"; + - Sparc, Mips, HPPA: removed marking of scanned stack frames + (benefits do not outweight cost). + +* Standard library: + - Arg.parse now prints documentation for command-line options; + - I/O buffers (types in_channel and out_channel) now heap-allocated, + avoids crashing when closing a channel several times; + - Overflow bug in compare() fixed; + - GC bug in raising Sys_error from I/O functions fixed; + - Parsing.symbol_start works even for epsilon productions. + +* Foreign interface: main() in C now working, fixed bug in library + order at link time. + +* Thread library: guard against calling thread functions before Thread.create. + +* Unix library: fixed getsockopt, setsockopt, open_process_{in,out}. + +* Perl-free, cpp-free, cholesterol-free installation procedure. + + +Objective Caml 1.02: +-------------------- +* Typing: + - fixed bug with type names escaping their scope via unification + with non-generalized type variables '_a; + - keep #class abbreviations longer; + - faster checking of well-formed abbreviation definitions; + - stricter checking of "with" constraints over signatures (arity + mismatch, overriding of an already manifest type). + +* Compilation (ocamlc and ocamlopt): + - fixed bug in compilation of recursive classes; + - [|...|] and let...rec... allowed inside definitions of recursive + data structures; + +* Bytecode compilation: fixed overflow in linker for programs with + more than 65535 globals and constants. + +* Native-code compilation: + - ocamlopt ported to HPPA under HP/UX, Intel x86 under Solaris 2, + PowerMacintosh under MkLinux; + - fixed two bugs related to floating-point arrays (one with "t array" + where t is an abstract type implemented as float, one with + comparison between two float arrays on 32 bit platforms); + - fixed reloading/spilling problem causing non-termination of + register allocation; + - fixed bugs in handling of () causing loss of tail recursion; + - fixed reloading bug in indirect calls. + +* Windows NT/95 port: + - complete port of the threads library (Pascal Cuoq); + - partial port of the Unix library (Pascal Cuoq); + - expansion of *, ? and @ on the command line. + +* Standard library: + - bug in in List.exists2 fixed; + - bug in "Random.int n" for very large n on 64-bit machines fixed; + - module Format: added a "general purpose" type of box (open_box); + can output on several formatters at the same time. + +* The "threads" library: + - implementation on top of native threads available for Win32 and + POSIX 1003.1c; + - added -thread option to select a thread-safe version of the + standard library, the ThreadIO module is no longer needed. + +* The "graph" library: avoid invalid pixmaps when doing + open_graph/close_graph several times. + +* The "dynlink" library: support for "private" (no re-export) dynamic loading. + +* ocamlyacc: skip '...' character literals correctly. + +* C interface: C code linked with O'Caml code can provide its own main() + and call caml_main() later. + + +Objective Caml 1.01: +-------------------- +* Typing: better report of type incompatibilities; + non-generalizable type variables in a struct...end no longer flagged + immediately as an error; + name clashes during "open" avoided. + +* Fixed bug in output_value where identical data structures + could have different external representations; this bug caused wrong + "inconsistent assumptions" errors when checking compatibility of + interfaces at link-time. + +* Standard library: fixed bug in Array.blit on overlapping array sections + +* Unmarshaling from strings now working. + +* ocamlc, ocamlopt: new flags -intf and -impl to force compilation as + an implementation/an interface, regardless of file extension; + overflow bug on wide-range integer pattern-matchings fixed. + +* ocamlc: fixed bytecode generation bug causing problems with compilation + units defining more than 256 values + +* ocamlopt, all platforms: + fixed GC bug in "let rec" over data structures; + link startup file first, fixes "undefined symbol" errors with some + libraries. + +* ocamlopt, Intel x86: + more efficient calling sequence for calling C functions; + floating-point wars, chapter 5: don't use float stack for holding + float pseudo-registers, stack-allocating them is just as efficient. + +* ocamlopt, Alpha and Intel x86: more compact calling sequence for garbage + collection. + +* ocamllex: generated automata no longer use callbacks for refilling + the input buffer (works better with threads); character literals + correctly skipped inside actions. + +* ocamldep: "-I" directories now searched in the right order + +* Thread library: incompatibilities with callbacks, signals, and + dynamic linking removed; scheduling bug with Thread.wait fixed. + +* New "dbm" library, interfaces with NDBM. + +* Object-oriented extensions: + instance variables can now be omitted in class types; + some error messages have been made clearer; + several bugs fixes. + +Objective Caml 1.00: +-------------------- + +* Merge of Jerome Vouillon and Didier Remy's object-oriented +extensions. + +* All libraries: all "new" functions renamed to "create" because "new" +is now a reserved keyword. + +* Compilation of "or" patterns (pat1 | pat2) completely revised to +avoid code size explosion. + +* Compiler support for preprocessing source files (-pp flag). + +* Library construction: flag -linkall to force linking of all units in +a library. + +* Native-code compiler: port to the Sparc under NetBSD. + +* Toplevel: fixed bug when tracing several times the same function +under different names. + +* New format for marshaling arbitrary data structures, allows +marshaling to/from strings. + +* Standard library: new module Genlex (configurable lexer for streams) + +* Thread library: much better support for I/O and blocking system calls. + +* Graphics library: faster reclaimation of unused pixmaps. + +* Unix library: new functions {set,clear}_nonblock, {set,clear}_close_on_exec, +{set,get}itimer, inet_addr_any, {get,set}sockopt. + +* Dynlink library: added support for linking libraries (.cma files). + +Caml Special Light 1.15: +------------------------ + +* Caml Special Light now runs under Windows NT and 95. Many thanks to +Kevin Gallo (Microsoft Research) who contributed his initial port. + +* csllex now generates tables for a table-driven automaton. +The resulting lexers are smaller and run faster. + +* Completely automatic configuration script. + +* Typing: more stringent checking of module type definitions against +manifest module type specifications. + +* Toplevel: recursive definitions of values now working. + +* Native-code compiler, all platforms: + toplevel "let"s with refutable patterns now working; + fixed bug in assignment to float record fields; + direct support for floating-point negation and absolute value. + +* Native-code compiler, x86: fixed bug with tail calls (with more than +4 arguments) from a function with a one-word stack frame. + +* Native-code compiler, Sparc: problem with -compact fixed. + +* Thread library: support for non-blocking writes; scheduler revised. + +* Unix library: bug in gethostbyaddr fixed; bounds checking for read, +write, etc. + +Caml Special Light 1.14: +------------------------ + +* cslopt ported to the PowerPC/RS6000 architecture. Better support for +AIX in the bytecode system as well. + +* cslopt, all platforms: fixed bug in live range splitting around catch/exit. + +* cslopt for the Intel (floating-point wars, chapter 4): +implemented Ershov's algorithm to minimize floating-point stack usage; +out-of-order pops fixed. + +* Several bug fixes in callbacks and signals. + +Caml Special Light 1.13: +------------------------ + +* Pattern-matching compilation revised to factor out accesses inside +matched structures. + +* Callbacks and signals now supported in cslopt. +Signals are only detected at allocation points, though. +Added callback functions with 2 and 3 arguments. + +* More explicit error messages when a native-code program aborts due +to array or string bound violations. + +* In patterns, "C _" allowed even if the constructor C has several arguments. + +* && and || allowed as alternate syntax for & and or. + +* cslopt for the Intel: code generation for floating-point +operations entirely redone for the third time (a pox on whomever at +Intel decided to organize the floating-point registers as a stack). + +* cslopt for the Sparc: don't use Sparc V8 smul and sdiv instructions, +emulation on V7 processors is abysmal. + +Caml Special Light 1.12: +------------------------ + +* Fixed an embarrassing bug with references to floats. + +Caml Special Light 1.11: +------------------------ + +* Streams and stream parsers a la Caml Light are back (thanks to +Daniel de Rauglaudre). + +* User-level concurrent threads, with low-level shared memory primitives +(locks and conditions) as well as channel-based communication primitives +with first-class synchronous events, in the style of Reppy's CML. + +* The native-code compiler has been ported to the HP PA-RISC processor +running under NextStep (sorry, no HPUX, its linker keeps dumping +core on me). + +* References not captured in a function are optimized into variables. + +* Fixed several bugs related to exceptions. + +* Floats behave a little more as specified in the IEEE standard +(believe it or not, but x < y is not the negation of x >= y). + +* Lower memory consumption for the native-code compiler. + +Caml Special Light 1.10: +------------------------ + +* Many bug fixes (too many to list here). + +* Module language: introduction of a "with module" notation over +signatures for concise sharing of all type components of a signature; +better support for concrete types in signatures. + +* Native-code compiler: the Intel 386 version has been ported to +NextStep and FreeBSD, and generates better code (especially for +floats) + +* Tools and libraries: the Caml Light profiler and library for +arbitrary-precision arithmetic have been ported (thanks to John +Malecki and Victor Manuel Gulias Fernandez); better docs for the Unix +and regexp libraries. + +Caml Special Light 1.07: +------------------------ + +* Syntax: optional ;; allowed in compilation units and structures +(back by popular demand) + +* cslopt: +generic handling of float arrays fixed +direct function application when the function expr is not a path fixed +compilation of "let rec" over values fixed +multiple definitions of a value name in a module correctly handled +no calls to ranlib in Solaris + +* csltop: #trace now working + +* Standard library: added List.memq; documentation of Array fixed. + +Caml Special Light 1.06: +------------------------ + +* First public release. + +$Id$ diff --git a/Changes_JoCaml b/Changes_JoCaml new file mode 100644 index 0000000000..903ff294c6 --- /dev/null +++ b/Changes_JoCaml @@ -0,0 +1,12 @@ + +- Several alteration of scheduling, so as to + limit pending signals, <= threads in pool and <= tasks in pool. + +- Added 'JoinFifo' and 'JoinCount' in standard library. + + +JoCaml 3.10.0: +-------------- +Initial release + +$Id$
\ No newline at end of file @@ -23,7 +23,7 @@ INSTALLATION INSTRUCTION ./configure -With respect to Objective Caml the ""configure" script options are modified +With respect to Objective Caml the "configure" script options are modified as follows. Suppressed options. @@ -66,7 +66,7 @@ Caml compilers, you can compile them with the native-code compiler make opt.opt -6- You can now install the Objective Caml system. This will create the +6- You can now install the JoCaml system. This will create the JoCaml commands (in the binary directory selected during autoconfiguration). @@ -88,4 +88,4 @@ ocamlprof, ocamlcp, ocamldoc. IF SOMETHING GOES WRONG: -Refer to the same section in file INSTALL_OCAML +Refer to the same section in file INSTALL_OCAML. diff --git a/INSTALL_OCAML b/INSTALL_OCAML index a1f06f4fb8..c1d8457086 100644 --- a/INSTALL_OCAML +++ b/INSTALL_OCAML @@ -100,21 +100,38 @@ The "configure" script accepts the following options: options for finding the header files, and "-dllibs" for finding the C libraries. --binutils <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 @@ -21,7 +21,7 @@ include otherlibs/systhreads/JoinModules include otherlibs/join/StdJoinModules CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot $(NOJOIN) -CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib $(NOJOIN) +CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink $(NOJOIN) COMPFLAGS=-warn-error A $(INCLUDES) LINKFLAGS= @@ -110,6 +110,11 @@ TOPOBJS=$(TOPLEVELLIB)\ otherlibs/join/join.cma\ $(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 \ @@ -135,14 +140,26 @@ center:runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml otherlibraries # Recompile the system using the bootstrap compiler all: center 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: @@ -166,6 +183,8 @@ coreboot: $(MAKE) compare # Bootstrap and rebuild the whole system. +# The compilation of ocaml will fail if the runtime has changed. +# Never mind, just do make bootstrap to reach fixpoint again. bootstrap: $(MAKE) coreboot $(MAKE) all @@ -187,7 +206,10 @@ coldstart: ln -s ../byterun stdlib/caml; fi # Build the core system: the minimum needed to make depend and bootstrap -core : coldstart ocamlc ocamllex ocamlyacc ocamltools library +core: coldstart ocamlc ocamllex ocamlyacc ocamltools library + +# Recompile the core system using the bootstrap compiler +coreall: ocamlc ocamllex ocamlyacc ocamltools library # Save the current bootstrap compiler MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev @@ -198,7 +220,8 @@ backup: mkdir boot/Saved mv boot/Saved.prev boot/Saved/Saved.prev cp boot/ocamlrun$(EXE) boot/Saved - mv boot/ocamlc boot/ocamllex boot/ocamlyacc$(EXE) boot/ocamldep boot/Saved + mv boot/ocamlc boot/ocamllex boot/ocamlyacc$(EXE) boot/ocamldep \ + boot/Saved cd boot; cp $(LIBFILES) Saved # Promote the newly compiled system to the rank of cross compiler @@ -223,7 +246,8 @@ restore: # Check if fixpoint reached compare: - @if cmp boot/ocamlc ocamlc && cmp boot/ocamllex lex/ocamllex && cmp boot/ocamldep tools/ocamldep; \ + @if cmp boot/ocamlc ocamlc && cmp boot/ocamllex lex/ocamllex \ + && cmp boot/ocamldep tools/ocamldep; \ then echo "Fixpoint reached, bootstrap succeeded."; \ else echo "Fixpoint not reached, try one more bootstrapping cycle."; \ fi @@ -233,6 +257,7 @@ cleanboot: rm -rf boot/Saved/Saved.prev/* # Compile the native-code compiler + opt-core:runtimeopt ocamlopt libraryopt opt-center:opt-core otherlibrariesopt opt: runtimeopt ocamlopt libraryopt otherlibrariesopt @@ -243,11 +268,12 @@ opt.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \ ocamllex.opt ocamltoolsopt.opt 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 @@ -261,7 +287,8 @@ install: FORCE cp expunge $(LIBDIR)/expunge$(EXE) cp typing/outcometree.cmi typing/outcometree.mli $(LIBDIR) cp toplevel/topstart.cmo $(LIBDIR) - cp toplevel/toploop.cmi toplevel/topdirs.cmi toplevel/topmain.cmi $(LIBDIR) + cp toplevel/toploop.cmi toplevel/topdirs.cmi toplevel/topmain.cmi \ + $(LIBDIR) cd tools; $(MAKE) install # -cd man; $(MAKE) install for i in $(OTHERLIBRARIES); do \ @@ -282,7 +309,8 @@ installopt: cp ocamlopt $(BINDIR)/jocamlopt$(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)/jocamlc.opt$(EXE); else :; fi if test -f ocamlopt.opt; \ @@ -341,6 +369,17 @@ toplevel/toplevellib.cma: $(TOPLIB) partialclean:: rm -f ocaml toplevel/toplevellib.cma +# The native toplevel + +ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx) + $(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat \ + $(NATTOPOBJS:.cmo=.cmx) -linkall + +toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa + +otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml + cd otherlibs/dynlink && make allopt + # The configuration file utils/config.ml: utils/config.mlp config/Makefile @@ -350,11 +389,8 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%BYTERUN%%|$(BINDIR)/jocamlrun|' \ -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)|' \ @@ -367,6 +403,10 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%EXT_LIB%%|.a|' \ -e 's|%%EXT_DLL%%|.so|' \ -e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \ + -e 's|%%ASM%%|$(ASM)|' \ + -e 's|%%MKDLL%%|$(MKDLL)|' \ + -e 's|%%MKEXE%%|$(MKEXE)|' \ + -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ utils/config.mlp > utils/config.ml @chmod -w utils/config.ml @@ -533,10 +573,12 @@ runtime: cd byterun; $(MAKE) all if test -f stdlib/libcamlrun.a; then :; else \ ln -s ../byterun/libcamlrun.a stdlib/libcamlrun.a; fi + clean:: cd byterun; $(MAKE) clean rm -f stdlib/libcamlrun.a rm -f stdlib/caml + alldepend:: cd byterun; $(MAKE) depend @@ -546,9 +588,11 @@ runtimeopt: cd asmrun; $(MAKE) all if test -f stdlib/libasmrun.a; then :; else \ ln -s ../asmrun/libasmrun.a stdlib/libasmrun.a; fi + clean:: cd asmrun; $(MAKE) clean rm -f stdlib/libasmrun.a + alldepend:: cd asmrun; $(MAKE) depend @@ -556,12 +600,16 @@ alldepend:: library: ocamlc cd stdlib; $(MAKE) all + library-cross: cd stdlib; $(MAKE) RUNTIME=../byterun/ocamlrun all + libraryopt: cd stdlib; $(MAKE) allopt + partialclean:: cd stdlib; $(MAKE) clean + alldepend:: cd stdlib; $(MAKE) depend @@ -569,15 +617,19 @@ alldepend:: ocamllex: ocamlyacc ocamlc cd lex; $(MAKE) all + ocamllex.opt: ocamlopt cd lex; $(MAKE) allopt + partialclean:: cd lex; $(MAKE) clean + alldepend:: cd lex; $(MAKE) depend ocamlyacc: cd yacc; $(MAKE) all + clean:: cd yacc; $(MAKE) clean @@ -585,68 +637,95 @@ 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 ocamldoc.opt: -#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: -#ocamldebugger: ocamlc ocamlyacc ocamllex +# ocamlc ocamlyacc ocamllex otherlibraries # cd debugger; $(MAKE) all +# #partialclean:: # cd debugger; $(MAKE) clean +# #alldepend:: # cd debugger; $(MAKE) depend + # Camlp4 camlp4out camlp4opt camlp4optopt: -#camlp4out: ocamlc -# cd camlp4; $(MAKE) all -#camlp4opt: ocamlopt -# cd camlp4; $(MAKE) opt -#camlp4optopt: ocamlopt -# cd camlp4; $(MAKE) opt.opt +#camlp4out: ocamlc otherlibraries ocamlbuild-partial-boot ocamlbuild.byte +# ./build/camlp4-byte-only.sh +# +#camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-partial-boot ocamlbuild.native +# ./build/camlp4-native-only.sh + +# Ocamlbuild +ocamlbuild.byte ocamlbuild.native: +#ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-partial-boot +# ./build/ocamlbuild-byte-only.sh +# +#ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-partial-boot +# ./build/ocamlbuild-native-only.sh +#ocamlbuildlib.native: ocamlopt otherlibrariesopt ocamlbuild-partial-boot +# ./build/ocamlbuildlib-native-only.sh +# +#ocamlbuild-partial-boot: ocamlc otherlibraries +# ./build/partial-boot.sh +# #partialclean:: -# cd camlp4; $(MAKE) clean -#alldepend:: -# cd camlp4; $(MAKE) depend +# rm -rf _build +# if test -d test; then \ +# (cd test; $(MAKE) clean); \ +# fi + # Check that the stack limit is reasonable. @@ -659,14 +738,9 @@ checkstack: # Make MacOS X package -.PHONY: package-macosx - package-macosx: sudo rm -rf package-macosx/root - make BINDIR="`pwd`"/package-macosx/root/bin \ - LIBDIR="`pwd`"/package-macosx/root/lib/jocaml \ - MANDIR="`pwd`"/package-macosx/root/man \ - install + make PREFIX="`pwd`"/package-macosx/root install tools/make-package-macosx sudo rm -rf package-macosx/root @@ -704,6 +778,18 @@ depend: beforedepend alldepend:: depend -FORCE: +distclean: + ./build/distclean.sh + +.PHONY: all backup bootstrap camlp4opt camlp4out checkstack clean +.PHONY: partialclean beforedepend alldepend cleanboot coldstart +.PHONY: compare core coreall +.PHONY: coreboot defaultentry depend distclean install installopt +.PHONY: library library-cross libraryopt ocamlbuild-partial-boot +.PHONY: ocamlbuild.byte ocamlbuild.native ocamldebugger ocamldoc +.PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltools.opt +.PHONY: ocamlyacc opt-core opt opt.opt otherlibraries +.PHONY: otherlibrariesopt package-macosx promote promote-cross +.PHONY: restore runtime runtimeopt world world.opt include .depend diff --git a/Makefile.nt b/Makefile.nt index ec8b91b1bd..855274bed7 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -18,7 +18,7 @@ include config/Makefile include stdlib/StdlibModules CAMLC=boot/ocamlrun boot/ocamlc -I boot -CAMLOPT=boot/ocamlrun ./ocamlopt -I stdlib +CAMLOPT=boot/ocamlrun ./ocamlopt -I stdlib -I otherlibs/dynlink COMPFLAGS=$(INCLUDES) LINKFLAGS= CAMLYACC=boot/ocamlyacc @@ -28,7 +28,8 @@ CAMLDEP=boot/ocamlrun tools/ocamldep DEPFLAGS=$(INCLUDES) CAMLRUN=byterun/ocamlrun -INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver -I toplevel +INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \ + -I toplevel UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \ @@ -98,6 +99,11 @@ TOPLIB=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(TOPLEVEL) TOPOBJS=$(TOPLEVELLIB) $(TOPLEVELSTART) +NATTOPOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) \ + driver/pparse.cmo driver/opterrors.cmo driver/optcompile.cmo \ + toplevel/genprintval.cmo toplevel/opttoploop.cmo toplevel/opttopdirs.cmo \ + toplevel/opttopmain.cmo toplevel/opttopstart.cmo + OPTOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) $(OPTDRIVER) EXPUNGEOBJS=utils/misc.cmo utils/tbl.cmo \ @@ -114,7 +120,7 @@ defaultentry: @echo "Please refer to the installation instructions in file README.win32." # Recompile the system using the bootstrap compiler -all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml otherlibraries ocamldoc.byte ocamlbuild.byte camlp4out win32gui +all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml otherlibraries ocamldoc.byte ocamlbuild.byte camlp4out $(DEBUGGER) win32gui # The compilation of ocaml will fail if the runtime has changed. # Never mind, just do make bootstrap to reach fixpoint again. @@ -148,7 +154,6 @@ LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader coldstart: cd byterun ; $(MAKEREC) all cp byterun/ocamlrun.exe boot/ocamlrun.exe - cp byterun/ocamlrun.dll boot/ocamlrun.dll cd yacc ; $(MAKEREC) all cp yacc/ocamlyacc.exe boot/ocamlyacc.exe cd stdlib ; $(MAKEREC) COMPILER=../boot/ocamlc all @@ -200,7 +205,7 @@ cleanboot: rm -rf boot/Saved/Saved.prev/* # Compile the native-code compiler -opt: runtimeopt ocamlopt libraryopt otherlibrariesopt +opt: runtimeopt ocamlopt libraryopt otherlibrariesopt ocamlbuildlib.native # Native-code versions of the tools opt.opt: ocamlc.opt ocamlopt.opt ocamllex.opt ocamltoolsopt.opt \ @@ -213,8 +218,6 @@ installbyt: mkdir -p $(BINDIR) mkdir -p $(LIBDIR) cd byterun ; $(MAKEREC) install - echo "$(STUBLIBDIR)" > $(LIBDIR)/ld.conf - echo "$(LIBDIR)" >> $(LIBDIR)/ld.conf cp ocamlc $(BINDIR)/ocamlc.exe cp ocaml $(BINDIR)/ocaml.exe cd stdlib ; $(MAKEREC) install @@ -229,6 +232,8 @@ installbyt: cd ocamldoc ; $(MAKEREC) install mkdir -p $(STUBLIBDIR) for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done + if test -f debugger/ocamldebug.exe; then (cd debugger; $(MAKEREC) install); \ + else :; fi cd win32caml ; $(MAKE) install ./build/partial-install.sh cp config/Makefile $(LIBDIR)/Makefile.config @@ -288,6 +293,17 @@ toplevel/toplevellib.cma: $(TOPLIB) partialclean:: rm -f ocaml +# The native toplevel + +ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx) + $(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat $(NATTOPOBJS:.cmo=.cmx) -linkall + +toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa + +otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml + cd otherlibs/dynlink && make allopt + + # The configuration file utils/config.ml: utils/config.mlp config/Makefile @@ -296,9 +312,7 @@ utils/config.ml: utils/config.mlp config/Makefile -e "s|%%BYTERUN%%|ocamlrun|" \ -e 's|%%CCOMPTYPE%%|$(CCOMPTYPE)|' \ -e "s|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS)|" \ - -e "s|%%BYTELINK%%|$(BYTECC) $(BYTECCLINKOPTS)|" \ -e "s|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|" \ - -e "s|%%NATIVELINK%%|$(NATIVECC) $(NATIVECCLINKOPTS)|" \ -e "s|%%PARTIALLD%%|$(PARTIALLD)|" \ -e "s|%%PACKLD%%|$(PACKLD)|" \ -e "s|%%BYTECCLIBS%%|$(BYTECCLIBS)|" \ @@ -314,6 +328,11 @@ utils/config.ml: utils/config.mlp config/Makefile -e "s|%%EXT_LIB%%|.$(A)|" \ -e "s|%%EXT_DLL%%|.dll|" \ -e "s|%%SYSTHREAD_SUPPORT%%|true|" \ + -e 's|%%ASM%%|$(ASM)|' \ + -e 's|%%MKDLL%%|$(MKDLL)|' \ + -e 's|%%MKEXE%%|$(MKEXE)|' \ + -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ + -e 's|%%CC_PROFILE%%||' \ utils/config.mlp > utils/config.ml @chmod -w utils/config.ml @@ -564,6 +583,15 @@ clean:: alldepend:: for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i depend; done +# The replay debugger + +ocamldebugger: ocamlc ocamlyacc ocamllex + cd debugger; $(MAKEREC) all +partialclean:: + cd debugger; $(MAKEREC) clean +alldepend:: + cd debugger; $(MAKEREC) depend + # Camlp4 camlp4out: ocamlc otherlibraries ocamlbuild-partial-boot ocamlbuild.byte @@ -577,6 +605,9 @@ 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: @@ -1,4 +1,4 @@ -3.10.0 +3.11+dev19 Private_abbrevs+natdynlink+lazy_patterns+fscanf debug (2008-10-06) # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli @@ -16,8 +16,8 @@ true: debug # By default everything we link needs the stdlib true: use_stdlib -# The stdlib don't require the stdlib -<stdlib/**>: -use_stdlib +# The stdlib neither requires the stdlib nor debug information +<stdlib/**>: -use_stdlib, -debug <**/*.ml*>: warn_Alez @@ -30,12 +30,13 @@ true: use_stdlib "ocamldoc/odoc_opt.native": use_unix, use_str <camlp4/**/*.ml*>: camlp4boot, -warn_Alez, warn_Ale -<camlp4/Camlp4_config.ml*>: -camlp4boot +<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 diff --git a/asmcomp/alpha/proc.ml b/asmcomp/alpha/proc.ml index 19531863e8..6bcf44f59a 100644 --- a/asmcomp/alpha/proc.ml +++ b/asmcomp/alpha/proc.ml @@ -207,11 +207,11 @@ let contains_calls = ref false let assemble_file infile outfile = let as_cmd = - if digital_asm - then if !Clflags.gprofile then "as -O2 -nocpp -pg -o " - else "as -O2 -nocpp -o " - else "as -o " in - Ccomp.command (as_cmd ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + if digital_asm && !Clflags.gprofile + then Config.as ^ " -pg" + else Config.as in + Ccomp.command (as_cmd ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 4f2d54d172..c38a73e8c2 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -36,10 +36,10 @@ let frame_required () = let frame_size () = (* includes return address *) if frame_required() then begin - let sz = + let sz = (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8) in Misc.align sz 16 - end else + end else !stack_offset + 8 let slot_offset loc cl = @@ -56,6 +56,24 @@ let slot_offset loc cl = let emit_symbol s = Emitaux.emit_symbol '$' s +let emit_call s = + if !Clflags.dlcode + then `call {emit_symbol s}@PLT` + else `call {emit_symbol s}` + +let emit_jump s = + if !Clflags.dlcode + then `jmp {emit_symbol s}@PLT` + else `jmp {emit_symbol s}` + +let load_symbol_addr s = + if !Clflags.dlcode + then `movq {emit_symbol s}@GOTPCREL(%rip)` + else if !pic_code + then `leaq {emit_symbol s}(%rip)` + else `movq ${emit_symbol s}` + + (* Output a label *) let emit_label lbl = @@ -111,7 +129,8 @@ let emit_reg32 r = emit_subreg reg_low_32_name r let emit_addressing addr r n = match addr with - Ibased(s, d) -> + | Ibased _ when !Clflags.dlcode -> assert false + | Ibased(s, d) -> `{emit_symbol s}`; if d <> 0 then ` + {emit_int d}`; `(%rip)` @@ -164,7 +183,7 @@ type gc_call = let call_gc_sites = ref ([] : gc_call list) let emit_call_gc gc = - `{emit_label gc.gc_lbl}: call {emit_symbol "caml_call_gc"}\n`; + `{emit_label gc.gc_lbl}: {emit_call "caml_call_gc"}\n`; `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` (* Record calls to caml_ml_array_bound_error. @@ -191,13 +210,13 @@ let bound_error_label dbg = end let emit_call_bound_error bd = - `{emit_label bd.bd_lbl}: call {emit_symbol "caml_ml_array_bound_error"}\n`; + `{emit_label bd.bd_lbl}: {emit_call "caml_ml_array_bound_error"}\n`; `{emit_label bd.bd_frame}:\n` let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; if !bound_error_call > 0 then - `{emit_label !bound_error_call}: jmp {emit_symbol "caml_ml_array_bound_error"}\n` + `{emit_label !bound_error_call}: {emit_call "caml_ml_array_bound_error"}\n` (* Names for instructions *) @@ -326,15 +345,12 @@ let emit_instr fallthrough i = ` movlpd {emit_label lbl}(%rip), {emit_reg i.res.(0)}\n` end | Lop(Iconst_symbol s) -> - if !pic_code then - ` leaq {emit_symbol s}(%rip), {emit_reg i.res.(0)}\n` - else - ` movq ${emit_symbol s}, {emit_reg i.res.(0)}\n` + ` {load_symbol_addr s}, {emit_reg i.res.(0)}\n` | Lop(Icall_ind) -> ` call *{emit_reg i.arg.(0)}\n`; record_frame i.live i.dbg | Lop(Icall_imm(s)) -> - ` call {emit_symbol s}\n`; + ` {emit_call s}\n`; record_frame i.live i.dbg | Lop(Itailcall_ind) -> output_epilogue(); @@ -344,15 +360,15 @@ let emit_instr fallthrough i = ` jmp {emit_label !tailrec_entry_point}\n` else begin output_epilogue(); - ` jmp {emit_symbol s}\n` + ` {emit_jump s}\n` end | Lop(Iextcall(s, alloc)) -> if alloc then begin - ` leaq {emit_symbol s}(%rip), %rax\n`; - ` call {emit_symbol "caml_c_call"}\n`; + ` {load_symbol_addr s}, %rax\n`; + ` {emit_call "caml_c_call"}\n`; record_frame i.live i.dbg end else begin - ` call {emit_symbol s}\n` + ` {emit_call s}\n` end | Lop(Istackoffset n) -> if n < 0 @@ -401,7 +417,11 @@ let emit_instr fallthrough i = if !fastcode_flag then begin let lbl_redo = new_label() in `{emit_label lbl_redo}: subq ${emit_int n}, %r15\n`; - ` cmpq {emit_symbol "caml_young_limit"}(%rip), %r15\n`; + if !Clflags.dlcode then begin + ` {load_symbol_addr "caml_young_limit"}, %rax\n`; + ` cmpq (%rax), %r15\n`; + end else + ` cmpq {emit_symbol "caml_young_limit"}(%rip), %r15\n`; let lbl_call_gc = new_label() in let lbl_frame = record_frame_label i.live Debuginfo.none in ` jb {emit_label lbl_call_gc}\n`; @@ -412,11 +432,11 @@ let emit_instr fallthrough i = gc_frame = lbl_frame } :: !call_gc_sites end else begin begin match n with - 16 -> ` call {emit_symbol "caml_alloc1"}\n` - | 24 -> ` call {emit_symbol "caml_alloc2"}\n` - | 32 -> ` call {emit_symbol "caml_alloc3"}\n` + 16 -> ` {emit_call "caml_alloc1"}\n` + | 24 -> ` {emit_call "caml_alloc2"}\n` + | 32 -> ` {emit_call "caml_alloc3"}\n` | _ -> ` movq ${emit_int n}, %rax\n`; - ` call {emit_symbol "caml_allocN"}\n` + ` {emit_call "caml_allocN"}\n` end; `{record_frame i.live Debuginfo.none} leaq 8(%r15), {emit_reg i.res.(0)}\n` end @@ -487,7 +507,7 @@ let emit_instr fallthrough i = | Lop(Ispecific(Istore_int(n, addr))) -> ` movq ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Istore_symbol(s, addr))) -> - assert (not !pic_code); + assert (not !pic_code && not !Clflags.dlcode); ` movq ${emit_symbol s}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> ` addq ${emit_int n}, {emit_addressing addr i.arg 0}\n` @@ -514,7 +534,7 @@ let emit_instr fallthrough i = ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm((Isigned Ceq | Isigned Cne | + | Iinttest_imm((Isigned Ceq | Isigned Cne | Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> output_test_zero i.arg.(0); let b = name_for_cond_branch cmp in @@ -548,9 +568,23 @@ let emit_instr fallthrough i = end | Lswitch jumptbl -> let lbl = new_label() in - if !pic_code then begin - ` leaq {emit_label lbl}(%rip), %r11\n`; - ` jmp *(%r11, {emit_reg i.arg.(0)}, 8)\n` + 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 + can still be assigned to r11, so we need to special-case + this situation. *) + if i.arg.(0).loc = Reg 9 (* ie r11, cf amd64/proc.ml *) then begin + ` salq $3, %r11\n`; + ` pushq %r11\n`; + ` leaq {emit_label lbl}(%rip), %r11\n`; + ` addq 0(%rsp), %r11\n`; + ` addq $8, %rsp\n`; + ` jmp *(%r11)\n` + end else begin + ` leaq {emit_label lbl}(%rip), %r11\n`; + ` jmp *(%r11, {emit_reg i.arg.(0)}, 8)\n` + end end else begin ` jmp *{emit_label lbl}(, {emit_reg i.arg.(0)}, 8)\n` end; @@ -573,7 +607,7 @@ let emit_instr fallthrough i = stack_offset := !stack_offset - 16 | Lraise -> if !Clflags.debug then begin - ` call {emit_symbol "caml_raise_exn"}\n`; + ` {emit_call "caml_raise_exn"}\n`; record_frame Reg.Set.empty i.dbg end else begin ` movq %r14, %rsp\n`; @@ -605,7 +639,7 @@ let emit_profile () = ` pushq %r10\n`; ` movq %rsp, %rbp\n`; ` pushq %r11\n`; - ` call {emit_symbol "mcount"}\n`; + ` {emit_call "mcount"}\n`; ` popq %r11\n`; ` popq %r10\n` | _ -> @@ -679,6 +713,14 @@ let data l = (* Beginning / end of an assembly file *) let begin_assembly() = + if !Clflags.dlcode then begin + (* from amd64.S; could emit these constants on demand *) + ` .section .rodata.cst8,\"a\",@progbits\n`; + ` .align 16\n`; + `caml_negf_mask: .quad 0x8000000000000000, 0\n`; + ` .align 16\n`; + `caml_absf_mask: .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF\n`; + end; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in ` .data\n`; ` .globl {emit_symbol lbl_begin}\n`; @@ -710,4 +752,8 @@ let end_assembly() = efa_label_rel = (fun lbl ofs -> ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n`); efa_def_label = (fun l -> `{emit_label l}:\n`); - efa_string = (fun s -> emit_string_directive " .asciz " s) } + efa_string = (fun s -> emit_string_directive " .asciz " s) }; + if Config.system = "linux" then + (* Mark stack as non-executable, PR#4564 *) + ` .section .note.GNU-stack,\"\",%progbits\n` + diff --git a/asmcomp/amd64/emit_nt.mlp b/asmcomp/amd64/emit_nt.mlp index 30b046e6de..71b71157b8 100644 --- a/asmcomp/amd64/emit_nt.mlp +++ b/asmcomp/amd64/emit_nt.mlp @@ -217,7 +217,7 @@ let emit_call_bound_error bd = let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; if !bound_error_call > 0 then - `{emit_label !bound_error_call}: jmp caml_ml_array_bound_error\n` + `{emit_label !bound_error_call}: call caml_ml_array_bound_error\n` (* Names for instructions *) diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index 0e274b4f4e..32d669dbbe 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -170,7 +170,7 @@ let destroyed_at_oper = function | Iop(Istore(Single, _)) -> [| rxmm15 |] | Iop(Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _)) -> [| rax |] - | Iswitch(_, _) when !pic_code -> [| r11 |] + | Iswitch(_, _) when !pic_code || !Clflags.dlcode -> [| r11 |] | _ -> [||] let destroyed_at_raise = all_phys_regs @@ -197,5 +197,5 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Ccomp.command ("as -o " ^ outfile ^ " " ^ infile) + Ccomp.command (Config.asm ^ " -o " ^ outfile ^ " " ^ infile) diff --git a/asmcomp/amd64/proc_nt.ml b/asmcomp/amd64/proc_nt.ml index dc53779afe..05ce517dd7 100644 --- a/asmcomp/amd64/proc_nt.ml +++ b/asmcomp/amd64/proc_nt.ml @@ -228,10 +228,6 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Ccomp.command ("ml64 /nologo /Cp /c /Fo" ^ + Ccomp.command (Config.asm ^ Filename.quote outfile ^ " " ^ Filename.quote infile ^ "> NUL") - - (* /Cp preserve case of all used identifiers - /c assemble only - /Fo output file name *) diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml index 99413edcc1..6901b5594e 100644 --- a/asmcomp/amd64/reload.ml +++ b/asmcomp/amd64/reload.ml @@ -93,7 +93,7 @@ method reload_operation op arg res = then (arg, res) else super#reload_operation op arg res | Iconst_symbol _ -> - if !pic_code + if !pic_code || !Clflags.dlcode then super#reload_operation op arg res else (arg, res) | _ -> (* Other operations: all args and results in registers *) diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index d33ae744cc..6ee3ee160d 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -32,7 +32,7 @@ type addressing_expr = let rec select_addr exp = match exp with - Cconst_symbol s -> + Cconst_symbol s when not !Clflags.dlcode -> (Asymbol s, 0) | Cop((Caddi | Cadda), [arg; Cconst_int m]) -> let (a, n) = select_addr arg in (a, n + m) @@ -144,7 +144,7 @@ method select_store addr exp = (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) | Cconst_natpointer n when self#is_immediate_natint n -> (Ispecific(Istore_int(n, addr)), Ctuple []) - | Cconst_symbol s when not !pic_code -> + | Cconst_symbol s when not (!pic_code || !Clflags.dlcode) -> (Ispecific(Istore_symbol(s, addr)), Ctuple []) | _ -> super#select_store addr exp diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index a26aaee618..586d477bd1 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -648,9 +648,6 @@ let begin_assembly() = `trap_ptr .req r11\n`; `alloc_ptr .req r8\n`; `alloc_limit .req r9\n`; - `sp .req r13\n`; - `lr .req r14\n`; - `pc .req r15\n`; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in ` .data\n`; ` .global {emit_symbol lbl_begin}\n`; diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml index df6f081a7c..5e8318ba9f 100644 --- a/asmcomp/arm/proc.ml +++ b/asmcomp/arm/proc.ml @@ -190,7 +190,8 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Sys.command ("as -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml index 3066d785d9..e34093acbd 100644 --- a/asmcomp/arm/selection.ml +++ b/asmcomp/arm/selection.ml @@ -106,7 +106,7 @@ method select_operation op args = | _ -> (Iextcall("__modsi3", false), args) end - | Ccheckbound -> + | Ccheckbound _ -> begin match args with [Cop(Clsr, [arg1; Cconst_int n]); arg2] when n > 0 && n < 32 && not(is_intconst arg2) -> @@ -116,15 +116,15 @@ method select_operation op args = end | _ -> super#select_operation op args -(* In mul rd, rm, rs, rm and rd must be different. +(* In mul rd, rm, rs, the registers rm and rd must be different. We deal with this by pretending that rm is also a result of the mul operation. *) -method insert_op op rs rd = +method insert_op_debug op dbg rs rd = if op = Iintop(Imul) then begin - self#insert (Iop op) rs [| rd.(0); rs.(0) |]; rd + self#insert_debug (Iop op) dbg rs [| rd.(0); rs.(0) |]; rd end else - super#insert_op op rs rd + super#insert_op_debug op dbg rs rd end diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 341d71c7b2..36edea8cf4 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -83,7 +83,18 @@ let compile_phrase ppf p = | Cfunction fd -> compile_fundecl ppf fd | Cdata dl -> Emit.data dl -let compile_implementation prefixname ppf (size, lam) = + +(* For the native toplevel: generates generic functions unless + they are already available in the process *) +let compile_genfuns ppf f = + List.iter + (function + | (Cfunction {fun_name = name}) as ph when f name -> + compile_phrase ppf ph + | _ -> ()) + (Cmmgen.generic_functions true [Compilenv.current_unit_infos ()]) + +let compile_implementation ?toplevel prefixname ppf (size, lam) = let asmfile = if !keep_asm_file then prefixname ^ ext_asm @@ -95,6 +106,20 @@ let compile_implementation prefixname ppf (size, lam) = Closure.intro size lam ++ Cmmgen.compunit size ++ List.iter (compile_phrase ppf) ++ (fun () -> ()); + (match toplevel with None -> () | Some f -> compile_genfuns ppf f); + + (* We add explicit references to external primitive symbols. This + is to ensure that the object files that define these symbols, + when part of a C library, won't be discarded by the linker. + This is important if a module that uses such a symbol is later + dynlinked. *) + + compile_phrase ppf + (Cmmgen.reference_symbols + (List.filter (fun s -> s <> "" && s.[0] <> '%') + (List.map Primitive.native_name !Translmod.primitive_declarations)) + ); + Emit.end_assembly(); close_out oc with x -> diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli index 0f6b831ceb..fe578bd4f5 100644 --- a/asmcomp/asmgen.mli +++ b/asmcomp/asmgen.mli @@ -15,6 +15,7 @@ (* From lambda to assembly code *) val compile_implementation : + ?toplevel:(string -> bool) -> string -> Format.formatter -> int * Lambda.lambda -> unit val compile_phrase : Format.formatter -> Cmm.phrase -> unit diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 3bbc761206..f02a9b3306 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -70,14 +70,14 @@ let check_consistency file_name unit crc = with Not_found -> () end; Consistbl.set crc_implementations unit.ui_name crc file_name; - implementations_defined := + implementations_defined := (unit.ui_name, file_name) :: !implementations_defined; if unit.ui_symbol <> unit.ui_name then cmx_required := unit.ui_name :: !cmx_required let extract_crc_interfaces () = Consistbl.extract crc_interfaces -let extract_crc_implementations () = +let extract_crc_implementations () = List.fold_left (fun ncl n -> if List.mem_assoc n ncl then ncl else (n, cmx_not_found_crc) :: ncl) @@ -96,6 +96,30 @@ let add_ccobjs l = lib_ccopts := l.lib_ccopts @ !lib_ccopts end +let runtime_lib () = + let libname = + if !Clflags.gprofile + then "libasmrunp" ^ ext_lib + else "libasmrun" ^ ext_lib in + try + if !Clflags.nopervasives then [] + else [ find_in_path !load_path libname ] + with Not_found -> + raise(Error(File_not_found libname)) + +let object_file_name name = + let file_name = + try + find_in_path !load_path name + with Not_found -> + fatal_error "Asmlink.object_file_name: not found" in + if Filename.check_suffix file_name ".cmx" then + Filename.chop_suffix file_name ".cmx" ^ ext_obj + else if Filename.check_suffix file_name ".cmxa" then + Filename.chop_suffix file_name ".cmxa" ^ ext_lib + else + fatal_error "Asmlink.object_file_name: bad ext" + (* First pass: determine which units are needed *) let missing_globals = (Hashtbl.create 17 : (string, string list ref) Hashtbl.t) @@ -119,7 +143,11 @@ let extract_missing_globals () = Hashtbl.iter (fun md rq -> mg := (md, !rq) :: !mg) missing_globals; !mg -let scan_file obj_name tolink = +type file = + | Unit of string * Compilenv.unit_infos * Digest.t + | Library of string * Compilenv.library_infos + +let read_file obj_name = let file_name = try find_in_path !load_path obj_name @@ -129,45 +157,44 @@ let scan_file obj_name tolink = (* This is a .cmx file. It must be linked in any case. Read the infos to see which modules it requires. *) let (info, crc) = Compilenv.read_unit_info file_name in - remove_required info.ui_name; - List.iter (add_required file_name) info.ui_imports_cmx; - (info, file_name, crc) :: tolink + Unit (file_name,info,crc) end else if Filename.check_suffix file_name ".cmxa" then begin - (* This is an archive file. Each unit contained in it will be linked - in only if needed. *) - let ic = open_in_bin file_name in - let buffer = String.create (String.length cmxa_magic_number) in - really_input ic buffer 0 (String.length cmxa_magic_number); - if buffer <> cmxa_magic_number then - raise(Error(Not_an_object_file file_name)); - let infos = (input_value ic : library_infos) in - close_in ic; - add_ccobjs infos; - List.fold_right - (fun (info, crc) reqd -> - if info.ui_force_link - || !Clflags.link_everything - || is_required info.ui_name - then begin - remove_required info.ui_name; - List.iter (add_required (Printf.sprintf "%s(%s)" - file_name info.ui_name)) - info.ui_imports_cmx; - (info, file_name, crc) :: reqd - end else - reqd) - infos.lib_units tolink + let infos = + try Compilenv.read_library_info file_name + with Compilenv.Error(Not_a_unit_info _) -> + raise(Error(Not_an_object_file file_name)) + in + Library (file_name,infos) end else raise(Error(Not_an_object_file file_name)) -(* Second pass: generate the startup file and link it with everything else *) +let scan_file obj_name tolink = match read_file obj_name with + | Unit (file_name,info,crc) -> + (* This is a .cmx file. It must be linked in any case. *) + remove_required info.ui_name; + List.iter (add_required file_name) info.ui_imports_cmx; + (info, file_name, crc) :: tolink + | Library (file_name,infos) -> + (* This is an archive file. Each unit contained in it will be linked + in only if needed. *) + add_ccobjs infos; + List.fold_right + (fun (info, crc) reqd -> + if info.ui_force_link + || !Clflags.link_everything + || is_required info.ui_name + then begin + remove_required info.ui_name; + List.iter (add_required (Printf.sprintf "%s(%s)" + file_name info.ui_name)) + info.ui_imports_cmx; + (info, file_name, crc) :: reqd + end else + reqd) + infos.lib_units tolink -module IntSet = Set.Make( - struct - type t = int - let compare = compare - end) +(* Second pass: generate the startup file and link it with everything else *) let make_startup_file ppf filename units_list = let compile_phrase p = Asmgen.compile_phrase ppf p in @@ -179,126 +206,94 @@ let make_startup_file ppf filename units_list = let name_list = List.flatten (List.map (fun (info,_,_) -> info.ui_defines) units_list) in compile_phrase (Cmmgen.entry_point name_list); - let apply_functions = ref (IntSet.add 2 (IntSet.add 3 IntSet.empty)) in - (* The callback functions always reference caml_apply[23] *) - let send_functions = ref IntSet.empty in - let curry_functions = ref IntSet.empty in - List.iter - (fun (info,_,_) -> - List.iter - (fun n -> apply_functions := IntSet.add n !apply_functions) - info.ui_apply_fun; - List.iter - (fun n -> send_functions := IntSet.add n !send_functions) - info.ui_send_fun; - List.iter - (fun n -> curry_functions := IntSet.add n !curry_functions) - info.ui_curry_fun) - units_list; - IntSet.iter - (fun n -> compile_phrase (Cmmgen.apply_function n)) - !apply_functions; - IntSet.iter - (fun n -> compile_phrase (Cmmgen.send_function n)) - !send_functions; - IntSet.iter - (fun n -> List.iter (compile_phrase) (Cmmgen.curry_function n)) - !curry_functions; + let units = List.map (fun (info,_,_) -> info) units_list in + List.iter compile_phrase (Cmmgen.generic_functions false units); Array.iter (fun name -> compile_phrase (Cmmgen.predef_exception name)) Runtimedef.builtin_exceptions; compile_phrase (Cmmgen.global_table name_list); compile_phrase (Cmmgen.globals_map - (List.map - (fun (unit,_,_) -> - try (unit.ui_name, List.assoc unit.ui_name unit.ui_imports_cmi) - with Not_found -> assert false) - units_list)); + (List.map + (fun (unit,_,crc) -> + try (unit.ui_name, List.assoc unit.ui_name unit.ui_imports_cmi, + crc, + unit.ui_defines) + with Not_found -> assert false) + units_list)); compile_phrase(Cmmgen.data_segment_table ("_startup" :: name_list)); compile_phrase(Cmmgen.code_segment_table ("_startup" :: name_list)); compile_phrase (Cmmgen.frame_table("_startup" :: "_system" :: name_list)); + Emit.end_assembly(); close_out oc -let call_linker file_list startup_file output_name = - let libname = - if !Clflags.gprofile - then "libasmrunp" ^ ext_lib - else "libasmrun" ^ ext_lib in - let runtime_lib = - try - if !Clflags.nopervasives then "" - else 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)) - (Filename.quote 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)) - (Filename.quote 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 *) @@ -325,7 +320,9 @@ let link ppf objfiles output_name = units_tolink; Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; Clflags.ccopts := !lib_ccopts @ !Clflags.ccopts; (* put user's opts first *) - let startup = Filename.temp_file "camlstartup" ext_asm in + let startup = + if !Clflags.keep_startup_file then output_name ^ ".startup" ^ ext_asm + else Filename.temp_file "camlstartup" ext_asm in make_startup_file ppf startup units_tolink; let startup_obj = Filename.temp_file "camlstartup" ext_obj in if Proc.assemble_file startup startup_obj <> 0 then diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli index 28c5287daf..2070c815d8 100644 --- a/asmcomp/asmlink.mli +++ b/asmcomp/asmlink.mli @@ -12,12 +12,16 @@ (* $Id$ *) -(* Link a set of .cmx/.o files and produce an executable *) +(* Link a set of .cmx/.o files and produce an executable or a plugin *) open Format val link: formatter -> string list -> string -> unit +val link_shared: formatter -> string list -> string -> unit + +val call_linker_shared: string list -> string -> unit + val check_consistency: string -> Compilenv.unit_infos -> Digest.t -> unit val extract_crc_interfaces: unit -> (string * Digest.t) list val extract_crc_implementations: unit -> (string * Digest.t) list diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 4469e77e6a..6be94a1b64 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -80,10 +80,14 @@ let check_units members = (* Make the .o file for the package *) let make_package_object ppf members targetobj targetname coercion = - (* Put the full name of the module in the temporary file name - to avoid collisions with MSVC's link /lib in case of successive packs *) let objtemp = - Filename.temp_file (Compilenv.make_symbol (Some "")) Config.ext_obj in + if !Clflags.keep_asm_file + then chop_extension_if_any targetobj ^ ".pack" ^ Config.ext_obj + else + (* Put the full name of the module in the temporary file name + to avoid collisions with MSVC's link /lib in case of successive + packs *) + Filename.temp_file (Compilenv.make_symbol (Some "")) Config.ext_obj in let components = List.map (fun m -> @@ -99,15 +103,11 @@ let make_package_object ppf members targetobj targetname coercion = List.map (fun m -> chop_extension_if_any m.pm_file ^ Config.ext_obj) (List.filter (fun m -> m.pm_kind <> PM_intf) members) in - let ld_cmd = - sprintf "%s%s %s %s" - Config.native_pack_linker - (Filename.quote targetobj) - (Filename.quote objtemp) - (Ccomp.quote_files objfiles) in - let retcode = Ccomp.command ld_cmd in + let ok = + Ccomp.call_linker Ccomp.Partial targetobj (objtemp :: objfiles) "" + in remove_file objtemp; - if retcode <> 0 then raise(Error Linking_error) + if not ok then raise(Error Linking_error) (* Make the .cmx file for the package *) @@ -146,7 +146,7 @@ let build_package_cmx members cmxfile = ui_send_fun = union(List.map (fun info -> info.ui_send_fun) units); ui_force_link = - List.exists (fun info -> info.ui_force_link) units + List.exists (fun info -> info.ui_force_link) units; } in Compilenv.write_unit_info pkg_infos cmxfile diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 15dc67986b..7524fb4e0d 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -108,8 +108,8 @@ let prim_size prim args = | Parrayrefs kind -> if kind = Pgenarray then 18 else 8 | Parraysets kind -> if kind = Pgenarray then 22 else 10 | Pbittest -> 3 - | Pbigarrayref(ndims, _, _) -> 4 + ndims * 6 - | Pbigarrayset(ndims, _, _) -> 4 + ndims * 6 + | Pbigarrayref(_, ndims, _, _) -> 4 + ndims * 6 + | Pbigarrayset(_, ndims, _, _) -> 4 + ndims * 6 | _ -> 2 (* arithmetic and comparisons *) (* Very raw approximation of switch cost *) @@ -378,7 +378,7 @@ let rec is_pure = function | Lconst cst -> true | Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ | Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets | - Parraysetu _ | Parraysets _), _) -> false + Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false | Lprim(p, args) -> List.for_all is_pure args | Levent(lam, ev) -> is_pure lam | _ -> false @@ -492,7 +492,7 @@ let rec close fenv cenv = function end | Lfunction(kind, params, body) as funct -> close_one_function fenv cenv (Ident.create "fun") funct - | Lapply(funct, args) -> + | Lapply(funct, args, loc) -> let nargs = List.length args in begin match (close fenv cenv funct, close_list fenv cenv args) with ((ufunct, Value_closure(fundesc, approx_res)), @@ -767,7 +767,7 @@ and close_one_function fenv cenv id funct = and close_switch fenv cenv cases num_keys default = let index = Array.create num_keys 0 - and store = mk_store Pervasives.(=) in + and store = mk_store Lambda.same in (* First default case *) begin match default with diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 9f5e4f29b6..83cb1f6e39 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -180,8 +180,15 @@ let test_bool = function let box_float c = Cop(Calloc, [alloc_float_header; c]) -let unbox_float = function +let rec unbox_float = function Cop(Calloc, [header; c]) -> c + | Clet(id, exp, body) -> Clet(id, exp, unbox_float body) + | Cifthenelse(cond, e1, e2) -> + Cifthenelse(cond, unbox_float e1, unbox_float e2) + | Csequence(e1, e2) -> Csequence(e1, unbox_float e2) + | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map unbox_float el) + | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_float e1, unbox_float e2) + | Ctrywith(e1, id, e2) -> Ctrywith(unbox_float e1, id, unbox_float e2) | c -> Cop(Cload Double_u, [c]) (* Complex *) @@ -469,7 +476,7 @@ let box_int bi arg = Cconst_symbol(operations_boxed_int bi); arg']) -let unbox_int bi arg = +let rec unbox_int bi arg = match arg with Cop(Calloc, [hdr; ops; Cop(Clsl, [contents; Cconst_int 32])]) when bi = Pint32 && size_int = 8 && big_endian -> @@ -481,6 +488,13 @@ let unbox_int bi arg = Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32]) | Cop(Calloc, [hdr; ops; contents]) -> contents + | Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body) + | Cifthenelse(cond, e1, e2) -> + Cifthenelse(cond, unbox_int bi e1, unbox_int bi e2) + | Csequence(e1, e2) -> Csequence(e1, unbox_int bi e2) + | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map (unbox_int bi) el) + | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_int bi e1, unbox_int bi e2) + | Ctrywith(e1, id, e2) -> Ctrywith(unbox_int bi e1, id, unbox_int bi e2) | _ -> Cop(Cload(if bi = Pint32 then Thirtytwo_signed else Word), [Cop(Cadda, [arg; Cconst_int size_addr])]) @@ -507,23 +521,22 @@ let bigarray_elt_size = function | Pbigarray_complex32 -> 8 | Pbigarray_complex64 -> 16 -let bigarray_indexing elt_kind layout b args dbg = +let bigarray_indexing unsafe elt_kind layout b args dbg = + let check_bound a1 a2 k = + if unsafe then k else Csequence(Cop(Ccheckbound dbg, [a1;a2]), k) in let rec ba_indexing dim_ofs delta_ofs = function [] -> assert false | [arg] -> bind "idx" (untag_int arg) (fun idx -> - Csequence( - Cop(Ccheckbound dbg, [Cop(Cload Word,[field_address b dim_ofs]); idx]), - idx)) + check_bound (Cop(Cload Word,[field_address b dim_ofs])) idx idx) | arg1 :: argl -> let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in bind "idx" (untag_int arg1) (fun idx -> bind "bound" (Cop(Cload Word, [field_address b dim_ofs])) (fun bound -> - Csequence(Cop(Ccheckbound dbg, [bound; idx]), - add_int (mul_int rem bound) idx))) in + check_bound bound idx (add_int (mul_int rem bound) idx))) in let offset = match layout with Pbigarray_unknown_layout -> @@ -555,33 +568,33 @@ let bigarray_word_kind = function | Pbigarray_complex32 -> Single | Pbigarray_complex64 -> Double -let bigarray_get elt_kind layout b args dbg = +let bigarray_get unsafe elt_kind layout b args dbg = match elt_kind with Pbigarray_complex32 | Pbigarray_complex64 -> let kind = bigarray_word_kind elt_kind in let sz = bigarray_elt_size elt_kind / 2 in - bind "addr" (bigarray_indexing elt_kind layout b args dbg) (fun addr -> + bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr -> box_complex (Cop(Cload kind, [addr])) (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])]))) | _ -> Cop(Cload (bigarray_word_kind elt_kind), - [bigarray_indexing elt_kind layout b args dbg]) + [bigarray_indexing unsafe elt_kind layout b args dbg]) -let bigarray_set elt_kind layout b args newval dbg = +let bigarray_set unsafe elt_kind layout b args newval dbg = match elt_kind with Pbigarray_complex32 | Pbigarray_complex64 -> let kind = bigarray_word_kind elt_kind in let sz = bigarray_elt_size elt_kind / 2 in bind "newval" newval (fun newv -> - bind "addr" (bigarray_indexing elt_kind layout b args dbg) (fun addr -> + bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr -> Csequence( Cop(Cstore kind, [addr; complex_re newv]), Cop(Cstore kind, [Cop(Cadda, [addr; Cconst_int sz]); complex_im newv])))) | _ -> Cop(Cstore (bigarray_word_kind elt_kind), - [bigarray_indexing elt_kind layout b args dbg; newval]) + [bigarray_indexing unsafe elt_kind layout b args dbg; newval]) (* Simplification of some primitives into C calls *) @@ -616,9 +629,9 @@ let simplif_primitive_32bits = function | Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan") | Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal") | Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "caml_greaterequal") - | Pbigarrayref(n, Pbigarray_int64, layout) -> + | Pbigarrayref(unsafe, n, Pbigarray_int64, layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) - | Pbigarrayset(n, Pbigarray_int64, layout) -> + | Pbigarrayset(unsafe, n, Pbigarray_int64, layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) | p -> p @@ -626,13 +639,13 @@ let simplif_primitive p = match p with | Pduprecord _ -> Pccall (default_prim "caml_obj_dup") - | Pbigarrayref(n, Pbigarray_unknown, layout) -> + | Pbigarrayref(unsafe, n, Pbigarray_unknown, layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) - | Pbigarrayset(n, Pbigarray_unknown, layout) -> + | Pbigarrayset(unsafe, n, Pbigarray_unknown, layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) - | Pbigarrayref(n, kind, Pbigarray_unknown_layout) -> + | Pbigarrayref(unsafe, n, kind, Pbigarray_unknown_layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) - | Pbigarrayset(n, kind, Pbigarray_unknown_layout) -> + | Pbigarrayset(unsafe, n, kind, Pbigarray_unknown_layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) | p -> if size_int = 8 then p else simplif_primitive_32bits p @@ -729,11 +742,11 @@ let is_unboxed_number = function | Plslbint bi -> Boxed_integer bi | Plsrbint bi -> Boxed_integer bi | Pasrbint bi -> Boxed_integer bi - | Pbigarrayref(_, (Pbigarray_float32 | Pbigarray_float64), _) -> + | Pbigarrayref(_, _, (Pbigarray_float32 | Pbigarray_float64), _) -> Boxed_float - | Pbigarrayref(_, Pbigarray_int32, _) -> Boxed_integer Pint32 - | Pbigarrayref(_, Pbigarray_int64, _) -> Boxed_integer Pint64 - | Pbigarrayref(_, Pbigarray_native_int, _) -> Boxed_integer Pnativeint + | Pbigarrayref(_, _, Pbigarray_int32, _) -> Boxed_integer Pint32 + | Pbigarrayref(_, _, Pbigarray_int64, _) -> Boxed_integer Pint64 + | Pbigarrayref(_, _, Pbigarray_native_int, _) -> Boxed_integer Pnativeint | _ -> No_unboxing end | _ -> No_unboxing @@ -869,14 +882,9 @@ let rec transl = function box_float (Cop(Cextcall(prim.prim_native_name, typ_float, false, dbg), List.map transl_unbox_float args)) - else begin - let name = - if prim.prim_native_name <> "" - then prim.prim_native_name - else prim.prim_name in - Cop(Cextcall(name, typ_addr, prim.prim_alloc, dbg), + else + Cop(Cextcall(Primitive.native_name prim, typ_addr, prim.prim_alloc, dbg), List.map transl args) - end | (Pmakearray kind, []) -> transl_constant(Const_block(0, [])) | (Pmakearray kind, args) -> @@ -890,9 +898,9 @@ let rec transl = function make_float_alloc Obj.double_array_tag (List.map transl_unbox_float args) end - | (Pbigarrayref(num_dims, elt_kind, layout), arg1 :: argl) -> + | (Pbigarrayref(unsafe, num_dims, elt_kind, layout), arg1 :: argl) -> let elt = - bigarray_get elt_kind layout + bigarray_get unsafe elt_kind layout (transl arg1) (List.map transl argl) dbg in begin match elt_kind with Pbigarray_float32 | Pbigarray_float64 -> box_float elt @@ -903,9 +911,9 @@ let rec transl = function | Pbigarray_caml_int -> force_tag_int elt | _ -> tag_int elt end - | (Pbigarrayset(num_dims, elt_kind, layout), arg1 :: argl) -> + | (Pbigarrayset(unsafe, num_dims, elt_kind, layout), arg1 :: argl) -> let (argidx, argnewval) = split_last argl in - return_unit(bigarray_set elt_kind layout + return_unit(bigarray_set unsafe elt_kind layout (transl arg1) (List.map transl argidx) (match elt_kind with @@ -1927,6 +1935,36 @@ let curry_function arity = then intermediate_curry_functions arity 0 else [tuplify_function (-arity)] + +module IntSet = Set.Make( + struct + type t = int + let compare = compare + end) + +let default_apply = IntSet.add 2 (IntSet.add 3 IntSet.empty) + (* These apply funs are always present in the main program. + TODO: add more, and do the same for send and curry funs + (maybe up to 10-15?). *) + +let generic_functions shared units = + let (apply,send,curry) = + List.fold_left + (fun (apply,send,curry) ui -> + List.fold_right IntSet.add ui.Compilenv.ui_apply_fun apply, + List.fold_right IntSet.add ui.Compilenv.ui_send_fun send, + List.fold_right IntSet.add ui.Compilenv.ui_curry_fun curry) + (IntSet.empty,IntSet.empty,IntSet.empty) + units + in + let apply = + if shared then IntSet.diff apply default_apply + else IntSet.union apply default_apply + in + let accu = IntSet.fold (fun n accu -> apply_function n :: accu) apply [] in + let accu = IntSet.fold (fun n accu -> send_function n :: accu) send accu in + IntSet.fold (fun n accu -> curry_function n @ accu) curry accu + (* Generate the entry point *) let entry_point namelist = @@ -1961,10 +1999,16 @@ let global_table namelist = List.map mksym namelist @ [cint_zero]) -let globals_map namelist = - Cdata(Cglobal_symbol "caml_globals_map" :: - emit_constant "caml_globals_map" - (Const_base (Const_string (Marshal.to_string namelist []))) []) +let reference_symbols namelist = + let mksym name = Csymbol_address name in + Cdata(List.map mksym namelist) + +let global_data name v = + Cdata(Cglobal_symbol name :: + emit_constant name + (Const_base (Const_string (Marshal.to_string v []))) []) + +let globals_map v = global_data "caml_globals_map" v (* Generate the master table of frame descriptors *) @@ -2006,3 +2050,33 @@ let predef_exception name = Cint(block_header 0 1); Cdefine_symbol bucketname; Csymbol_address symname ]) + +(* Header for a plugin *) + +let mapflat f l = List.flatten (List.map f l) + +type dynunit = { + name: string; + crc: Digest.t; + imports_cmi: (string * Digest.t) list; + imports_cmx: (string * Digest.t) list; + defines: string list; +} + +type dynheader = { + magic: string; + units: dynunit list; +} + +let dyn_magic_number = "Caml2007D001" + +let plugin_header units = + let mk (ui,crc) = + { name = ui.Compilenv.ui_name; + crc = crc; + imports_cmi = ui.Compilenv.ui_imports_cmi; + imports_cmx = ui.Compilenv.ui_imports_cmx; + defines = ui.Compilenv.ui_defines + } in + global_data "caml_plugin_header" + { magic = dyn_magic_number; units = List.map mk units } diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli index fa4dba277a..50771c81bf 100644 --- a/asmcomp/cmmgen.mli +++ b/asmcomp/cmmgen.mli @@ -19,10 +19,14 @@ val compunit: int -> Clambda.ulambda -> Cmm.phrase list val apply_function: int -> Cmm.phrase val send_function: int -> Cmm.phrase val curry_function: int -> Cmm.phrase list +val generic_functions: bool -> Compilenv.unit_infos list -> Cmm.phrase list val entry_point: string list -> Cmm.phrase val global_table: string list -> Cmm.phrase -val globals_map: (string * string) list -> Cmm.phrase +val reference_symbols: string list -> Cmm.phrase +val globals_map: (string * Digest.t * Digest.t * string list) list -> + Cmm.phrase val frame_table: string list -> Cmm.phrase val data_segment_table: string list -> Cmm.phrase val code_segment_table: string list -> Cmm.phrase val predef_exception: string -> Cmm.phrase +val plugin_header: (Compilenv.unit_infos * Digest.t) list -> Cmm.phrase diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index 9f4288821c..e0f999c208 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -126,6 +126,17 @@ let read_unit_info filename = close_in ic; raise(Error(Corrupted_unit_info(filename))) +let read_library_info filename = + let ic = open_in_bin filename in + let buffer = String.create (String.length cmxa_magic_number) in + really_input ic buffer 0 (String.length cmxa_magic_number); + if buffer <> cmxa_magic_number then + raise(Error(Not_a_unit_info filename)); + let infos = (input_value ic : library_infos) in + close_in ic; + infos + + (* Read and cache info on global identifiers *) let cmx_not_found_crc = @@ -160,10 +171,18 @@ let cache_unit_info ui = (* Return the approximation of a global identifier *) +let toplevel_approx = Hashtbl.create 16 + +let record_global_approx_toplevel id = + Hashtbl.add toplevel_approx current_unit.ui_name current_unit.ui_approx + let global_approx id = - match get_global_info id with - | None -> Value_unknown - | Some ui -> ui.ui_approx + if Ident.is_predef_exn id then Value_unknown + else try Hashtbl.find toplevel_approx (Ident.name id) + with Not_found -> + match get_global_info id with + | None -> Value_unknown + | Some ui -> ui.ui_approx (* Return the symbol used to refer to a global identifier *) diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index 3b547872a1..762123b012 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -70,6 +70,9 @@ val global_approx: Ident.t -> Clambda.value_approximation (* Return the approximation for the given global identifier *) val set_global_approx: Clambda.value_approximation -> unit (* Record the approximation of the unit being compiled *) +val record_global_approx_toplevel: unit -> unit + (* Record the current approximation for the current toplevel phrase *) + val need_curry_fun: int -> unit val need_apply_fun: int -> unit @@ -77,6 +80,7 @@ val need_send_fun: int -> unit (* Record the need of a currying (resp. application, message sending) function with the given arity *) + val read_unit_info: string -> unit_infos * Digest.t (* Read infos and CRC from a [.cmx] file. *) val write_unit_info: unit_infos -> string -> unit @@ -92,6 +96,8 @@ val cmx_not_found_crc: Digest.t (* Special digest used in the [ui_imports_cmx] list to signal that no [.cmx] file was found and used for the imported unit *) +val read_library_info: string -> library_infos + type error = Not_a_unit_info of string | Corrupted_unit_info of string @@ -100,3 +106,5 @@ type error = exception Error of error val report_error: Format.formatter -> error -> unit + + diff --git a/asmcomp/hppa/proc.ml b/asmcomp/hppa/proc.ml index e525ae9079..296baa17b9 100644 --- a/asmcomp/hppa/proc.ml +++ b/asmcomp/hppa/proc.ml @@ -217,7 +217,8 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Ccomp.command ("as -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; diff --git a/asmcomp/hppa/reload.ml b/asmcomp/hppa/reload.ml index 57a242d707..54208fcc33 100644 --- a/asmcomp/hppa/reload.ml +++ b/asmcomp/hppa/reload.ml @@ -14,5 +14,25 @@ (* Reloading for the HPPA *) + +open Cmm +open Arch +open Reg +open Mach +open Proc + +class reload = object (self) + +inherit Reloadgen.reload_generic as super + +method reload_operation op arg res = + match op with + Iintop(Idiv | Imod) + | Iintop_imm((Idiv | Imod), _) -> (arg, res) + | _ -> super#reload_operation op arg res +end + + + let fundecl f = - (new Reloadgen.reload_generic)#fundecl f + (new reload)#fundecl f diff --git a/asmcomp/hppa/selection.ml b/asmcomp/hppa/selection.ml index 24db6cd900..6a0e9fe409 100644 --- a/asmcomp/hppa/selection.ml +++ b/asmcomp/hppa/selection.ml @@ -92,17 +92,17 @@ method select_operation op args = (* Deal with register constraints *) -method insert_op op rs rd = +method insert_op_debug op dbg rs rd = match op with Iintop(Idiv | Imod) -> (* handled via calls to millicode *) let rs' = [|phys_reg 20; phys_reg 19|] (* %r26, %r25 *) and rd' = [|phys_reg 22|] (* %r29 *) in self#insert_moves rs rs'; - self#insert (Iop op) rs' rd'; + self#insert_debug (Iop op) dbg rs' rd'; self#insert_moves rd' rd; rd | _ -> - super#insert_op op rs rd + super#insert_op_debug op dbg rs rd end diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index b50ecff27f..aaaba421a4 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -35,7 +35,7 @@ let stack_offset = ref 0 (* Layout of the stack frame *) let frame_size () = (* includes return address *) - let sz = + let sz = !stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 4 in Misc.align sz stack_alignment @@ -116,12 +116,12 @@ let emit_align = (fun n -> ` .align {emit_int n}\n`) | _ -> (fun n -> ` .align {emit_int(Misc.log2 n)}\n`) - + let emit_Llabel fallthrough lbl = if not fallthrough && !fastcode_flag then emit_align 16 ; emit_label lbl - + (* Output a pseudo-register *) let emit_reg = function @@ -239,7 +239,7 @@ let emit_call_bound_error bd = let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; if !bound_error_call > 0 then - `{emit_label !bound_error_call}: jmp {emit_symbol "caml_ml_array_bound_error"}\n` + `{emit_label !bound_error_call}: call {emit_symbol "caml_ml_array_bound_error"}\n` (* Names for instructions *) @@ -299,7 +299,7 @@ let name_for_cond_branch = function | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" - + (* Output an = 0 or <> 0 test. *) let output_test_zero arg = @@ -737,7 +737,7 @@ let emit_instr fallthrough i = ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm((Isigned Ceq | Isigned Cne | + | Iinttest_imm((Isigned Ceq | Isigned Cne | Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> output_test_zero i.arg.(0); let b = name_for_cond_branch cmp in @@ -986,4 +986,7 @@ let end_assembly() = if use_ascii_dir then emit_string_directive " .ascii " s else emit_bytes_directive " .byte " s) }; - if macosx then emit_external_symbols () + if macosx then emit_external_symbols (); + if Config.system = "linux_elf" then + (* Mark stack as non-executable, PR#4564 *) + `\n .section .note.GNU-stack,\"\",%progbits\n` diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index bba42fe88f..e4ac9d408d 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -206,7 +206,7 @@ let emit_call_bound_error bd = let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; if !bound_error_call > 0 then - `{emit_label !bound_error_call}: jmp _caml_ml_array_bound_error\n` + `{emit_label !bound_error_call}: call _caml_ml_array_bound_error\n` (* Names for instructions *) diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index 4076b4df27..d2e3cdda96 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -181,7 +181,8 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Ccomp.command ("as -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; diff --git a/asmcomp/i386/proc_nt.ml b/asmcomp/i386/proc_nt.ml index 554b6c55b6..03b5a2f6bc 100644 --- a/asmcomp/i386/proc_nt.ml +++ b/asmcomp/i386/proc_nt.ml @@ -88,12 +88,23 @@ let word_addressed = false (* Calling conventions *) +(* To supplement the processor's meagre supply of registers, we also + use some global memory locations to pass arguments beyond the 6th. + These globals are denoted by Incoming and Outgoing stack locations + with negative offsets, starting at -64. + Unlike arguments passed on stack, arguments passed in globals + do not prevent tail-call elimination. The caller stores arguments + in these globals immediately before the call, and the first thing the + callee does is copy them to registers or stack locations. + Neither GC nor thread context switches can occur between these two + times. *) + let calling_conventions first_int last_int first_float last_float make_stack arg = let loc = Array.create (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in - let ofs = ref 0 in + let ofs = ref (-64) in for i = 0 to Array.length arg - 1 do match arg.(i).typ with Int | Addr as ty -> @@ -113,7 +124,7 @@ let calling_conventions first_int last_int first_float last_float make_stack ofs := !ofs + size_float end done; - (loc, !ofs) + (loc, max 0 !ofs) let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs @@ -170,9 +181,6 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Ccomp.command ("ml /nologo /coff /Cp /c /Fo" ^ - Filename.quote outfile ^ " " ^ Filename.quote infile ^ ">NUL") - (* /Cp preserve case of all used identifiers - /c assemble only - /Fo output file name *) - + Ccomp.command (Config.asm ^ + Filename.quote outfile ^ " " ^ Filename.quote infile ^ + (if !Clflags.verbose then "" else ">NUL")) diff --git a/asmcomp/ia64/proc.ml b/asmcomp/ia64/proc.ml index 7f99ebb8a6..a82536586a 100644 --- a/asmcomp/ia64/proc.ml +++ b/asmcomp/ia64/proc.ml @@ -210,7 +210,8 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Ccomp.command ("as -xexplicit -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; diff --git a/asmcomp/mips/proc.ml b/asmcomp/mips/proc.ml index a848e33523..6ac37a4c01 100644 --- a/asmcomp/mips/proc.ml +++ b/asmcomp/mips/proc.ml @@ -202,10 +202,9 @@ let contains_calls = ref false (* Calling the assembler *) -let asm_command = "as -n32 -O2 -nocpp -g0 -o " - let assemble_file infile outfile = - Ccomp.command (asm_command ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index 48611bab9e..5d09342a88 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -234,16 +234,8 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - let infile = Filename.quote infile - and outfile = Filename.quote outfile in - match Config.system with - | "elf" -> - Ccomp.command ("as -u -m ppc -o " ^ outfile ^ " " ^ infile) - | "rhapsody" -> - Ccomp.command ("as -arch " ^ Config.model ^ " -o " ^ outfile ^ " " ^ infile) - | "bsd" -> - Ccomp.command ("as -o " ^ outfile ^ " " ^ infile) - | _ -> assert false + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; diff --git a/asmcomp/sparc/proc.ml b/asmcomp/sparc/proc.ml index 6035772573..91f1c8e73d 100644 --- a/asmcomp/sparc/proc.ml +++ b/asmcomp/sparc/proc.ml @@ -206,9 +206,10 @@ let contains_calls = ref false (* Calling the assembler and the archiver *) let assemble_file infile outfile = - let asprefix = begin match !arch_version with - SPARC_V7 -> "as -o " - | SPARC_V8 -> "as -xarch=v8 -o " - | SPARC_V9 -> "as -xarch=v8plus -o " + let asflags = begin match !arch_version with + SPARC_V7 -> " -o " + | SPARC_V8 -> " -xarch=v8 -o " + | SPARC_V9 -> " -xarch=v8plus -o " end in - Ccomp.command (asprefix ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + Ccomp.command (Config.asm ^ asflags ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) diff --git a/asmrun/.depend b/asmrun/.depend index 3176dd5533..916da83ee9 100644 --- a/asmrun/.depend +++ b/asmrun/.depend @@ -117,8 +117,10 @@ freelist.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/misc.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/misc.h + ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h gc_ctrl.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ @@ -252,7 +254,7 @@ minor_gc.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ ../byterun/misc.h ../byterun/signals.h ../byterun/misc.h \ - ../byterun/mlvalues.h + ../byterun/mlvalues.h ../byterun/weak.h ../byterun/mlvalues.h misc.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ @@ -260,6 +262,17 @@ misc.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h +natdynlink.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h \ + ../byterun/callback.h ../byterun/mlvalues.h ../byterun/alloc.h \ + ../byterun/misc.h ../byterun/mlvalues.h natdynlink.h \ + ../byterun/osdeps.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h obj.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ @@ -322,9 +335,13 @@ startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/gc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ - ../byterun/misc.h ../byterun/osdeps.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/osdeps.h ../byterun/misc.h \ ../byterun/printexc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/sys.h ../byterun/misc.h + ../byterun/sys.h ../byterun/misc.h natdynlink.h str.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ @@ -485,8 +502,10 @@ freelist.d.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/misc.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/misc.h + ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h gc_ctrl.d.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ @@ -620,7 +639,7 @@ minor_gc.d.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ ../byterun/misc.h ../byterun/signals.h ../byterun/misc.h \ - ../byterun/mlvalues.h + ../byterun/mlvalues.h ../byterun/weak.h ../byterun/mlvalues.h misc.d.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ @@ -628,6 +647,17 @@ misc.d.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h +natdynlink.d.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h \ + ../byterun/callback.h ../byterun/mlvalues.h ../byterun/alloc.h \ + ../byterun/misc.h ../byterun/mlvalues.h natdynlink.h \ + ../byterun/osdeps.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h obj.d.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ @@ -690,9 +720,13 @@ startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/gc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ - ../byterun/misc.h ../byterun/osdeps.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/osdeps.h ../byterun/misc.h \ ../byterun/printexc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/sys.h ../byterun/misc.h + ../byterun/sys.h ../byterun/misc.h natdynlink.h str.d.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ @@ -853,8 +887,10 @@ freelist.p.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/misc.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/misc.h + ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h gc_ctrl.p.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ @@ -988,7 +1024,7 @@ minor_gc.p.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ ../byterun/misc.h ../byterun/signals.h ../byterun/misc.h \ - ../byterun/mlvalues.h + ../byterun/mlvalues.h ../byterun/weak.h ../byterun/mlvalues.h misc.p.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ @@ -996,6 +1032,17 @@ misc.p.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h +natdynlink.p.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h \ + ../byterun/callback.h ../byterun/mlvalues.h ../byterun/alloc.h \ + ../byterun/misc.h ../byterun/mlvalues.h natdynlink.h \ + ../byterun/osdeps.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h obj.p.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ @@ -1058,9 +1105,13 @@ startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/gc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ - ../byterun/misc.h ../byterun/osdeps.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/osdeps.h ../byterun/misc.h \ ../byterun/printexc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/sys.h ../byterun/misc.h + ../byterun/sys.h ../byterun/misc.h natdynlink.h str.p.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ diff --git a/asmrun/Makefile b/asmrun/Makefile index 78557f2f0c..633ce5254b 100644 --- a/asmrun/Makefile +++ b/asmrun/Makefile @@ -17,7 +17,7 @@ include ../config/Makefile CC=$(NATIVECC) FLAGS=-I../byterun -DCAML_NAME_SPACE -DNATIVE_CODE \ - -DTARGET_$(ARCH) -DSYS_$(SYSTEM) + -DTARGET_$(ARCH) -DSYS_$(SYSTEM) $(IFLEXDIR) CFLAGS=$(FLAGS) -O $(NATIVECCCOMPOPTS) DFLAGS=$(FLAGS) -g -DDEBUG $(NATIVECCCOMPOPTS) PFLAGS=$(FLAGS) -pg -O -DPROFILING $(NATIVECCPROFOPTS) @@ -26,7 +26,7 @@ COBJS=startup.o main.o fail.o roots.o globroots.o signals.o signals_asm.o \ misc.o freelist.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.o \ floats.o str.o array.o io.o extern.o intern.o hash.o sys.o parsing.o \ gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \ - compact.o finalise.o custom.o unix.o backtrace.o + compact.o finalise.o custom.o unix.o backtrace.o natdynlink.o ASMOBJS=$(ARCH).o @@ -155,11 +155,11 @@ clean:: .SUFFIXES: .S .d.o .p.o .S.o: - $(ASPP) $(ASPPFLAGS) -o $*.o $*.S || \ + $(ASPP) -DSYS_$(SYSTEM) -o $*.o $*.S || \ { echo "If your assembler produced syntax errors, it is probably unhappy with the"; echo "preprocessor. Check your assembler, or try producing $*.o by hand."; exit 2; } .S.p.o: - $(ASPP) $(ASPPFLAGS) $(ASPPPROFFLAGS) -o $*.p.o $*.S + $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.S .c.d.o: @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi @@ -174,10 +174,10 @@ clean:: @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi .s.o: - $(ASPP) $(ASPPFLAGS) -o $*.o $*.s + $(ASPP) -DSYS_$(SYSTEM) -o $*.o $*.s .s.p.o: - $(ASPP) $(ASPPFLAGS) $(ASPPPROFFLAGS) -o $*.p.o $*.s + $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.s clean:: rm -f *.o *.a *~ diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt index aa42f4b02b..ca24bc71ad 100644 --- a/asmrun/Makefile.nt +++ b/asmrun/Makefile.nt @@ -24,7 +24,7 @@ COBJS=startup.$(O) main.$(O) fail.$(O) roots.$(O) signals.$(O) signals_asm.$(O) intern.$(O) hash.$(O) sys.$(O) parsing.$(O) gc_ctrl.$(O) terminfo.$(O) \ md5.$(O) obj.$(O) lexing.$(O) win32.$(O) printexc.$(O) callback.$(O) \ weak.$(O) compact.$(O) finalise.$(O) custom.$(O) globroots.$(O) \ - backtrace.$(O) + backtrace.$(O) natdynlink.$(O) LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \ @@ -46,10 +46,10 @@ libasmrun.$(A): $(OBJS) $(call MKLIB,libasmrun.$(A), $(OBJS)) i386nt.obj: i386nt.asm - ml /nologo /coff /Cp /c /Foi386nt.obj i386nt.asm + $(ASM)i386nt.obj i386nt.asm amd64nt.obj: amd64nt.asm - ml64 /nologo /Cp /c /Foamd64nt.obj amd64nt.asm + $(ASM)amd64nt.obj amd64nt.asm i386.o: i386.S $(CC) -c -DSYS_$(SYSTEM) i386.S @@ -62,7 +62,7 @@ $(LINKEDFILES): %.c: ../byterun/%.c # Need special compilation rule so as not to do -I../byterun win32.$(O): ../byterun/win32.c - $(CC) -c $(NATIVECCCOMPOPTS) -DNATIVE_CODE ../byterun/win32.c + $(CC) -c $(NATIVECCCOMPOPTS) -DNATIVE_CODE $(IFLEXDIR) ../byterun/win32.c .SUFFIXES: .c .$(O) diff --git a/asmrun/amd64.S b/asmrun/amd64.S index d61d521efd..4cf4f822d7 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -366,3 +366,8 @@ caml_negf_mask: .align 16 caml_absf_mask: .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF + +#if defined(SYS_linux) + /* Mark stack as non-executable, PR#4564 */ + .section .note.GNU-stack,"",%progbits +#endif diff --git a/asmrun/arm.S b/asmrun/arm.S index c32b4b6674..98fdfcfe32 100644 --- a/asmrun/arm.S +++ b/asmrun/arm.S @@ -91,11 +91,13 @@ caml_allocN: /* Record return address and desired size */ ldr alloc_limit, .Lcaml_last_return_address str lr, [alloc_limit, #0] - str r10, .Lcaml_requested_size + ldr alloc_limit, .LLcaml_requested_size + str r10, [alloc_limit, #0] /* Invoke GC */ bl .Linvoke_gc /* Try again */ - ldr r10, .Lcaml_requested_size + ldr r10, .LLcaml_requested_size + ldr r10, [r10, #0] b caml_allocN /* Shared code to invoke the GC */ @@ -323,9 +325,12 @@ caml_ml_array_bound_error: .LLtrap_handler: .word .Ltrap_handler .Lcaml_apply2: .word caml_apply2 .Lcaml_apply3: .word caml_apply3 -.Lcaml_requested_size: .word 0 +.LLcaml_requested_size: .word .Lcaml_requested_size .Lcaml_array_bound_error: .word caml_array_bound_error +.data +.Lcaml_requested_size: .word 0 + /* GC roots for callback */ .data diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c index 50af17bb73..1b39bfb94f 100644 --- a/asmrun/backtrace.c +++ b/asmrun/backtrace.c @@ -16,6 +16,7 @@ /* Stack backtrace for uncaught exceptions */ #include <stdio.h> +#include "alloc.h" #include "backtrace.h" #include "memory.h" #include "misc.h" @@ -28,12 +29,29 @@ code_t * caml_backtrace_buffer = NULL; value caml_backtrace_last_exn = Val_unit; #define BACKTRACE_BUFFER_SIZE 1024 -/* Initialize the backtrace machinery */ +/* Start or stop the backtrace machinery */ -void caml_init_backtrace(void) +CAMLprim value caml_record_backtrace(value vflag) { - caml_backtrace_active = 1; - caml_register_global_root(&caml_backtrace_last_exn); + int flag = Int_val(vflag); + + if (flag != caml_backtrace_active) { + caml_backtrace_active = flag; + caml_backtrace_pos = 0; + if (flag) { + caml_register_global_root(&caml_backtrace_last_exn); + } else { + caml_remove_global_root(&caml_backtrace_last_exn); + } + } + return Val_unit; +} + +/* Return the status of the backtrace machinery */ + +CAMLprim value caml_backtrace_status(value vunit) +{ + return Val_bool(caml_backtrace_active); } /* Store the return addresses contained in the given stack fragment @@ -59,8 +77,8 @@ void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) h = Hash_retaddr(pc); while(1) { d = caml_frame_descriptors[h]; + if (d == 0) return; /* can happen if some code not compiled with -g */ if (d->retaddr == pc) break; - if (d->retaddr == 0) return; /* should not happen */ h = (h+1) & caml_frame_descriptors_mask; } /* Skip to next frame */ @@ -95,18 +113,31 @@ void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) } } -/* Print a backtrace */ +/* Extract location information for the given frame descriptor */ -static void print_location(int index, frame_descr * d) +struct loc_info { + int loc_valid; + int loc_is_raise; + char * loc_filename; + int loc_lnum; + int loc_startchr; + int loc_endchr; +}; + +static void extract_location_info(frame_descr * d, + /*out*/ struct loc_info * li) { uintnat infoptr; - uint32 info1, info2, k, n, l, a, b; - char * kind; + uint32 info1, info2; /* If no debugging information available, print nothing. When everything is compiled with -g, this corresponds to compiler-inserted re-raise operations. */ - if ((d->frame_size & 1) == 0) return; + if ((d->frame_size & 1) == 0) { + li->loc_valid = 0; + li->loc_is_raise = 1; + return; + } /* Recover debugging info */ infoptr = ((uintnat) d + sizeof(char *) + sizeof(short) + sizeof(short) + @@ -123,27 +154,72 @@ static void print_location(int index, frame_descr * d) l (20 bits): line number a ( 8 bits): beginning of character range b (10 bits): end of character range */ - k = info1 & 3; - n = info1 & 0x3FFFFFC; - l = info2 >> 12; - a = (info2 >> 4) & 0xFF; - b = ((info2 & 0xF) << 6) | (info1 >> 26); + li->loc_valid = 1; + li->loc_is_raise = (info1 & 3) != 0; + li->loc_filename = (char *) infoptr + (info1 & 0x3FFFFFC); + li->loc_lnum = info2 >> 12; + li->loc_startchr = (info2 >> 4) & 0xFF; + li->loc_endchr = ((info2 & 0xF) << 6) | (info1 >> 26); +} + +static void print_location(struct loc_info * li, int index) +{ + char * info; + + /* Ignore compiler-inserted raise */ + if (!li->loc_valid) return; if (index == 0) - kind = "Raised at"; - else if (k == 1) - kind = "Re-raised at"; + info = "Raised at"; + else if (li->loc_is_raise) + info = "Re-raised at"; else - kind = "Called from"; - - fprintf(stderr, "%s file \"%s\", line %d, characters %d-%d\n", - kind, ((char *) infoptr) + n, l, a, b); + info = "Called from"; + fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n", + info, li->loc_filename, li->loc_lnum, + li->loc_startchr, li->loc_endchr); } +/* Print a backtrace */ + void caml_print_exception_backtrace(void) { int i; + struct loc_info li; + + for (i = 0; i < caml_backtrace_pos; i++) { + extract_location_info((frame_descr *) (caml_backtrace_buffer[i]), &li); + print_location(&li, i); + } +} - for (i = 0; i < caml_backtrace_pos; i++) - print_location(i, (frame_descr *) caml_backtrace_buffer[i]); +/* Convert the backtrace to a data structure usable from Caml */ + +CAMLprim value caml_get_exception_backtrace(value unit) +{ + CAMLparam0(); + CAMLlocal4(res, arr, p, fname); + int i; + struct loc_info li; + + arr = caml_alloc(caml_backtrace_pos, 0); + for (i = 0; i < caml_backtrace_pos; i++) { + extract_location_info((frame_descr *) (caml_backtrace_buffer[i]), &li); + if (li.loc_valid) { + fname = caml_copy_string(li.loc_filename); + p = caml_alloc_small(5, 0); + Field(p, 0) = Val_bool(li.loc_is_raise); + Field(p, 1) = fname; + Field(p, 2) = Val_int(li.loc_lnum); + Field(p, 3) = Val_int(li.loc_startchr); + Field(p, 4) = Val_int(li.loc_endchr); + } else { + p = caml_alloc_small(1, 1); + Field(p, 0) = Val_bool(li.loc_is_raise); + } + caml_modify(&Field(arr, i), p); + } + res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ + CAMLreturn(res); } + diff --git a/asmrun/fail.c b/asmrun/fail.c index d89bcc6582..a1ec0fb070 100644 --- a/asmrun/fail.c +++ b/asmrun/fail.c @@ -94,6 +94,21 @@ void caml_raise_with_arg(value tag, value arg) CAMLnoreturn; } +void caml_raise_with_args(value tag, int nargs, value args[]) +{ + CAMLparam1 (tag); + CAMLxparamN (args, nargs); + value bucket; + int i; + + Assert(1 + nargs <= Max_young_wosize); + bucket = caml_alloc_small (1 + nargs, 0); + Field(bucket, 0) = tag; + for (i = 0; i < nargs; i++) Field(bucket, 1 + i) = args[i]; + caml_raise(bucket); + CAMLnoreturn; +} + void caml_raise_with_string(value tag, char const *msg) { caml_raise_with_arg(tag, caml_copy_string(msg)); @@ -170,14 +185,23 @@ static struct { char data[BOUND_MSG_LEN + sizeof(value)]; } array_bound_error_msg = { 0, BOUND_MSG }; +static int array_bound_error_bucket_inited = 0; + void caml_array_bound_error(void) { - mlsize_t wosize = (BOUND_MSG_LEN + sizeof(value)) / sizeof(value); - mlsize_t offset_index = Bsize_wsize(wosize) - 1; - array_bound_error_msg.hdr = Make_header(wosize, String_tag, Caml_white); - array_bound_error_msg.data[offset_index] = offset_index - BOUND_MSG_LEN; - array_bound_error_bucket.hdr = Make_header(2, 0, Caml_white); - array_bound_error_bucket.exn = (value) caml_exn_Invalid_argument; - array_bound_error_bucket.arg = (value) array_bound_error_msg.data; + if (! array_bound_error_bucket_inited) { + mlsize_t wosize = (BOUND_MSG_LEN + sizeof(value)) / sizeof(value); + mlsize_t offset_index = Bsize_wsize(wosize) - 1; + array_bound_error_msg.hdr = Make_header(wosize, String_tag, Caml_white); + array_bound_error_msg.data[offset_index] = offset_index - BOUND_MSG_LEN; + array_bound_error_bucket.hdr = Make_header(2, 0, Caml_white); + array_bound_error_bucket.exn = (value) caml_exn_Invalid_argument; + array_bound_error_bucket.arg = (value) array_bound_error_msg.data; + array_bound_error_bucket_inited = 1; + caml_page_table_add(In_static_data, + &array_bound_error_msg, + &array_bound_error_msg + 1); + array_bound_error_bucket_inited = 1; + } caml_raise((value) &array_bound_error_bucket.exn); } diff --git a/asmrun/i386.S b/asmrun/i386.S index 9d45f6e974..73ac46741d 100644 --- a/asmrun/i386.S +++ b/asmrun/i386.S @@ -384,9 +384,17 @@ G(caml_ml_array_bound_error): ffree %st(5) ffree %st(6) ffree %st(7) - /* Branch to [caml_array_bound_error] */ - movl $ G(caml_array_bound_error), %eax - jmp G(caml_c_call) + /* Record lowest stack address and return address */ + movl (%esp), %edx + movl %edx, G(caml_last_return_address) + leal 4(%esp), %edx + movl %edx, G(caml_bottom_of_stack) + /* For MacOS X: re-align the stack */ +#ifdef SYS_macosx + andl $-16, %esp +#endif + /* Branch to [caml_array_bound_error] (never returns) */ + call G(caml_array_bound_error) .data .globl G(caml_system__frametable) @@ -416,3 +424,8 @@ Lmcount$stub: hlt ; hlt ; hlt ; hlt ; hlt .subsections_via_symbols #endif + +#if defined(SYS_linux_elf) + /* Mark stack as non-executable, PR#4564 */ + .section .note.GNU-stack,"",%progbits +#endif diff --git a/asmrun/roots.c b/asmrun/roots.c index f5ff1591e8..dad820f3b6 100644 --- a/asmrun/roots.c +++ b/asmrun/roots.c @@ -24,6 +24,8 @@ #include "mlvalues.h" #include "stack.h" #include "roots.h" +#include <string.h> +#include <stdio.h> /* Roots registered from C functions */ @@ -36,6 +38,37 @@ void (*caml_scan_roots_hook) (scanning_action) = NULL; frame_descr ** caml_frame_descriptors = NULL; int caml_frame_descriptors_mask; +/* Linked-list */ + +typedef struct link { + void *data; + struct link *next; +} link; + +static link *cons(void *data, link *tl) { + link *lnk = caml_stat_alloc(sizeof(link)); + lnk->data = data; + lnk->next = tl; + return lnk; +} + +#define iter_list(list,lnk) \ + for (lnk = list; lnk != NULL; lnk = lnk->next) + +/* Linked-list of frametables */ + +static link *frametables = NULL; + +void caml_register_frametable(intnat *table) { + frametables = cons(table,frametables); + + if (NULL != caml_frame_descriptors) { + caml_stat_free(caml_frame_descriptors); + caml_frame_descriptors = NULL; + /* force caml_init_frame_descriptors to be called */ + } +} + void caml_init_frame_descriptors(void) { intnat num_descr, tblsize, i, j, len; @@ -43,11 +76,21 @@ void caml_init_frame_descriptors(void) frame_descr * d; uintnat nextd; uintnat h; + link *lnk; + + static int inited = 0; + + if (!inited) { + for (i = 0; caml_frametable[i] != 0; i++) + caml_register_frametable(caml_frametable[i]); + inited = 1; + } /* Count the frame descriptors */ num_descr = 0; - for (i = 0; caml_frametable[i] != 0; i++) - num_descr += *(caml_frametable[i]); + iter_list(frametables,lnk) { + num_descr += *((intnat*) lnk->data); + } /* The size of the hashtable is a power of 2 greater or equal to 2 times the number of descriptors */ @@ -61,8 +104,8 @@ void caml_init_frame_descriptors(void) caml_frame_descriptors_mask = tblsize - 1; /* Fill the hash table */ - for (i = 0; caml_frametable[i] != 0; i++) { - tbl = caml_frametable[i]; + iter_list(frametables,lnk) { + tbl = (intnat*) lnk->data; len = *tbl; d = (frame_descr *)(tbl + 1); for (j = 0; j < len; j++) { @@ -89,6 +132,11 @@ uintnat caml_last_return_address = 1; /* not in Caml code initially */ value * caml_gc_regs; intnat caml_globals_inited = 0; static intnat caml_globals_scanned = 0; +static link * caml_dyn_globals = NULL; + +void caml_register_dyn_global(void *v) { + caml_dyn_globals = cons((void*) v,caml_dyn_globals); +} /* Call [caml_oldify_one] on (at least) all the roots that point to the minor heap. */ @@ -100,11 +148,15 @@ void caml_oldify_local_roots (void) frame_descr * d; uintnat h; int i, j, n, ofs; +#ifdef Stack_grows_upwards + short * p; /* PR#4339: stack offsets are negative in this case */ +#else unsigned short * p; +#endif value glob; value * root; - struct global_root * gr; struct caml__roots_block *lr; + link *lnk; /* The global roots */ for (i = caml_globals_scanned; @@ -117,6 +169,14 @@ void caml_oldify_local_roots (void) } caml_globals_scanned = caml_globals_inited; + /* Dynamic global roots */ + iter_list(caml_dyn_globals, lnk) { + glob = (value) lnk->data; + for (j = 0; j < Wosize_val(glob); j++){ + Oldify (&Field (glob, j)); + } + } + /* The stack and local roots */ if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); sp = caml_bottom_of_stack; @@ -177,13 +237,11 @@ void caml_oldify_local_roots (void) } } /* Global C roots */ - for (gr = caml_global_roots.forward[0]; gr != NULL; gr = gr->forward[0]) { - Oldify (gr->root); - } + caml_scan_global_young_roots(&caml_oldify_one); /* Finalised values */ caml_final_do_young_roots (&caml_oldify_one); /* Hook */ - if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(caml_oldify_one); + if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one); } /* Call [darken] on all roots */ @@ -197,7 +255,7 @@ void caml_do_roots (scanning_action f) { int i, j; value glob; - struct global_root * gr; + link *lnk; /* The global roots */ for (i = 0; caml_globals[i] != 0; i++) { @@ -205,14 +263,21 @@ void caml_do_roots (scanning_action f) for (j = 0; j < Wosize_val(glob); j++) f (Field (glob, j), &Field (glob, j)); } + + /* Dynamic global roots */ + iter_list(caml_dyn_globals, lnk) { + glob = (value) lnk->data; + for (j = 0; j < Wosize_val(glob); j++){ + f (Field (glob, j), &Field (glob, j)); + } + } + /* The stack and local roots */ if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); caml_do_local_roots(f, caml_bottom_of_stack, caml_last_return_address, caml_gc_regs, caml_local_roots); /* Global C roots */ - for (gr = caml_global_roots.forward[0]; gr != NULL; gr = gr->forward[0]) { - f(*(gr->root), gr->root); - } + caml_scan_global_roots(f); /* Finalised values */ caml_final_do_strong_roots (f); /* Hook */ @@ -229,7 +294,11 @@ void caml_do_local_roots(scanning_action f, char * bottom_of_stack, frame_descr * d; uintnat h; int i, j, n, ofs; +#ifdef Stack_grows_upwards + short * p; /* PR#4339: stack offsets are negative in this case */ +#else unsigned short * p; +#endif value * root; struct caml__roots_block *lr; diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c index f333540513..f8f542ada9 100644 --- a/asmrun/signals_asm.c +++ b/asmrun/signals_asm.c @@ -47,9 +47,10 @@ extern void caml_win32_overflow_detection(); extern char * caml_code_area_start, * caml_code_area_end; -#define In_code_area(pc) \ - ((char *)(pc) >= caml_code_area_start && \ - (char *)(pc) <= caml_code_area_end) +#define Is_in_code_area(pc) \ + ( ((char *)(pc) >= caml_code_area_start && \ + (char *)(pc) <= caml_code_area_end) \ + || (Classify_addr(pc) & In_code_area) ) /* This routine is the common entry point for garbage collection and signal handling. It can trigger a callback to Caml code. @@ -84,7 +85,7 @@ DECLARE_SIGNAL_HANDLER(handle_signal) Use the signal context to modify that register too, but only if we are inside Caml code (not inside C code). */ #if defined(CONTEXT_PC) && defined(CONTEXT_YOUNG_LIMIT) - if (In_code_area(CONTEXT_PC)) + if (Is_in_code_area(CONTEXT_PC)) CONTEXT_YOUNG_LIMIT = (context_reg) caml_young_limit; #endif } @@ -190,7 +191,7 @@ DECLARE_SIGNAL_HANDLER(segv_handler) && fault_addr < system_stack_top && fault_addr >= system_stack_top - limit.rlim_cur - 0x2000 #ifdef CONTEXT_PC - && In_code_area(CONTEXT_PC) + && Is_in_code_area(CONTEXT_PC) #endif ) { /* Turn this into a Stack_overflow exception */ @@ -238,7 +239,7 @@ void caml_init_signals(void) /* Stack overflow handling */ #ifdef HAS_STACK_OVERFLOW_DETECTION { - struct sigaltstack stk; + stack_t stk; struct sigaction act; stk.ss_sp = sig_alt_stack; stk.ss_size = SIGSTKSZ; diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index f34863b39b..0ae285f327 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -87,9 +87,16 @@ sigact.sa_flags = SA_SIGINFO #include <sys/ucontext.h> + #include <AvailabilityMacros.h> - #define CONTEXT_STATE (((struct ucontext *)context)->uc_mcontext->ss) - #define CONTEXT_PC (CONTEXT_STATE.eip) +#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 + #define CONTEXT_REG(r) __##r + #endif + + #define CONTEXT_STATE (((ucontext_t *)context)->uc_mcontext->CONTEXT_REG(ss)) + #define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(eip)) #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) /****************** MIPS, all OS */ @@ -113,106 +120,43 @@ #elif defined(TARGET_power) && defined(SYS_rhapsody) -#ifdef __ppc64__ - #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, siginfo_t * info, void * context) - #define SET_SIGACT(sigact,name) \ - sigact.sa_sigaction = (name); \ - sigact.sa_flags = SA_SIGINFO | SA_64REGSET - - typedef unsigned long long context_reg; - #include <sys/ucontext.h> + #include <AvailabilityMacros.h> - #define CONTEXT_STATE (((struct ucontext64 *)context)->uc_mcontext64->ss) - - #define CONTEXT_PC (CONTEXT_STATE.srr0) - #define CONTEXT_EXCEPTION_POINTER (CONTEXT_STATE.r29) - #define CONTEXT_YOUNG_LIMIT (CONTEXT_STATE.r30) - #define CONTEXT_YOUNG_PTR (CONTEXT_STATE.r31) - #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) - #define CONTEXT_SP (CONTEXT_STATE.r1) - -#else + #ifdef __LP64__ + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (name); \ + sigact.sa_flags = SA_SIGINFO | SA_64REGSET - #include <sys/utsname.h> + typedef unsigned long long context_reg; - #define DECLARE_SIGNAL_HANDLER(name) \ - static void name(int sig, siginfo_t * info, void * context) + #define CONTEXT_MCONTEXT (((ucontext64_t *)context)->uc_mcontext64) + #else + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (name); \ + sigact.sa_flags = SA_SIGINFO - #define SET_SIGACT(sigact,name) \ - sigact.sa_handler = (void (*)(int)) (name); \ - sigact.sa_flags = SA_SIGINFO + typedef unsigned long context_reg; - typedef unsigned long context_reg; + #define CONTEXT_MCONTEXT (((ucontext_t *)context)->uc_mcontext) + #endif - #define CONTEXT_PC (*context_gpr_p(context, -2)) - #define CONTEXT_EXCEPTION_POINTER (*context_gpr_p(context, 29)) - #define CONTEXT_YOUNG_LIMIT (*context_gpr_p(context, 30)) - #define CONTEXT_YOUNG_PTR (*context_gpr_p(context, 31)) - #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) - #define CONTEXT_SP (*context_gpr_p(context, 1)) - - static int ctx_version = 0; - static void init_ctx (void) - { - struct utsname name; - if (uname (&name) == 0){ - if (name.release[1] == '.' && name.release[0] <= '5'){ - ctx_version = 1; - }else{ - ctx_version = 2; - } - }else{ - caml_fatal_error ("cannot determine SIGCONTEXT format"); - } - } - - #ifdef DARWIN_VERSION_6 - #include <sys/ucontext.h> - static unsigned long *context_gpr_p (void *ctx, int regno) - { - unsigned long *regs; - if (ctx_version == 0) init_ctx (); - if (ctx_version == 1){ - /* old-style context (10.0 and 10.1) */ - regs = (unsigned long *)(((struct sigcontext *)ctx)->sc_regs); - }else{ - Assert (ctx_version == 2); - /* new-style context (10.2) */ - regs = (unsigned long *)&(((struct ucontext *)ctx)->uc_mcontext->ss); - } - return &(regs[2 + regno]); - } +#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 - #define SA_SIGINFO 0x0040 - struct ucontext { - int uc_onstack; - sigset_t uc_sigmask; - struct sigaltstack uc_stack; - struct ucontext *uc_link; - size_t uc_mcsize; - unsigned long *uc_mcontext; - }; - static unsigned long *context_gpr_p (void *ctx, int regno) - { - unsigned long *regs; - if (ctx_version == 0) init_ctx (); - if (ctx_version == 1){ - /* old-style context (10.0 and 10.1) */ - regs = (unsigned long *)(((struct sigcontext *)ctx)->sc_regs); - }else{ - Assert (ctx_version == 2); - /* new-style context (10.2) */ - regs = (unsigned long *)((struct ucontext *)ctx)->uc_mcontext + 8; - } - return &(regs[2 + regno]); - } + #define CONTEXT_REG(r) __##r #endif -#endif + #define CONTEXT_STATE (CONTEXT_MCONTEXT->CONTEXT_REG(ss)) + #define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(srr0)) + #define CONTEXT_EXCEPTION_POINTER (CONTEXT_STATE.CONTEXT_REG(r29)) + #define CONTEXT_YOUNG_LIMIT (CONTEXT_STATE.CONTEXT_REG(r30)) + #define CONTEXT_YOUNG_PTR (CONTEXT_STATE.CONTEXT_REG(r31)) + #define CONTEXT_SP (CONTEXT_STATE.CONTEXT_REG(r1)) + #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) /****************** PowerPC, ELF (Linux) */ diff --git a/asmrun/stack.h b/asmrun/stack.h index 913ec4f553..578e9cf87b 100644 --- a/asmrun/stack.h +++ b/asmrun/stack.h @@ -114,6 +114,8 @@ extern int caml_frame_descriptors_mask; (((uintnat)(addr) >> 3) & caml_frame_descriptors_mask) extern void caml_init_frame_descriptors(void); +extern void caml_register_frametable(intnat *); +extern void caml_register_dyn_global(void *); /* Declaration of variables used in the asm code */ extern char * caml_bottom_of_stack; @@ -124,5 +126,4 @@ extern value caml_globals[]; extern intnat caml_globals_inited; extern intnat * caml_frametable[]; - #endif /* CAML_STACK_H */ diff --git a/asmrun/startup.c b/asmrun/startup.c index 765d2a8bfc..9f76992b3a 100644 --- a/asmrun/startup.c +++ b/asmrun/startup.c @@ -23,44 +23,52 @@ #include "fail.h" #include "gc.h" #include "gc_ctrl.h" +#include "memory.h" #include "misc.h" #include "mlvalues.h" #include "osdeps.h" #include "printexc.h" #include "sys.h" +#include "natdynlink.h" #ifdef HAS_UI #include "ui.h" #endif extern int caml_parser_trace; -header_t caml_atom_table[256]; -char * caml_static_data_start, * caml_static_data_end; +CAMLexport header_t caml_atom_table[256]; char * caml_code_area_start, * caml_code_area_end; /* Initialize the atom table and the static data and code area limits. */ struct segment { char * begin; char * end; }; -static void minmax_table(struct segment *table, char **min, char **max) -{ - int i; - *min = table[0].begin; - *max = table[0].end; - for (i = 1; table[i].begin != 0; i++) { - if (table[i].begin < *min) *min = table[i].begin; - if (table[i].end > *max) *max = table[i].end; - } -} - static void init_atoms(void) { - int i; extern struct segment caml_data_segments[], caml_code_segments[]; + int i; - for (i = 0; i < 256; i++) caml_atom_table[i] = Make_header(0, i, Caml_white); - minmax_table(caml_data_segments, - &caml_static_data_start, &caml_static_data_end); - minmax_table(caml_code_segments, &caml_code_area_start, &caml_code_area_end); + for (i = 0; i < 256; i++) { + caml_atom_table[i] = Make_header(0, i, Caml_white); + } + if (caml_page_table_add(In_static_data, + caml_atom_table, caml_atom_table + 256) != 0) + caml_fatal_error("Fatal error: not enough memory for the initial page table"); + + for (i = 0; caml_data_segments[i].begin != 0; i++) { + if (caml_page_table_add(In_static_data, + caml_data_segments[i].begin, + caml_data_segments[i].end) != 0) + caml_fatal_error("Fatal error: not enough memory for the initial page table"); + } + + caml_code_area_start = caml_code_segments[0].begin; + caml_code_area_end = caml_code_segments[0].end; + for (i = 1; caml_code_segments[i].begin != 0; i++) { + if (caml_code_segments[i].begin < caml_code_area_start) + caml_code_area_start = caml_code_segments[i].begin; + if (caml_code_segments[i].end > caml_code_area_end) + caml_code_area_end = caml_code_segments[i].end; + } } /* Configuration parameters and flags */ @@ -111,7 +119,7 @@ static void parse_camlrunparam(void) case 'o': scanmult (opt, &percent_free_init); break; case 'O': scanmult (opt, &max_percent_free_init); break; case 'v': scanmult (opt, &caml_verb_gc); break; - case 'b': caml_init_backtrace(); break; + case 'b': caml_record_backtrace(Val_true); break; case 'p': caml_parser_trace = 1; break; } } diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 628eb78a20..e3a281280a 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex 6dbdc63904..d10e1c2077 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 96f81404da..0db630253a 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/build/buildbot b/build/buildbot index c755852fe6..e9b2579eb0 100755 --- a/build/buildbot +++ b/build/buildbot @@ -1,5 +1,9 @@ #!/bin/sh +# If you want to help me by participating to the build/test effort: +# http://gallium.inria.fr/~pouillar/ocaml-testing.html +# -- Nicolas Pouillard + usage() { echo "Usage: $0 (make|ocb|ocamlbuild) (win (mingw|msvc|msvc64) | <configure-arg>*)" exit 1 @@ -11,7 +15,7 @@ finish() { curl -s -0 -F "log=@$logfile" \ -F "host=`hostname`" \ -F "mode=$mode-$opt_win-$opt_win2" \ - http://weblog.feydakins.org/dropbox || : + http://buildbot.feydakins.org/dropbox || : } rm -f buildbot.failed diff --git a/build/distclean.sh b/build/distclean.sh index e9db93934c..1a88138d85 100755 --- a/build/distclean.sh +++ b/build/distclean.sh @@ -1,5 +1,19 @@ #!/bin/sh + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + # $Id$ + cd `dirname $0`/.. set -ex (cd byterun && make clean) || : @@ -9,6 +23,7 @@ rm -rf _build rm -f boot/ocamlrun boot/ocamlrun.exe boot/camlheader \ boot/myocamlbuild boot/myocamlbuild.native boot/myocamlbuild.native.exe \ myocamlbuild_config.ml config/config.sh config/Makefile \ + boot/ocamlyacc tools/cvt_emit.bak tools/*.bak \ config/s.h config/m.h boot/*.cm* _log _*_log* # from partial boot @@ -17,7 +32,7 @@ rm -f driver/main.byte driver/optmain.byte lex/main.byte \ camlp4/build/location.mli \ tools/myocamlbuild_config.ml camlp4/build/linenum.mli \ camlp4/build/linenum.mll \ - camlp4/build/terminfo.mli camlp4/build/terminfo.ml + camlp4/build/terminfo.mli camlp4/build/terminfo.ml # from ocamlbuild bootstrap rm -f ocamlbuild/_log ocamlbuild/,ocamlbuild.byte.start \ diff --git a/build/install.sh b/build/install.sh index 12f3260742..06feb41ba0 100755 --- a/build/install.sh +++ b/build/install.sh @@ -1,5 +1,19 @@ #!/bin/sh + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + # $Id$ + set -e cd `dirname $0`/.. @@ -127,6 +141,7 @@ installdir otherlibs/"$WIN32"unix/unixsupport.h \ installdir yacc/ocamlyacc byterun/ocamlrun $BINDIR +installdir config/Makefile $LIBDIR/Makefile.config installdir byterun/ld.conf $LIBDIR cd _build @@ -152,6 +167,7 @@ installdir \ stdlib/arrayLabels.cmi stdlib/arrayLabels.mli \ stdlib/buffer.cmi stdlib/buffer.mli \ stdlib/callback.cmi stdlib/callback.mli \ + stdlib/camlinternalLazy.cmi stdlib/camlinternalLazy.mli \ stdlib/camlinternalMod.cmi stdlib/camlinternalMod.mli \ stdlib/camlinternalOO.cmi stdlib/camlinternalOO.mli \ stdlib/char.cmi stdlib/char.mli \ @@ -195,6 +211,7 @@ installdir \ stdlib/arrayLabels.cmx stdlib/arrayLabels.p.cmx stdlib/arrayLabels.$O stdlib/arrayLabels.p.$O \ stdlib/buffer.cmx stdlib/buffer.p.cmx stdlib/buffer.$O stdlib/buffer.p.$O \ stdlib/callback.cmx stdlib/callback.p.cmx stdlib/callback.$O stdlib/callback.p.$O \ + stdlib/camlinternalLazy.cmx stdlib/camlinternalLazy.p.cmx stdlib/camlinternalLazy.$O stdlib/camlinternalLazy.p.$O \ stdlib/camlinternalMod.cmx stdlib/camlinternalMod.p.cmx stdlib/camlinternalMod.$O stdlib/camlinternalMod.p.$O \ stdlib/camlinternalOO.cmx stdlib/camlinternalOO.p.cmx stdlib/camlinternalOO.$O stdlib/camlinternalOO.p.$O \ stdlib/char.cmx stdlib/char.p.cmx stdlib/char.$O stdlib/char.p.$O \ @@ -462,8 +479,8 @@ echo "Installing manuals..." (cd ../man && make install) echo "Installing ocamldoc..." -installbin ocamldoc/ocamldoc$EXE $BINDIR/ocamldoc$EXE -installbin ocamldoc/ocamldoc.opt$EXE $BINDIR/ocamldoc.opt$EXE +installbin ocamldoc/ocamldoc $BINDIR/ocamldoc$EXE +installbin ocamldoc/ocamldoc.opt $BINDIR/ocamldoc.opt$EXE installdir \ ../ocamldoc/ocamldoc.hva \ @@ -510,30 +527,40 @@ installdir \ camlp4o.cma camlp4of.cma camlp4oof.cma \ camlp4orf.cma camlp4r.cma camlp4rf.cma \ Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \ - Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O \ + Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O Camlp4_import.cmi \ $CAMLP4DIR installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR cd .. echo "Installing ocamlbuild..." -installbin ocamlbuild/ocamlbuild.byte$EXE $BINDIR/ocamlbuild.byte$EXE -installbin ocamlbuild/ocamlbuild.native$EXE $BINDIR/ocamlbuild.native$EXE -installbestbin ocamlbuild/ocamlbuild.native$EXE ocamlbuild/ocamlbuild.byte$EXE $BINDIR/ocamlbuild$EXE +cd ocamlbuild +installbin ocamlbuild.byte$EXE $BINDIR/ocamlbuild.byte$EXE +installbin ocamlbuild.native$EXE $BINDIR/ocamlbuild.native$EXE +installbestbin ocamlbuild.native$EXE ocamlbuild.byte$EXE $BINDIR/ocamlbuild$EXE installlibdir \ - ocamlbuild/ocamlbuildlib.$A \ + ocamlbuildlib.$A \ $LIBDIR/ocamlbuild installdir \ - ocamlbuild/ocamlbuildlib.cmxa \ - ocamlbuild/ocamlbuildlib.cma \ - ocamlbuild/ocamlbuild_plugin.cmi \ - ocamlbuild/ocamlbuild_pack.cmi \ - ocamlbuild/ocamlbuild.cmo \ - ocamlbuild/ocamlbuild.cmx \ - ocamlbuild/ocamlbuild.$O \ + ocamlbuildlib.cmxa \ + ocamlbuildlib.cma \ + ocamlbuild_plugin.cmi \ + ocamlbuild_pack.cmi \ + ocamlbuild_unix_plugin.cmi \ + ocamlbuild_unix_plugin.cmo \ + ocamlbuild_unix_plugin.cmx \ + ocamlbuild_unix_plugin.$O \ + ocamlbuild_executor.cmi \ + ocamlbuild_executor.cmo \ + ocamlbuild_executor.cmx \ + ocamlbuild_executor.$O \ + ocamlbuild.cmo \ + ocamlbuild.cmx \ + ocamlbuild.$O \ $LIBDIR/ocamlbuild +cd .. installdir \ ../ocamlbuild/man/ocamlbuild.1 \ diff --git a/build/mkconfig.sh b/build/mkconfig.sh index 591bebc658..1cd66f37ec 100755 --- a/build/mkconfig.sh +++ b/build/mkconfig.sh @@ -5,6 +5,7 @@ cd `dirname $0`/.. sed -e 's/^\(.*\$([0-9]).*\)$/# \1/' \ -e 's/\$(\([^)]*\))/${\1}/g' \ + -e 's/^FLEX.*$//g' \ -e 's/^\([^#=]*\)=\([^"]*\)$/if [ "x$\1" = "x" ]; then \1="\2"; fi/' \ config/Makefile > config/config.sh diff --git a/build/mkmyocamlbuild_config.sh b/build/mkmyocamlbuild_config.sh index 158e13d5e2..e48f5b0e0b 100755 --- a/build/mkmyocamlbuild_config.sh +++ b/build/mkmyocamlbuild_config.sh @@ -1,20 +1,40 @@ #!/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$ cd `dirname $0`/.. sed \ + -e 's/^.*FLEXDIR.*$//g' \ -e 's/^#ml \(.*\)/\1/' \ -e 's/^\(#.*\)$/(* \1 *)/' \ -e 's/^\(.*\$([0-9]).*\)$/(* \1 *)/' \ -e 's/^\([^(=]*\)=\([^"]*\)$/let <:lower<\1>> = "\2";;/' \ + -e 's/\$(AS)/as/g' \ -e 's/\$(\([^)]*\))/"\^<:lower<\1>>\^"/g' \ -e 's/""\^//g' \ -e 's/\^""//g' \ - -e 's/^let <:lower<\(MAKE\|DO\).*$//g' \ + -e 's/^let <:lower<MAKE.*$//g' \ + -e 's/^let <:lower<DO.*$//g' \ -e 's/"true"/true/g' \ -e 's/"false"/false/g' \ - config/Makefile | \ - sed -f build/tolower.sed | \ - sed -f build/tolower.sed | \ - sed -f build/tolower.sed > myocamlbuild_config.ml + config/Makefile \ + | sed -f build/tolower.sed \ + | sed -f build/tolower.sed \ + | sed -f build/tolower.sed \ + | sed -f build/tolower.sed \ + | sed -f build/tolower.sed \ + | sed -f build/tolower.sed \ + > myocamlbuild_config.ml diff --git a/build/otherlibs-targets.sh b/build/otherlibs-targets.sh index 77542fad20..24df9a6d91 100644 --- a/build/otherlibs-targets.sh +++ b/build/otherlibs-targets.sh @@ -93,7 +93,9 @@ for lib in $OTHERLIBRARIES; do add_ocaml_lib dbm add_c_lib mldbm;; dynlink) - add_byte $lib.cmi $lib.cma extract_crc;; + add_ocaml_lib dynlink + add_native dynlink.cmx + add_file $lib.cmi extract_crc;; win32unix) UNIXDIR="otherlibs/win32unix" add_file unixsupport.h cst2constr.h socketaddr.h diff --git a/build/partial-boot.sh b/build/partial-boot.sh index e2b8097b76..ee6676eadb 100755 --- a/build/partial-boot.sh +++ b/build/partial-boot.sh @@ -1,14 +1,25 @@ #!/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$ + set -ex cd `dirname $0`/.. OCAMLBUILD_PARTIAL="true" export OCAMLBUILD_PARTIAL mkdir -p _build cp -rf boot _build/ -cp parsing/location.ml parsing/location.mli camlp4/build -cp parsing/linenum.mll parsing/linenum.mli camlp4/build -cp utils/terminfo.ml utils/terminfo.mli camlp4/build ./build/mkconfig.sh ./build/mkmyocamlbuild_config.sh ./build/boot.sh diff --git a/build/partial-install.sh b/build/partial-install.sh index 0122cf4450..05bb74811d 100755 --- a/build/partial-install.sh +++ b/build/partial-install.sh @@ -1,6 +1,20 @@ #!/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$ + ###################################### ######### Copied from build/install.sh ###################################### @@ -136,7 +150,7 @@ installdir \ camlp4o.cma camlp4of.cma camlp4oof.cma \ camlp4orf.cma camlp4r.cma camlp4rf.cma \ Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \ - Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O \ + Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O Camlp4_import.cmi \ $CAMLP4DIR installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR cd .. @@ -156,6 +170,14 @@ installdir \ ocamlbuildlib.cma \ ocamlbuild_plugin.cmi \ ocamlbuild_pack.cmi \ + ocamlbuild_unix_plugin.cmi \ + ocamlbuild_unix_plugin.cmo \ + ocamlbuild_unix_plugin.cmx \ + ocamlbuild_unix_plugin.$O \ + ocamlbuild_executor.cmi \ + ocamlbuild_executor.cmo \ + ocamlbuild_executor.cmx \ + ocamlbuild_executor.$O \ ocamlbuild.cmo \ ocamlbuild.cmx \ ocamlbuild.$O \ diff --git a/build/targets.sh b/build/targets.sh index 90041aaaa6..146015a637 100644 --- a/build/targets.sh +++ b/build/targets.sh @@ -1,4 +1,18 @@ + +######################################################################### +# # +# 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$ + . config/config.sh . build/otherlibs-targets.sh . build/camlp4-targets.sh @@ -38,8 +52,9 @@ OCAMLOPT_NATIVE=ocamlopt.opt$EXE OCAMLLEX_NATIVE=lex/ocamllex.opt$EXE TOOLS_NATIVE=tools/ocamldep.native$EXE OCAMLDOC_NATIVE="ocamldoc/ocamldoc.opt$EXE ocamldoc/odoc_info.cmxa ocamldoc/stdlib_man/Pervasives.3o" -OCAMLBUILD_NATIVE="ocamlbuild/ocamlbuildlib.cmxa \ - ocamlbuild/ocamlbuildlightlib.cmxa \ +OCAMLBUILDLIB_NATIVE="ocamlbuild/ocamlbuildlib.cmxa \ + ocamlbuild/ocamlbuildlightlib.cmxa" +OCAMLBUILD_NATIVE="$OCAMLBUILDLIB_NATIVE \ ocamlbuild/ocamlbuild.native$EXE \ ocamlbuild/ocamlbuildlight.native$EXE" if [ -x boot/myocamlbuild.native ]; then diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 2cd0c65b0d..f7911aa3e5 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -373,17 +373,12 @@ let comp_primitive p args = | Pbintcomp(bi, Cgt) -> Kccall("caml_greaterthan", 2) | Pbintcomp(bi, Cle) -> Kccall("caml_lessequal", 2) | Pbintcomp(bi, Cge) -> Kccall("caml_greaterequal", 2) - | Pbigarrayref(n, _, _) -> Kccall("caml_ba_get_" ^ string_of_int n, n + 1) - | Pbigarrayset(n, _, _) -> Kccall("caml_ba_set_" ^ string_of_int n, n + 2) + | Pbigarrayref(_, n, _, _) -> Kccall("caml_ba_get_" ^ string_of_int n, n + 1) + | Pbigarrayset(_, n, _, _) -> Kccall("caml_ba_set_" ^ string_of_int n, n + 2) | _ -> fatal_error "Bytegen.comp_primitive" let is_immed n = immed_min <= n && n <= immed_max -let explode_isout arg l h = - Lprim - (Psequor, - [Lprim (Pintcomp Clt,[arg ; Lconst (Const_base (Const_int 0))]) ; - Lprim (Pintcomp Cgt,[arg ; Lconst (Const_base (Const_int h))])]) (* Compile an expression. The value of the expression is left in the accumulator. @@ -414,13 +409,15 @@ let rec comp_expr env exp sz cont = end | Lconst cst -> Kconst cst :: cont - | Lapply(func, args) -> + | Lapply(func, args, loc) -> let nargs = List.length args in - if is_tailcall cont then + if is_tailcall cont then begin + Stypes.record (Stypes.An_call (loc, Annot.Tail)); comp_args env args sz (Kpush :: comp_expr env func (sz + nargs) (Kappterm(nargs, sz + nargs) :: discard_dead_code cont)) - else + end else begin + Stypes.record (Stypes.An_call (loc, Annot.Stack)); if nargs < 4 then comp_args env args sz (Kpush :: comp_expr env func (sz + nargs) (Kapply nargs :: cont)) @@ -431,6 +428,7 @@ let rec comp_expr env exp sz cont = (Kpush :: comp_expr env func (sz + 3 + nargs) (Kapply nargs :: cont1)) end + end | Lsend(kind, met, obj, args) -> let args = if kind = Cached then List.tl args else args in let nargs = List.length args + 1 in @@ -746,7 +744,7 @@ let rec comp_expr env exp sz cont = | Lev_after ty -> let info = match lam with - Lapply(_, args) -> Event_return (List.length args) + Lapply(_, args, _) -> Event_return (List.length args) | Lsend(_, _, _, args) -> Event_return (List.length args + 1) | _ -> Event_other in diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index 153aa69d87..97df99b17f 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -45,13 +45,15 @@ let lib_ccopts = ref [] let lib_dllibs = ref [] let add_ccobjs l = - if not !Clflags.no_auto_link - && String.length !Clflags.use_runtime = 0 + if not !Clflags.no_auto_link then begin + if + String.length !Clflags.use_runtime = 0 && String.length !Clflags.use_prims = 0 - then begin - if l.lib_custom then Clflags.custom_runtime := true; - lib_ccobjs := l.lib_ccobjs @ !lib_ccobjs; - lib_ccopts := l.lib_ccopts @ !lib_ccopts; + then begin + if l.lib_custom then Clflags.custom_runtime := true; + lib_ccobjs := l.lib_ccobjs @ !lib_ccobjs; + lib_ccopts := l.lib_ccopts @ !lib_ccopts; + end; lib_dllibs := l.lib_dllibs @ !lib_dllibs end @@ -429,43 +431,9 @@ void caml_startup(char ** argv) (* Build a custom runtime *) let build_custom_runtime prim_name exec_name = - match Config.ccomp_type with - "cc" -> - Ccomp.command - (Printf.sprintf - "%s -o %s %s %s %s %s %s -lcamlrun %s" - !Clflags.c_linker - (Filename.quote exec_name) - (Clflags.std_include_flag "-I") - (String.concat " " (List.rev !Clflags.ccopts)) - prim_name - (Ccomp.quote_files - (List.map (fun dir -> if dir = "" then "" else "-L" ^ dir) - !load_path)) - (Ccomp.quote_files (List.rev !Clflags.ccobjs)) - Config.bytecomp_c_libraries) - | "msvc" -> - let retcode = - Ccomp.command - (Printf.sprintf - "%s /Fe%s %s %s %s %s %s %s" - !Clflags.c_linker - (Filename.quote exec_name) - (Clflags.std_include_flag "-I") - prim_name - (Ccomp.quote_files - (List.rev_map Ccomp.expand_libname !Clflags.ccobjs)) - (Filename.quote (Ccomp.expand_libname "-lcamlrun")) - Config.bytecomp_c_libraries - (Ccomp.make_link_options !Clflags.ccopts)) in - (* C compiler doesn't clean up after itself. Note that the .obj - file is created in the current working directory. *) - remove_file - (Filename.chop_suffix (Filename.basename prim_name) ".c" ^ ".obj"); - if retcode <> 0 - then retcode - else Ccomp.merge_manifest exec_name - | _ -> assert false + Ccomp.call_linker Ccomp.Exe exec_name + ([prim_name] @ List.rev !Clflags.ccobjs @ ["-lcamlrun"]) + Config.bytecomp_c_libraries let append_bytecode_and_cleanup bytecode_name exec_name prim_name = let oc = open_out_gen [Open_wronly; Open_append; Open_binary] 0 exec_name in @@ -510,7 +478,7 @@ let link objfiles output_name = Symtable.output_primitive_table poc; close_out poc; let exec_name = fix_exec_name output_name in - if build_custom_runtime prim_name exec_name <> 0 + if not (build_custom_runtime prim_name exec_name) then raise(Error Custom_runtime); if !Clflags.make_runtime then (remove_file bytecode_name; remove_file prim_name) @@ -520,17 +488,28 @@ let link objfiles output_name = remove_file prim_name; raise x end else begin - let c_file = - Filename.chop_suffix output_name Config.ext_obj ^ ".c" in + let basename = Filename.chop_extension output_name in + let c_file = basename ^ ".c" + and obj_file = basename ^ Config.ext_obj in if Sys.file_exists c_file then raise(Error(File_exists c_file)); + let temps = ref [] in try link_bytecode_as_c tolink c_file; - if Ccomp.compile_file c_file <> 0 - then raise(Error Custom_runtime); - remove_file c_file + if not (Filename.check_suffix output_name ".c") then begin + temps := c_file :: !temps; + if Ccomp.compile_file c_file <> 0 then raise(Error Custom_runtime); + if not (Filename.check_suffix output_name Config.ext_obj) then begin + temps := obj_file :: !temps; + if not ( + Ccomp.call_linker Ccomp.MainDll output_name + ([obj_file] @ List.rev !Clflags.ccobjs @ ["-lcamlrun"]) + Config.bytecomp_c_libraries + ) then raise (Error Custom_runtime); + end + end; + List.iter remove_file !temps with x -> - remove_file c_file; - remove_file output_name; + List.iter remove_file !temps; raise x end diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index d26fef75c7..db10dea647 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -373,7 +373,7 @@ let to_file outchan unit_name code = cu_codesize = !out_position; cu_reloc = List.rev !reloc_info; cu_imports = Env.imported_units(); - cu_primitives = !Translmod.primitive_declarations; + cu_primitives = List.map Primitive.byte_name !Translmod.primitive_declarations; cu_force_link = false; cu_debug = pos_debug; cu_debugsize = size_debug } in diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index f97648fcba..746711e11e 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -29,6 +29,8 @@ type primitive = | Pfloatfield of int | Psetfloatfield of int | Pduprecord of Types.record_representation * int + (* Force lazy values *) + | Plazyforce (* External call *) | Pccall of Primitive.description (* Exceptions *) @@ -79,9 +81,9 @@ type primitive = | Plsrbint of boxed_integer | Pasrbint of boxed_integer | Pbintcomp of boxed_integer * comparison - (* Operations on big arrays *) - | Pbigarrayref of int * bigarray_kind * bigarray_layout - | Pbigarrayset of int * bigarray_kind * bigarray_layout + (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) + | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout + | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge @@ -124,7 +126,7 @@ type shared_code = (int * int) list type lambda = Lvar of Ident.t | Lconst of structured_constant - | Lapply of lambda * lambda list + | Lapply of lambda * lambda list * Location.t | Lfunction of function_kind * Ident.t list * lambda | Llet of let_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda @@ -171,7 +173,7 @@ let rec same l1 l2 = Ident.same v1 v2 | Lconst c1, Lconst c2 -> c1 = c2 - | Lapply(a1, bl1), Lapply(a2, bl2) -> + | Lapply(a1, bl1, _), Lapply(a2, bl2, _) -> same a1 a2 && samelist same bl1 bl2 | Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) -> k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2 @@ -241,7 +243,7 @@ let name_lambda_list args fn = let rec iter f = function Lvar _ | Lconst _ -> () - | Lapply(fn, args) -> + | Lapply(fn, args, _) -> f fn; List.iter f args | Lfunction(kind, params, body) -> f body @@ -375,7 +377,7 @@ let subst_lambda s lam = Lvar id as l -> begin try Ident.find_same id s with Not_found -> l end | Lconst sc as l -> l - | Lapply(fn, args) -> Lapply(subst fn, List.map subst args) + | Lapply(fn, args, loc) -> Lapply(subst fn, List.map subst args, loc) | Lfunction(kind, params, body) -> Lfunction(kind, params, subst body) | Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body) | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body) @@ -453,8 +455,9 @@ let may_raise = function | Pdivint | Pmodint (* Hum, not really an exception... *) | Pdivbint _ | Pmodbint _ - | Pbigarrayref (_,_,_) - | Pbigarrayset (_,_,_) + | Pbigarrayref _ + | Pbigarrayset _ + | Plazyforce -> true | Pidentity | Pignore diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index 6c55f2bb59..6f735faf9d 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -29,6 +29,8 @@ type primitive = | Pfloatfield of int | Psetfloatfield of int | Pduprecord of Types.record_representation * int + (* Force lazy values *) + | Plazyforce (* External call *) | Pccall of Primitive.description (* Exceptions *) @@ -79,9 +81,9 @@ type primitive = | Plsrbint of boxed_integer | Pasrbint of boxed_integer | Pbintcomp of boxed_integer * comparison - (* Operations on big arrays *) - | Pbigarrayref of int * bigarray_kind * bigarray_layout - | Pbigarrayset of int * bigarray_kind * bigarray_layout + (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) + | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout + | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge @@ -133,7 +135,7 @@ type shared_code = (int * int) list (* stack size -> code label *) type lambda = Lvar of Ident.t | Lconst of structured_constant - | Lapply of lambda * lambda list + | Lapply of lambda * lambda list * Location.t | Lfunction of function_kind * Ident.t list * lambda | Llet of let_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 330e91f867..7eda09c23b 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -203,7 +203,11 @@ let ctx_matcher p = let l' = all_record_args l' in p, List.fold_right (fun (_,p) r -> p::r) l' rem | _ -> p,List.fold_right (fun (_,p) r -> p::r) l rem) - | _ -> fatal_error "Matching.ctx_matcher" + | Tpat_lazy omega -> + (fun q rem -> match q.pat_desc with + | Tpat_lazy arg -> p, (arg::rem) + | _ -> p, (omega::rem)) + | _ -> fatal_error "Matching.ctx_matcher" @@ -616,6 +620,7 @@ let rec extract_vars r p = match p.pat_desc with | Tpat_array pats -> List.fold_left extract_vars r pats | Tpat_variant (_,Some p, _) -> extract_vars r p +| Tpat_lazy p -> extract_vars r p | Tpat_or (p,_,_) -> extract_vars r p | Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> r @@ -683,6 +688,10 @@ and group_array = function | {pat_desc=Tpat_array _} -> true | _ -> false +and group_lazy = function + | {pat_desc = Tpat_lazy _} -> true + | _ -> false + let get_group p = match p.pat_desc with | Tpat_any -> group_var | Tpat_constant _ -> group_constant @@ -691,6 +700,7 @@ let get_group p = match p.pat_desc with | Tpat_record _ -> group_record | Tpat_array _ -> group_array | Tpat_variant (_,_,_) -> group_variant +| Tpat_lazy _ -> group_lazy | _ -> fatal_error "Matching.get_group" @@ -1287,6 +1297,119 @@ let make_var_matching def = function let divide_var ctx pm = divide_line ctx_lshift make_var_matching get_args_var omega ctx pm +(* Matching and forcing a lazy value *) + +let get_arg_lazy p rem = match p with +| {pat_desc = Tpat_any} -> omega :: rem +| {pat_desc = Tpat_lazy arg} -> arg :: rem +| _ -> assert false + +let matcher_lazy p rem = match p.pat_desc with +| Tpat_or (_,_,_) -> raise OrPat +| Tpat_var _ -> get_arg_lazy omega rem +| _ -> get_arg_lazy p rem + +(* Inlining the tag tests before calling the primitive that works on + lazy blocks. This is alse used in translcore.ml. + No call other than Obj.tag when the value has been forced before. +*) + +let prim_obj_tag = + {prim_name = "caml_obj_tag"; + prim_arity = 1; prim_alloc = false; + prim_native_name = ""; + prim_native_float = false} + +let get_mod_field modname field = + lazy ( + try + let mod_ident = Ident.create_persistent modname in + let env = Env.open_pers_signature modname Env.initial in + let p = try + match Env.lookup_value (Longident.Lident field) env with + | (Path.Pdot(_,_,i), _) -> i + | _ -> fatal_error ("Primitive "^modname^"."^field^" not found.") + with Not_found -> fatal_error ("Primitive "^modname^"."^field^" not found.") + in + Lprim(Pfield p, [Lprim(Pgetglobal mod_ident, [])]) + with Not_found -> fatal_error ("Module "^modname^" unavailable.") + ) + +let code_force_lazy_block = + get_mod_field "CamlinternalLazy" "force_lazy_block" +;; + +(* inline_lazy_force inlines the beginning of the code of Lazy.force. When + the value argument is tagged as: + - forward, take field 0 + - lazy, call the primitive that forces (without testing again the tag) + - anything else, return it + + Using Lswitch below relies on the fact that the GC does not shortcut + Forward(val_out_of_heap). +*) + +let inline_lazy_force_cond arg loc = + let idarg = Ident.create "lzarg" in + let varg = Lvar idarg in + let tag = Ident.create "tag" in + let force_fun = Lazy.force code_force_lazy_block in + Llet(Strict, idarg, arg, + Llet(Alias, tag, Lprim(Pccall prim_obj_tag, [varg]), + Lifthenelse( + (* if (tag == Obj.forward_tag) then varg.(0) else ... *) + Lprim(Pintcomp Ceq, + [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))]), + Lprim(Pfield 0, [varg]), + Lifthenelse( + (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *) + Lprim(Pintcomp Ceq, + [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))]), + Lapply(force_fun, [varg], loc), + (* ... arg *) + varg)))) + +let inline_lazy_force_switch arg loc = + let idarg = Ident.create "lzarg" in + let varg = Lvar idarg in + let force_fun = Lazy.force code_force_lazy_block in + Llet(Strict, idarg, arg, + Lifthenelse( + Lprim(Pisint, [varg]), varg, + (Lswitch + (varg, + { sw_numconsts = 0; sw_consts = []; + sw_numblocks = (max Obj.lazy_tag Obj.forward_tag) + 1; + sw_blocks = + [ (Obj.forward_tag, Lprim(Pfield 0, [varg])); + (Obj.lazy_tag, + Lapply(force_fun, [varg], loc)) ]; + sw_failaction = Some varg } )))) + +let inline_lazy_force = + if !Clflags.native_code then + (* Lswitch generates compact and efficient native code *) + inline_lazy_force_switch + else + (* generating bytecode: Lswitch would generate too many rather big + tables (~ 250 elts); conditionals are better *) + inline_lazy_force_cond + +let make_lazy_matching def = function + [] -> fatal_error "Matching.make_lazy_matching" + | (arg,mut) :: argl -> + { cases = []; + args = + (inline_lazy_force arg Location.none, Strict) :: argl; + default = make_default matcher_lazy def } + +let divide_lazy p ctx pm = + divide_line + (filter_ctx p) + make_lazy_matching + get_arg_lazy + p ctx pm + (* Matching against a tuple pattern *) @@ -2335,10 +2458,14 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with compile_test (compile_match repr partial) partial (divide_array kind) (combine_array arg kind partial) ctx pm + | Tpat_lazy _ -> + compile_no_test + (divide_lazy (normalize_pat pat)) + ctx_combine repr partial ctx pm | Tpat_variant(lab, _, row) -> compile_test (compile_match repr partial) partial - (divide_variant row) - (combine_variant row arg partial) + (divide_variant !row) + (combine_variant !row arg partial) ctx pm | _ -> assert false end @@ -2582,4 +2709,3 @@ let for_multiple_match (handler, loc) paraml pat_act_list partial = end with Unused -> assert false (* ; partial_function loc () *) - diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli index 062088d532..91cbf285f2 100644 --- a/bytecomp/matching.mli +++ b/bytecomp/matching.mli @@ -42,3 +42,5 @@ val flatten_pattern: int -> pattern -> pattern list val make_test_sequence: lambda option -> primitive -> primitive -> lambda -> (Asttypes.constant * lambda) list -> lambda + +val inline_lazy_force : lambda -> Location.t -> lambda diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 3f42f7e1e8..0d6e19148d 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -61,9 +61,9 @@ let boxed_integer_mark name = function let print_boxed_integer name ppf bi = fprintf ppf "%s" (boxed_integer_mark name bi);; -let print_bigarray name kind ppf layout = +let print_bigarray name unsafe kind ppf layout = fprintf ppf "Bigarray.%s[%s,%s]" - name + (if unsafe then "unsafe_"^ name else name) (match kind with | Pbigarray_unknown -> "generic" | Pbigarray_float32 -> "float32" @@ -103,6 +103,7 @@ let primitive ppf = function | Pfloatfield n -> fprintf ppf "floatfield %i" n | Psetfloatfield n -> fprintf ppf "setfloatfield %i" n | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size + | Plazyforce -> fprintf ppf "force" | Pccall p -> fprintf ppf "%s" p.prim_name | Praise -> fprintf ppf "raise" | Psequand -> fprintf ppf "&&" @@ -177,15 +178,17 @@ let primitive ppf = function | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi - | Pbigarrayref(n, kind, layout) -> print_bigarray "get" kind ppf layout - | Pbigarrayset(n, kind, layout) -> print_bigarray "set" kind ppf layout + | Pbigarrayref(unsafe, n, kind, layout) -> + print_bigarray "get" unsafe kind ppf layout + | Pbigarrayset(unsafe, n, kind, layout) -> + print_bigarray "set" unsafe kind ppf layout let rec lam ppf = function | Lvar id -> Ident.print ppf id | Lconst cst -> struct_const ppf cst - | Lapply(lfun, largs) -> + | Lapply(lfun, largs, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index ee59cab742..eaa408935f 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -26,8 +26,8 @@ let rec eliminate_ref id = function Lvar v as lam -> if Ident.same v id then raise Real_reference else lam | Lconst cst as lam -> lam - | Lapply(e1, el) -> - Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el) + | Lapply(e1, el, loc) -> + Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, loc) | Lfunction(kind, params, body) as lam -> if IdentSet.mem id (free_variables lam) then raise Real_reference @@ -104,7 +104,7 @@ let simplify_exits lam = let rec count = function | (Lvar _| Lconst _) -> () - | Lapply(l1, ll) -> count l1; List.iter count ll + | Lapply(l1, ll, _) -> count l1; List.iter count ll | Lfunction(kind, params, l) -> count l | Llet(str, v, l1, l2) -> count l2; count l1 @@ -185,7 +185,7 @@ let simplify_exits lam = let rec simplif = function | (Lvar _|Lconst _) as l -> l - | Lapply(l1, ll) -> Lapply(simplif l1, List.map simplif ll) + | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc) | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l) | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2) | Lletrec(bindings, body) -> @@ -209,7 +209,7 @@ let simplify_exits lam = with | Not_found -> l end - | Lstaticraise (i,ls) as l -> + | Lstaticraise (i,ls) -> let ls = List.map simplif ls in begin try let xs,handler = Hashtbl.find subst i in @@ -222,7 +222,7 @@ let simplify_exits lam = (fun y l r -> Llet (Alias, y, l, r)) ys ls (Lambda.subst_lambda env handler) with - | Not_found -> l + | Not_found -> Lstaticraise (i,ls) end | Lstaticcatch (l1,(i,[]),(Lstaticraise (j,[]) as l2)) -> Hashtbl.add subst i ([],simplif l2) ; @@ -276,7 +276,7 @@ let simplify_lets lam = let rec count = function | Lvar v -> incr_var v | Lconst cst -> () - | Lapply(l1, ll) -> count l1; List.iter count ll + | Lapply(l1, ll, _) -> count l1; List.iter count ll | Lfunction(kind, params, l) -> count l | Llet(str, v, Lvar w, l2) when not !Clflags.debug -> (* v will be replaced by w in l2, so each occurrence of v in l2 @@ -346,7 +346,7 @@ let simplify_lets lam = l end | Lconst cst as l -> l - | Lapply(l1, ll) -> Lapply(simplif l1, List.map simplif ll) + | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc) | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l) | Llet(str, v, Lvar w, l2) when not !Clflags.debug -> Hashtbl.add subst v (simplif (Lvar w)); diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 7249ff66bb..5187c6d504 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -34,12 +34,14 @@ let lfunction params body = | _ -> Lfunction (Curried, params, body) -let lapply func args = +let lapply func args loc = match func with - Lapply(func', args') -> - Lapply(func', args' @ args) + Lapply(func', args', _) -> + Lapply(func', args' @ args, loc) | _ -> - Lapply(func, args) + Lapply(func, args, loc) + +let mkappl (func, args) = Lapply (func, args, Location.none);; let lsequence l1 l2 = if l2 = lambda_unit then l1 else Lsequence(l1, l2) @@ -68,13 +70,13 @@ let copy_inst_var obj id expr templ offset = Lvar offset])])])) let transl_val tbl create name = - Lapply (oo_prim (if create then "new_variable" else "get_variable"), + mkappl (oo_prim (if create then "new_variable" else "get_variable"), [Lvar tbl; transl_label name]) -let transl_vals tbl create vals rem = +let transl_vals tbl create strict vals rem = List.fold_right (fun (name, id) rem -> - Llet(StrictOpt, id, transl_val tbl create name, rem)) + Llet(strict, id, transl_val tbl create name, rem)) vals rem let meths_super tbl meths inh_meths = @@ -82,13 +84,13 @@ let meths_super tbl meths inh_meths = (fun (nm, id) rem -> try (nm, id, - Lapply(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)])) + mkappl(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)])) :: rem with Not_found -> rem) inh_meths [] let bind_super tbl (vals, meths) cl_init = - transl_vals tbl false vals + transl_vals tbl false StrictOpt vals (List.fold_right (fun (nm, id, def) rem -> Llet(StrictOpt, id, def, rem)) meths cl_init) @@ -97,16 +99,16 @@ let create_object cl obj init = let (inh_init, obj_init, has_init) = init obj' in if obj_init = lambda_unit then (inh_init, - Lapply (oo_prim (if has_init then "create_object_and_run_initializers" + mkappl (oo_prim (if has_init then "create_object_and_run_initializers" else"create_object_opt"), [obj; Lvar cl])) else begin (inh_init, Llet(Strict, obj', - Lapply (oo_prim "create_object_opt", [obj; Lvar cl]), + mkappl (oo_prim "create_object_opt", [obj; Lvar cl]), Lsequence(obj_init, if not has_init then Lvar obj' else - Lapply (oo_prim "run_initializers_opt", + mkappl (oo_prim "run_initializers_opt", [obj; Lvar obj'; Lvar cl])))) end @@ -120,7 +122,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = | Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])] in ((envs, (obj_init, path)::inh_init), - Lapply(Lvar obj_init, env @ [obj])) + mkappl(Lvar obj_init, env @ [obj])) | Tclass_structure str -> create_object cl_table obj (fun obj -> let (inh_init, obj_init, has_init) = @@ -178,7 +180,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = let (inh_init, obj_init) = build_object_init cl_table obj params inh_init obj_init cl in - (inh_init, transl_apply obj_init oexprs) + (inh_init, transl_apply obj_init oexprs Location.none) | Tclass_let (rec_flag, defs, vals, cl) -> let (inh_init, obj_init) = build_object_init cl_table obj (vals @ params) inh_init obj_init cl @@ -204,23 +206,23 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = let bind_method tbl lab id cl_init = - Llet(StrictOpt, id, Lapply (oo_prim "get_method_label", - [Lvar tbl; transl_label lab]), + Llet(Strict, id, mkappl (oo_prim "get_method_label", + [Lvar tbl; transl_label lab]), cl_init) let bind_methods tbl meths vals cl_init = let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in let len = List.length methl and nvals = List.length vals in if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else - if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else + if len = 0 && nvals < 2 then transl_vals tbl true Strict vals cl_init else let ids = Ident.create "ids" in let i = ref (len + nvals) in let getter, names = if nvals = 0 then "get_method_labels", [] else "new_methods_variables", [transl_meth_list (List.map fst vals)] in - Llet(StrictOpt, ids, - Lapply (oo_prim getter, + Llet(Strict, ids, + 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)) @@ -230,9 +232,9 @@ let output_methods tbl methods lam = match methods with [] -> lam | [lab; code] -> - lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam + lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam | _ -> - lsequence (Lapply(oo_prim "set_methods", + lsequence (mkappl(oo_prim "set_methods", [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)])) lam @@ -247,6 +249,8 @@ let rec index a = function | b :: l -> if b = a then 0 else 1 + index a l +let bind_id_as_val (id, _) = ("", id) + let rec build_class_init cla cstr super inh_init cl_init msubst top cl = match cl.cl_desc with Tclass_ident path -> @@ -255,7 +259,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = let lpath = transl_path path in (inh_init, Llet (Strict, obj_init, - Lapply(Lprim(Pfield 1, [lpath]), Lvar cla :: + mkappl(Lprim(Pfield 1, [lpath]), Lvar cla :: if top then [Lprim(Pfield 3, [lpath])] else []), bind_super cla super cl_init)) | _ -> @@ -296,7 +300,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = (inh_init, cl_init, methods, vals @ values) | Cf_init exp -> (inh_init, - Lsequence(Lapply (oo_prim "add_initializer", + Lsequence(mkappl (oo_prim "add_initializer", Lvar cla :: msubst false (transl_exp exp)), cl_init), methods, values)) @@ -309,16 +313,16 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in - let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in - (inh_init, transl_vals cla true vals cl_init) + let vals = List.map bind_id_as_val vals in + (inh_init, transl_vals cla true StrictOpt vals cl_init) | Tclass_apply (cl, exprs) -> build_class_init cla cstr super inh_init cl_init msubst top cl | Tclass_let (rec_flag, defs, vals, cl) -> let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in - let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in - (inh_init, transl_vals cla true vals cl_init) + let vals = List.map bind_id_as_val vals in + (inh_init, transl_vals cla true StrictOpt vals cl_init) | Tclass_constraint (cl, vals, meths, concr_meths) -> let virt_meths = List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in @@ -349,7 +353,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = cl_init valids in (inh_init, Llet (Strict, inh, - Lapply(oo_prim "inherits", narrow_args @ + mkappl(oo_prim "inherits", narrow_args @ [lpath; Lconst(Const_pointer(if top then 1 else 0))]), Llet(StrictOpt, obj_init, lfield inh 0, cl_init))) | _ -> @@ -358,10 +362,11 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = in if cstr then core cl_init else let (inh_init, cl_init) = - core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init)) + core (Lsequence (mkappl (oo_prim "widen", [Lvar cla]), cl_init)) in (inh_init, - Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init)) + Lsequence(mkappl (oo_prim "narrow", narrow_args), + cl_init)) end let rec build_class_lets cl = @@ -409,7 +414,7 @@ let rec transl_class_rebind obj_init cl vf = | rem -> build [] rem) | Tclass_apply (cl, oexprs) -> let path, obj_init = transl_class_rebind obj_init cl vf in - (path, transl_apply obj_init oexprs) + (path, transl_apply obj_init oexprs Location.none) | Tclass_let (rec_flag, defs, vals, cl) -> let path, obj_init = transl_class_rebind obj_init cl vf in (path, Translcore.transl_let rec_flag defs obj_init) @@ -437,7 +442,7 @@ let transl_class_rebind ids cl vf = try let obj_init = Ident.create "obj_init" and self = Ident.create "self" in - let obj_init0 = lapply (Lvar obj_init) [Lvar self] in + let obj_init0 = lapply (Lvar obj_init) [Lvar self] Location.none in let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in if not (Translcore.check_recursive_lambda ids obj_init') then raise(Error(cl.cl_loc, Illegal_class_expr)); @@ -454,13 +459,13 @@ let transl_class_rebind ids cl vf = Llet( Alias, cla, transl_path path, Lprim(Pmakeblock(0, Immutable), - [Lapply(Lvar new_init, [lfield cla 0]); + [mkappl(Lvar new_init, [lfield cla 0]); lfunction [table] (Llet(Strict, env_init, - Lapply(lfield cla 1, [Lvar table]), + mkappl(lfield cla 1, [Lvar table]), lfunction [envs] - (Lapply(Lvar new_init, - [Lapply(Lvar env_init, [Lvar envs])])))); + (mkappl(Lvar new_init, + [mkappl(Lvar env_init, [Lvar envs])])))); lfield cla 2; lfield cla 3]))) with Exit -> @@ -499,12 +504,12 @@ let rec builtin_meths self env env2 body = match body with | Llet(_, s', Lvar s, body) when List.mem s self -> builtin_meths (s'::self) env env2 body - | Lapply(f, [arg]) when const_path f -> + | Lapply(f, [arg], _) when const_path f -> let s, args = conv arg in ("app_"^s, f :: args) - | Lapply(f, [arg; p]) when const_path f && const_path p -> + | Lapply(f, [arg; p], _) when const_path f && const_path p -> let s, args = conv arg in ("app_"^s^"_const", f :: args @ [p]) - | Lapply(f, [p; arg]) when const_path f && const_path p -> + | Lapply(f, [p; arg], _) when const_path f && const_path p -> let s, args = conv arg in ("app_const_"^s, f :: p :: args) | Lsend(Self, Lvar n, Lvar s, [arg]) when List.mem s self -> @@ -535,7 +540,7 @@ module M = struct open CamlinternalOO let builtin_meths self env env2 body = let builtin, args = builtin_meths self env env2 body in - (* if not arr then [Lapply(oo_prim builtin, args)] else *) + (* if not arr then [mkappl(oo_prim builtin, args)] else *) let tag = match builtin with "get_const" -> GetConst | "get_var" -> GetVar @@ -585,6 +590,9 @@ open M Si ids=0 (objet immediat), alors on ne conserve que env_init. *) +let prerr_ids msg ids = + let names = List.map Ident.unique_toplevel_name ids in + prerr_endline (String.concat " " (msg :: names)) let transl_class ids cl_id arity pub_meths cl vflag = (* First check if it is not only a rebind *) @@ -602,10 +610,6 @@ let transl_class ids cl_id arity pub_meths cl vflag = let subst env lam i0 new_ids' = let fv = free_variables lam in let fv = List.fold_right IdentSet.remove !new_ids' fv in - (* IdentSet.iter - (fun id -> - if not (List.mem id new_ids) then prerr_endline (Ident.name id)) - fv; *) 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 @@ -682,11 +686,11 @@ let transl_class ids cl_id arity pub_meths cl vflag = tags pub_meths; let ltable table lam = Llet(Strict, table, - Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam) + mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam) and ldirect obj_init = Llet(Strict, obj_init, cl_init, - Lsequence(Lapply (oo_prim "init_class", [Lvar cla]), - Lapply(Lvar obj_init, [lambda_unit]))) + Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), + mkappl (Lvar obj_init, [lambda_unit]))) in (* Simplest case: an object defined at toplevel (ids=[]) *) if top && ids = [] then llets (ltable cla (ldirect obj_init)) else @@ -697,16 +701,16 @@ let transl_class ids cl_id arity pub_meths cl vflag = Llet(Strict, class_init, cl_init, lam (free_variables cl_init)) and lbody fv = if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then - Lapply (oo_prim "make_class",[transl_meth_list pub_meths; + mkappl (oo_prim "make_class",[transl_meth_list pub_meths; Lvar class_init]) else ltable table ( Llet( - Strict, env_init, Lapply(Lvar class_init, [Lvar table]), + Strict, env_init, mkappl (Lvar class_init, [Lvar table]), Lsequence( - Lapply (oo_prim "init_class", [Lvar table]), + mkappl (oo_prim "init_class", [Lvar table]), Lprim(Pmakeblock(0, Immutable), - [Lapply(Lvar env_init, [lambda_unit]); + [mkappl (Lvar env_init, [lambda_unit]); Lvar class_init; Lvar env_init; lambda_unit])))) and lbody_virt lenvs = Lprim(Pmakeblock(0, Immutable), @@ -742,7 +746,7 @@ let transl_class ids cl_id arity pub_meths cl vflag = lam) and def_ids cla lam = Llet(StrictOpt, env2, - Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]), + mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]), lam) in let inh_paths = @@ -756,7 +760,7 @@ let transl_class ids cl_id arity pub_meths cl vflag = and lcache lam = if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else Llet(Strict, cached, - Lapply(oo_prim "lookup_tables", + mkappl (oo_prim "lookup_tables", [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]), lam) and lset cached i lam = @@ -765,7 +769,7 @@ let transl_class ids cl_id arity pub_meths cl vflag = let ldirect () = ltable cla (Llet(Strict, env_init, def_ids cla cl_init, - Lsequence(Lapply (oo_prim "init_class", [Lvar cla]), + Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), lset cached 0 (Lvar env_init)))) and lclass_virt () = lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init)) @@ -777,14 +781,14 @@ let transl_class ids cl_id arity pub_meths cl vflag = if ids = [] then ldirect () else if not concrete then lclass_virt () else lclass ( - Lapply (oo_prim "make_class_store", + mkappl (oo_prim "make_class_store", [transl_meth_list pub_meths; Lvar class_init; Lvar cached]))), make_envs ( - if ids = [] then Lapply(lfield cached 0, [lenvs]) else + if ids = [] then mkappl (lfield cached 0, [lenvs]) else Lprim(Pmakeblock(0, Immutable), if concrete then - [Lapply(lfield cached 0, [lenvs]); + [mkappl (lfield cached 0, [lenvs]); lfield cached 1; lfield cached 0; lenvs] diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 74a0064016..3e0ca8c3b8 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -202,6 +202,7 @@ let primitives_table = create_hashtable 57 [ "%obj_field", Parrayrefu Pgenarray; "%obj_set_field", Parraysetu Pgenarray; "%obj_is_int", Pisint; + "%lazy_force", Plazyforce; "%nativeint_of_int", Pbintofint Pnativeint; "%nativeint_to_int", Pintofbint Pnativeint; "%nativeint_neg", Pnegbint Pnativeint; @@ -250,12 +251,30 @@ let primitives_table = create_hashtable 57 [ "%int64_to_int32", Pcvtbint(Pint64, Pint32); "%int64_of_nativeint", Pcvtbint(Pnativeint, Pint64); "%int64_to_nativeint", Pcvtbint(Pint64, Pnativeint); - "%caml_ba_ref_1", Pbigarrayref(1, Pbigarray_unknown, Pbigarray_c_layout); - "%caml_ba_ref_2", Pbigarrayref(2, Pbigarray_unknown, Pbigarray_c_layout); - "%caml_ba_ref_3", Pbigarrayref(3, Pbigarray_unknown, Pbigarray_c_layout); - "%caml_ba_set_1", Pbigarrayset(1, Pbigarray_unknown, Pbigarray_c_layout); - "%caml_ba_set_2", Pbigarrayset(2, Pbigarray_unknown, Pbigarray_c_layout); - "%caml_ba_set_3", Pbigarrayset(3, Pbigarray_unknown, Pbigarray_c_layout) + "%caml_ba_ref_1", + Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_ref_2", + Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_ref_3", + Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_set_1", + Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_set_2", + Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_set_3", + Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_unsafe_ref_1", + Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_unsafe_ref_2", + Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_unsafe_ref_3", + Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_unsafe_set_1", + Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_unsafe_set_2", + Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_unsafe_set_3", + Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout) ] let prim_makearray = @@ -279,6 +298,12 @@ let transl_prim prim args = | [{exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}; arg2] when simplify_constant_constructor -> intcomp + | [arg1; {exp_desc = Texp_variant(_, None)}] + when simplify_constant_constructor -> + intcomp + | [{exp_desc = Texp_variant(_, None)}; exp2] + when simplify_constant_constructor -> + intcomp | [arg1; arg2] when has_base_type arg1 Predef.path_int || has_base_type arg1 Predef.path_char -> intcomp @@ -306,12 +331,14 @@ let transl_prim prim args = | (Parraysetu Pgenarray, arg1 :: _) -> Parraysetu(array_kind arg1) | (Parrayrefs Pgenarray, arg1 :: _) -> Parrayrefs(array_kind arg1) | (Parraysets Pgenarray, arg1 :: _) -> Parraysets(array_kind arg1) - | (Pbigarrayref(n, Pbigarray_unknown, _), arg1 :: _) -> + | (Pbigarrayref(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), + arg1 :: _) -> let (k, l) = bigarray_kind_and_layout arg1 in - Pbigarrayref(n, k, l) - | (Pbigarrayset(n, Pbigarray_unknown, _), arg1 :: _) -> + Pbigarrayref(unsafe, n, k, l) + | (Pbigarrayset(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), + arg1 :: _) -> let (k, l) = bigarray_kind_and_layout arg1 in - Pbigarrayset(n, k, l) + Pbigarrayset(unsafe, n, k, l) | _ -> p end with Not_found -> @@ -362,10 +389,15 @@ let transl_primitive p = Hashtbl.find primitives_table p.prim_name with Not_found -> Pccall p in - let rec make_params n = - if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in - let params = make_params p.prim_arity in - Lfunction(Curried, params, Lprim(prim, List.map (fun id -> Lvar id) params)) + match prim with + Plazyforce -> + let parm = Ident.create "prim" in + Lfunction(Curried, [parm], Matching.inline_lazy_force (Lvar parm) Location.none) + | _ -> + let rec make_params n = + if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in + let params = make_params p.prim_arity in + Lfunction(Curried, params, Lprim(prim, List.map (fun id -> Lvar id) params)) (* To check the well-formedness of r.h.s. of "let rec" definitions *) @@ -610,19 +642,22 @@ and transl_exp0 e = ({exp_desc = Texp_ident(path, {val_kind = Val_alone id})}, [Some arg,_]) -> - Lapply (Lvar id,[transl_exp arg]) + Lapply (Lvar id,[transl_exp arg],e.exp_loc) | Texp_apply ({exp_desc = Texp_ident(path, {val_kind = Val_channel (auto,idx)})}, [Some arg,_]) -> Transljoin.local_send_sync auto idx (transl_exp arg) (*<JOCAML*) - | 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 @@ -643,11 +678,16 @@ and transl_exp0 e = (Praise, [arg1]) -> wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)])) | (_, _) -> - let p = Lprim(prim, argl) in - if primitive_is_ccall prim then wrap p else wrap0 p + begin match (prim, argl) with + | (Plazyforce, [a]) -> + wrap (Matching.inline_lazy_force a e.exp_loc) + | (Plazyforce, _) -> assert false + |_ -> let p = Lprim(prim, argl) in + if primitive_is_ccall prim then wrap p else wrap0 p + end end | Texp_apply(funct, oargs) -> - event_after e (transl_apply (transl_exp funct) oargs) + event_after e (transl_apply (transl_exp funct) oargs e.exp_loc) | Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) -> Matching.for_multiple_match (id_lam,e.exp_loc) (transl_list transl_exp argl) @@ -764,7 +804,7 @@ and transl_exp0 e = in event_after e lam | Texp_new (cl, _) -> - Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit]) + Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none) | Texp_instvar(path_self, path) -> Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path]) | Texp_setinstvar(path_self, path, expr) -> @@ -772,7 +812,8 @@ and transl_exp0 e = | Texp_override(path_self, modifs) -> let cpy = Ident.create "copy" in Llet(Strict, cpy, - Lapply(Translobj.oo_prim "copy", [transl_path path_self]), + Lapply(Translobj.oo_prim "copy", [transl_path path_self], + Location.none), List.fold_right (fun (path, expr) rem -> Lsequence(transl_setinstvar (Lvar cpy) path expr, rem)) @@ -786,8 +827,55 @@ and transl_exp0 e = else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e.exp_loc) | Texp_assertfalse -> assert_failed e.exp_loc | Texp_lazy e -> - let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in - Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn]) + (* when e needs no computation (constants, identifiers, ...), we + optimize the translation just as Lazy.lazy_from_val would + do *) + begin match e.exp_desc with + (* a constant expr of type <> float gets compiled as itself *) + | Texp_constant + ( Const_int _ | Const_char _ | Const_string _ + | Const_int32 _ | Const_int64 _ | Const_nativeint _ ) + | Texp_function(_, _) + | Texp_construct ({cstr_arity = 0}, _) + -> transl_exp e + | Texp_constant(Const_float _) -> + Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]) + | Texp_ident(_, _) -> (* according to the type *) + begin match e.exp_type.desc with + | Tproc _ -> assert false (* By typing *) + (* 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 @@ -799,7 +887,7 @@ and transl_exp0 e = | Texp_spawn (e) -> transl_spawn e (*< JOCAML *) | _ -> - Location.print Format.err_formatter e.exp_loc ; + Location.print_error Format.err_formatter e.exp_loc ; fatal_error "Translcore.transl_exp" (*> JOCAML *) @@ -888,7 +976,7 @@ and transl_proc die sync p = match p.exp_desc with Texp_apply (_, _)|Texp_function (_, _)|Texp_constant _|Texp_ident (_, _)| Texp_assertfalse -> - Location.print Format.err_formatter p.exp_loc ; + Location.print_error Format.err_formatter p.exp_loc ; fatal_error "Translcore.transl_proc" (* @@ -1018,7 +1106,7 @@ and transl_dispatcher disp = if chan.jchannel_sync then match chan.jchannel_id with | Chan (name, i) -> Transljoin.local_send_sync name i (Lvar z) - | Alone g -> Lapply (Lvar g, [Lvar z]) + | Alone g -> Lapply (Lvar g, [Lvar z],Location.none) else match chan.jchannel_id with | Chan (name, i) -> Transljoin.local_tail_send_async name i @@ -1111,17 +1199,17 @@ and transl_cases transl_exp pat_expr_list = and transl_tupled_cases patl_expr_list = List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list -and transl_apply lam sargs = +and transl_apply lam sargs loc = let lapply funct args = match funct with Lsend(k, lmet, lobj, largs) -> Lsend(k, lmet, lobj, largs @ args) | Levent(Lsend(k, lmet, lobj, largs), _) -> Lsend(k, lmet, lobj, largs @ args) - | Lapply(lexp, largs) -> - Lapply(lexp, largs @ args) + | Lapply(lexp, largs, _) -> + Lapply(lexp, largs @ args, loc) | lexp -> - Lapply(lexp, args) + Lapply(lexp, args, loc) in let rec build_apply lam args = function (None, optional) :: l -> @@ -1163,7 +1251,8 @@ and transl_apply lam sargs = and transl_function loc untuplify_fn repr partial pat_expr_list = match pat_expr_list with - [pat, ({exp_desc = Texp_function(pl,partial')} as exp)] -> + [pat, ({exp_desc = Texp_function(pl,partial')} as exp)] + when Parmatch.fluid pat -> let param = name_pattern "param" pat_expr_list in let ((_, params), body) = transl_function exp.exp_loc false repr partial' pl in diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index 040d112956..a88bc5fcc6 100644 --- a/bytecomp/translcore.mli +++ b/bytecomp/translcore.mli @@ -23,7 +23,8 @@ open Lambda val name_pattern: string -> (pattern * 'a) list -> Ident.t val transl_exp: expression -> lambda -val transl_apply: lambda -> (expression option * optional) list -> lambda +val transl_apply: lambda -> (expression option * optional) list + -> Location.t -> lambda val transl_let: rec_flag -> (pattern * expression) list -> lambda -> lambda (*> JOCAML *) diff --git a/bytecomp/transljoin.ml b/bytecomp/transljoin.ml index ad56dd73eb..87f373efc4 100644 --- a/bytecomp/transljoin.ml +++ b/bytecomp/transljoin.ml @@ -96,7 +96,7 @@ let lambda_raise_join_exit = mk_lambda env_join "raise_join_exit" let mk_apply f args = match Lazy.force f with | _,{val_kind=Val_prim p} -> Lprim (Pccall p,args) -| path,_ -> Lapply (transl_path path, args) +| path,_ -> Lapply (transl_path path, args, Location.none) let lambda_int i = Lconst (Const_base (Const_int i)) @@ -141,7 +141,8 @@ and local_send_sync2 auto idx arg = mk_apply lambda_local_send_sync [Lvar auto ; idx ; arg] (* Those two are inlined *) -let local_tail_send_alone guard arg = Lapply (Lvar guard, [arg]) +let local_tail_send_alone guard arg = + Lapply (Lvar guard, [arg],Location.none) let local_send_alone guard arg = create_process @@ -258,7 +259,7 @@ let simple_prim = ref ((fun p -> assert false) : Primitive.description -> bool) let rec simple_pat p = match p.pat_desc with | Tpat_any | Tpat_var _ -> true -| Tpat_alias (p,_) -> simple_pat p +| Tpat_alias (p,_)|Tpat_lazy p -> simple_pat p | Tpat_tuple ps -> List.for_all simple_pat ps | Tpat_record lps -> List.for_all (fun (_,p) -> simple_pat p) lps | Tpat_or (p1,p2,_) -> simple_pat p1 && simple_pat p2 @@ -688,6 +689,11 @@ let rec explode = function xs [] +(* 3.10 -> 3.11, a third argument 'Location.t' appeared here, + just pretend it is not useful at the moment *) + +let lapply (f,args) = Lapply (f,args,Location.none) + (* gs is a list of compiled guarded processes *) let create_table auto gs r = @@ -732,8 +738,8 @@ let create_table auto gs r = Lfunction (Curried, [goid], build_lets bds - (Lapply - (Lvar goid, [Lvar name ; Lapply (Lvar g, args)]))) + (lapply + (Lvar goid, [Lvar name ; lapply (Lvar g, args)]))) else let pri_kont = let rec find_rec bds jpats = match bds, jpats with @@ -747,8 +753,8 @@ let create_table auto gs r = Lfunction (Curried, [goid], build_lets bds - (Lapply - (Lvar goid, [pri_kont ; Lapply (Lvar g, args)]))) in + (lapply + (Lvar goid, [pri_kont ; lapply (Lvar g, args)]))) in Lprim (Pmakeblock (0, Immutable), [build_mask n_chans names jpats ; diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index aa0d7db9ec..6c0e9db623 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -47,7 +47,8 @@ let rec apply_coercion restr arg = name_lambda arg (fun id -> Lfunction(Curried, [param], apply_coercion cc_res - (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)])))) + (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)], + Location.none)))) | Tcoerce_primitive p -> transl_primitive p @@ -79,8 +80,11 @@ let rec compose_coercions c1 c2 = (* Record the primitive declarations occuring in the module compiled *) -let primitive_declarations = ref ([] : string list) - +let primitive_declarations = ref ([] : Primitive.description list) +let record_primitive = function + | {val_kind=Val_prim p} -> primitive_declarations := p :: !primitive_declarations + | _ -> () + (* Keep track of the root path (from the root of the namespace to the currently compiled module expression). Useful for naming exceptions. *) @@ -202,7 +206,7 @@ let eval_rec_bindings bindings cont = | (id, None, rhs) :: rem -> bind_inits rem | (id, Some(loc, shape), rhs) :: rem -> - Llet(Strict, id, Lapply(mod_prim "init_mod", [loc; shape]), + Llet(Strict, id, Lapply(mod_prim "init_mod", [loc; shape], Location.none), bind_inits rem) and bind_strict = function [] -> @@ -217,7 +221,8 @@ let eval_rec_bindings bindings cont = | (id, None, rhs) :: rem -> patch_forwards rem | (id, Some(loc, shape), rhs) :: rem -> - Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs]), + Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs], + Location.none), patch_forwards rem) in bind_inits bindings @@ -258,7 +263,7 @@ let rec transl_module cc rootpath mexp = oo_wrap mexp.mod_env true (apply_coercion cc) (Lapply(transl_module Tcoerce_none None funct, - [transl_module ccarg None arg])) + [transl_module ccarg None arg], mexp.mod_loc)) | Tmod_constraint(arg, mty, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg @@ -299,11 +304,7 @@ and transl_structure fields cc rootpath = function transl_structure fields cc rootpath rem) (*< JOCAML *) | 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 @@ -345,7 +346,7 @@ and transl_structure fields cc rootpath = function | id :: ids -> Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]), rebind_idents (pos + 1) (id :: newfields) ids) in - Llet(Alias, mid, transl_module Tcoerce_none None modl, + Llet(Strict, mid, transl_module Tcoerce_none None modl, rebind_idents 0 fields ids) (* Update forward declaration in Translcore *) @@ -371,9 +372,21 @@ let transl_implementation module_name (str, cc) = "map" is a table from defined idents to (pos in global block, coercion). "prim" is a list of (pos in global block, primitive declaration). *) +let transl_store_subst = ref Ident.empty + (** In the native toplevel, this reference is threaded through successive + calls of transl_store_structure *) + +let nat_toplevel_name id = + try match Ident.find_same id !transl_store_subst with + | Lprim(Pfield pos, [Lprim(Pgetglobal glob, [])]) -> (glob,pos) + | _ -> raise Not_found + with Not_found -> + fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id) + let transl_store_structure glob map prims str = let rec transl_store subst = function [] -> + transl_store_subst := subst; lambda_unit | Tstr_eval expr :: rem -> Lsequence(subst_lambda subst (transl_exp expr), @@ -399,11 +412,7 @@ let transl_store_structure glob map prims str = Lsequence (subst_lambda subst lam, transl_store subst rem) (*< JOCAML *) | 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 @@ -493,7 +502,7 @@ let transl_store_structure glob map prims str = [Lprim(Pgetglobal glob, []); transl_primitive prim]), cont) - in List.fold_right store_primitive prims (transl_store Ident.empty str) + in List.fold_right store_primitive prims (transl_store !transl_store_subst str) (* Build the list of value identifiers defined by a toplevel structure (excluding primitive declarations). *) @@ -557,18 +566,32 @@ let build_ident_map restr idlist = | _ -> fatal_error "Translmod.build_ident_map" -(* Compile an implementation using transl_store_structure +(* Compile an implementation using transl_store_structure (for the native-code compiler). *) -let transl_store_implementation module_name (str, restr) = +let transl_store_gen module_name (str, restr) topl = reset_labels (); primitive_declarations := []; let module_id = Ident.create_persistent module_name in let (map, prims, size) = build_ident_map restr (defined_idents str) in - transl_store_label_init module_id size - (transl_store_structure module_id map prims) str + let f = function + | [ Tstr_eval expr ] when topl -> + assert (size = 0); + subst_lambda !transl_store_subst (transl_exp expr) + | str -> transl_store_structure module_id map prims str in + transl_store_label_init module_id size f str (*size, transl_label_init (transl_store_structure module_id map prims str)*) +let transl_store_phrases module_name str = + transl_store_gen module_name (str,Tcoerce_none) true + +let transl_store_implementation module_name (str, restr) = + let s = !transl_store_subst in + transl_store_subst := Ident.empty; + let r = transl_store_gen module_name (str, restr) false in + transl_store_subst := s; + r + (* Compile a toplevel phrase *) let toploop_ident = Ident.create_persistent "Toploop" @@ -588,12 +611,14 @@ let toplevel_name id = let toploop_getvalue id = Lapply(Lprim(Pfield toploop_getvalue_pos, [Lprim(Pgetglobal toploop_ident, [])]), - [Lconst(Const_base(Const_string (toplevel_name id)))]) + [Lconst(Const_base(Const_string (toplevel_name id)))], + Location.none) let toploop_setvalue id lam = Lapply(Lprim(Pfield toploop_setvalue_pos, [Lprim(Pgetglobal toploop_ident, [])]), - [Lconst(Const_base(Const_string (toplevel_name id))); lam]) + [Lconst(Const_base(Const_string (toplevel_name id))); lam], + Location.none) let toploop_setvalue_id id = toploop_setvalue id (Lvar id) @@ -677,7 +702,7 @@ let transl_toplevel_definition str = let get_component = function None -> Lconst const_unit - | Some id -> Lprim(Pgetglobal id, []) + | Some id -> Lprim(Pgetglobal id, []) let transl_package component_names target_name coercion = let components = diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli index 7a2aa5a0f2..bec880b2f9 100644 --- a/bytecomp/translmod.mli +++ b/bytecomp/translmod.mli @@ -19,6 +19,7 @@ open Typedtree open Lambda val transl_implementation: string -> structure * module_coercion -> lambda +val transl_store_phrases: string -> structure -> int * lambda val transl_store_implementation: string -> structure * module_coercion -> int * lambda val transl_toplevel_definition: structure -> lambda @@ -28,8 +29,9 @@ val transl_store_package: Ident.t option list -> Ident.t -> module_coercion -> int * lambda val toplevel_name: Ident.t -> string +val nat_toplevel_name: Ident.t -> Ident.t * int -val primitive_declarations: string list ref +val primitive_declarations: Primitive.description list ref type error = Circular_dependency of Ident.t diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index b49516d0d9..8a49ea16ba 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -22,28 +22,24 @@ open Types open Typedtree open Lambda -let is_base_type ty env base_ty_path = - let ty = - Ctype.expand_head env (Ctype.correct_levels ty) in - match Ctype.repr ty with +let has_base_type exp base_ty_path = + let exp_ty = + 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 has_base_type exp base_ty_path = - is_base_type exp.exp_type exp.exp_env base_ty_path - - 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 @@ -54,9 +50,9 @@ let maybe_pointer exp = | _ -> true let array_element_kind env ty = - let ty = Ctype.repr (Ctype.expand_head env ty) in + let ty = Ctype.repr (Ctype.expand_head_opt env ty) in match ty.desc with - Tvar -> + Tvar | Tunivar -> Pgenarray | Tconstr(p, args, abbrev) -> if Path.same p Predef.path_int || Path.same p Predef.path_char then @@ -74,7 +70,7 @@ let array_element_kind env ty = match Env.find_type p env with {type_kind = Type_abstract} -> Pgenarray - | {type_kind = Type_variant(cstrs, _)} + | {type_kind = Type_variant cstrs} when List.for_all (fun (name, args) -> args = []) cstrs -> Pintarray | {type_kind = _} -> @@ -89,7 +85,7 @@ let array_element_kind env ty = Paddrarray let array_kind_gen ty env = - let array_ty = Ctype.expand_head env (Ctype.correct_levels ty) in + let array_ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in match (Ctype.repr array_ty).desc with Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _) when Path.same p Predef.path_array -> @@ -129,7 +125,7 @@ let layout_table = "fortran_layout", Pbigarray_fortran_layout] let bigarray_kind_and_layout exp = - let ty = Ctype.repr (Ctype.expand_head exp.exp_env exp.exp_type) in + let ty = Ctype.repr (Ctype.expand_head_opt exp.exp_env exp.exp_type) in match ty.desc with Tconstr(p, [caml_type; elt_type; layout_type], abbrev) -> (bigarray_decode_type elt_type kind_table Pbigarray_unknown, @@ -138,11 +134,15 @@ let bigarray_kind_and_layout exp = (Pbigarray_unknown, Pbigarray_unknown_layout) let is_unit_channel_type ty env = - let channel_ty = Ctype.expand_head env (Ctype.correct_levels ty) in - match (Ctype.repr channel_ty).desc with + let channel_ty =Ctype.repr (Ctype.expand_head_opt env ty) in + match channel_ty.desc with | Tconstr(p, [msg_ty], _) (* when Path.same p Predef.path_channel *) -> - is_base_type msg_ty env Predef.path_unit + let msg_ty = Ctype.repr (Ctype.expand_head_opt env msg_ty) in + begin match msg_ty.desc with + | Tconstr (p,[],_) when Path.same p Predef.path_unit -> true + | _ -> false + end | _ -> (* This can happen with synchronous channels *) false diff --git a/byterun/.cvsignore b/byterun/.cvsignore index 90636dc158..9020f408e2 100644 --- a/byterun/.cvsignore +++ b/byterun/.cvsignore @@ -14,3 +14,4 @@ ocamlrun.dbg interp.a.lst *.[sd]obj *.lib +.gdb_history diff --git a/byterun/.depend b/byterun/.depend index 43277c13ee..9e2a3d100a 100644 --- a/byterun/.depend +++ b/byterun/.depend @@ -6,8 +6,8 @@ array.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ minor_gc.h backtrace.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - fix_code.h exec.h startup.h stacks.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h sys.h backtrace.h + fix_code.h exec.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + startup.h stacks.h sys.h backtrace.h callback.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h @@ -43,14 +43,15 @@ floats.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h reverse.h stacks.h freelist.o: freelist.c config.h ../config/m.h ../config/s.h \ - compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h major_gc.h + compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ + major_gc.h minor_gc.h gc_ctrl.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ stacks.h globroots.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - globroots.h + roots.h globroots.h hash.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h @@ -87,7 +88,7 @@ meta.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h minor_gc.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 + gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h misc.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.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ @@ -104,13 +105,13 @@ printexc.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ roots.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_byt.o: signals_byt.c config.h ../config/m.h ../config/s.h \ + compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ + minor_gc.h osdeps.h signals.h signals_machdep.h signals.o: signals.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ sys.h -signals_byt.o: signals_byt.c config.h ../config/m.h ../config/s.h \ - compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ - minor_gc.h osdeps.h signals.h signals_machdep.h stacks.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h @@ -141,8 +142,8 @@ array.d.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ minor_gc.h backtrace.d.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - fix_code.h exec.h startup.h stacks.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h sys.h backtrace.h + fix_code.h exec.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + startup.h stacks.h sys.h backtrace.h callback.d.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h @@ -178,14 +179,15 @@ floats.d.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h reverse.h stacks.h freelist.d.o: freelist.c config.h ../config/m.h ../config/s.h \ - compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h major_gc.h + compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ + major_gc.h minor_gc.h gc_ctrl.d.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ stacks.h globroots.d.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - globroots.h + roots.h globroots.h hash.d.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h @@ -224,7 +226,7 @@ meta.d.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h minor_gc.d.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 + gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h misc.d.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.d.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ @@ -241,13 +243,13 @@ printexc.d.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ roots.d.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_byt.d.o: signals_byt.c config.h ../config/m.h ../config/s.h \ + compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ + minor_gc.h osdeps.h signals.h signals_machdep.h signals.d.o: signals.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ sys.h -signals_byt.d.o: signals_byt.c config.h ../config/m.h ../config/s.h \ - compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ - minor_gc.h osdeps.h signals.h signals_machdep.h stacks.d.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h @@ -270,3 +272,139 @@ unix.d.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ weak.d.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ minor_gc.h +alloc.pic.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ + minor_gc.h stacks.h +array.pic.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h +backtrace.pic.o: backtrace.c config.h ../config/m.h ../config/s.h \ + compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ + fix_code.h exec.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + startup.h stacks.h sys.h backtrace.h +callback.pic.o: callback.c callback.h compatibility.h mlvalues.h config.h \ + ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h +compact.pic.o: compact.c config.h ../config/m.h ../config/s.h compatibility.h \ + finalise.h roots.h misc.h memory.h gc.h mlvalues.h major_gc.h \ + freelist.h minor_gc.h gc_ctrl.h weak.h +compare.pic.o: compare.c custom.h compatibility.h mlvalues.h config.h \ + ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h +custom.pic.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h +debugger.pic.o: debugger.c config.h ../config/m.h ../config/s.h \ + compatibility.h debugger.h misc.h mlvalues.h fail.h fix_code.h \ + instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h sys.h +dynlink.pic.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ + alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h osdeps.h prims.h +extern.pic.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ + memory.h major_gc.h freelist.h minor_gc.h reverse.h +fail.pic.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ + freelist.h minor_gc.h printexc.h signals.h stacks.h +finalise.pic.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ + ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h signals.h +fix_code.pic.o: fix_code.c config.h ../config/m.h ../config/s.h \ + compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ + md5.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h reverse.h +floats.pic.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h reverse.h stacks.h +freelist.pic.o: freelist.c config.h ../config/m.h ../config/s.h \ + compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ + major_gc.h minor_gc.h +gc_ctrl.pic.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ + ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ + roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ + stacks.h +globroots.pic.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ + ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ + roots.h globroots.h +hash.pic.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ + ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h +instrtrace.pic.o: instrtrace.c +intern.pic.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ + memory.h major_gc.h freelist.h minor_gc.h reverse.h +interp.pic.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ + fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ + memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h +ints.pic.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h custom.h fail.h intext.h io.h fix_code.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h int64_native.h +io.pic.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ + misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h signals.h sys.h +lexing.pic.o: lexing.c fail.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h +main.pic.o: main.c misc.h compatibility.h config.h ../config/m.h \ + ../config/s.h mlvalues.h sys.h +major_gc.pic.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ + compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h +md5.pic.o: md5.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h reverse.h +memory.pic.o: memory.c fail.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ + minor_gc.h signals.h +meta.pic.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ + major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h +minor_gc.pic.o: minor_gc.c config.h ../config/m.h ../config/s.h \ + compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ + gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h +misc.pic.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ + misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h +obj.pic.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ + memory.h minor_gc.h prims.h +parsing.pic.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \ + mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + alloc.h +prims.pic.o: prims.c mlvalues.h compatibility.h config.h ../config/m.h \ + ../config/s.h misc.h prims.h +printexc.pic.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ + ../config/m.h ../config/s.h misc.h callback.h debugger.h fail.h \ + printexc.h +roots.pic.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \ + ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ + freelist.h minor_gc.h globroots.h stacks.h +signals_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 +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 +stacks.pic.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ + fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h +startup.pic.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ + alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ + dynlink.h exec.h fail.h fix_code.h gc_ctrl.h instrtrace.h interp.h \ + intext.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h osdeps.h \ + prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ + version.h +str.pic.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h +sys.pic.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ + misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ + stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h +terminfo.pic.o: terminfo.c config.h ../config/m.h ../config/s.h \ + compatibility.h alloc.h misc.h mlvalues.h fail.h io.h +unix.pic.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ + memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ + osdeps.h +weak.pic.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ + minor_gc.h diff --git a/byterun/Makefile b/byterun/Makefile index a33a019604..9ee6a69d0d 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -13,53 +13,31 @@ # $Id$ -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)/jocamlrun$(EXE) - cp libcamlrun.a $(LIBDIR)/libcamlrun.a - cd $(LIBDIR); $(RANLIB) libcamlrun.a - if test -d $(LIBDIR)/caml; then : ; else mkdir $(LIBDIR)/caml; fi - for i in $(PUBLIC_INCLUDES); do \ - sed -f ../tools/cleanup-header $$i > $(LIBDIR)/caml/$$i; \ - done - cp ld.conf $(LIBDIR)/ld.conf - -ld.conf: ../config/Makefile - echo "$(STUBLIBDIR)" >ld.conf - echo "$(LIBDIR)" >>ld.conf + $(MKEXE) -g $(BYTECCLINKOPTS) -o ocamlrund$(EXE) \ + prims.o libcamlrund.a $(BYTECCLIBS) libcamlrun.a: $(OBJS) ar rc libcamlrun.a $(OBJS) @@ -69,42 +47,10 @@ libcamlrund.a: $(DOBJS) ar rc libcamlrund.a $(DOBJS) $(RANLIB) libcamlrund.a -clean: - rm -f ocamlrun$(EXE) ocamlrund$(EXE) *.o lib*.a - rm -f primitives prims.c opnames.h jumptbl.h ld.conf - rm -f version.h - -primitives : $(PRIMS) - sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" \ - $(PRIMS) > primitives - -prims.c : primitives - (echo '#include "mlvalues.h"'; \ - echo '#include "prims.h"'; \ - sed -e 's/.*/extern value &();/' primitives; \ - echo 'c_primitive caml_builtin_cprim[] = {'; \ - sed -e 's/.*/ &,/' primitives; \ - echo ' 0 };'; \ - echo 'char * caml_names_of_builtin_cprim[] = {'; \ - sed -e 's/.*/ "&",/' primitives; \ - echo ' 0 };') > prims.c - -opnames.h : instruct.h - sed -e '/\/\*/d' \ - -e '/^#/d' \ - -e 's/enum /char * names_of_/' \ - -e 's/{$$/[] = {/' \ - -e 's/\([[:upper:]][[:upper:]_0-9]*\)/"\1"/g' instruct.h > opnames.h - -# jumptbl.h is required only if you have GCC 2.0 or later -jumptbl.h : instruct.h - sed -n -e '/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp' \ - -e '/^}/q' instruct.h > jumptbl.h - -version.h : ../VERSION - echo "#define OCAML_VERSION \"`head -1 ../VERSION`\"" >version.h - -.SUFFIXES: .d.o +libcamlrun_shared.so: $(PICOBJS) + $(MKDLL) -o libcamlrun_shared.so $(PICOBJS) + +.SUFFIXES: .d.o .pic.o .c.d.o: @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi @@ -112,8 +58,16 @@ version.h : ../VERSION mv $*.o $*.d.o @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi +.c.pic.o: + @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi + $(CC) -c $(CFLAGS) $(SHAREDCCCOMPOPTS) $< + mv $*.o $*.pic.o + @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi + depend : prims.c opnames.h jumptbl.h version.h -gcc -MM $(BYTECCCOMPOPTS) *.c > .depend -gcc -MM $(BYTECCCOMPOPTS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend + -gcc -MM $(BYTECCCOMPOPTS) *.c | sed -e 's/\.o/.pic.o/' >> .depend +.PHONY: depend include .depend diff --git a/byterun/Makefile.common b/byterun/Makefile.common index bac885f1ce..2546cf661f 100755 --- a/byterun/Makefile.common +++ b/byterun/Makefile.common @@ -45,7 +45,7 @@ ld.conf: ../config/Makefile echo "$(LIBDIR)" >> ld.conf install:: - cp ocamlrun$(EXE) $(BINDIR)/ocamlrun$(EXE) + cp ocamlrun$(EXE) $(BINDIR)/jocamlrun$(EXE) cp libcamlrun.$(A) $(LIBDIR)/libcamlrun.$(A) cd $(LIBDIR); $(RANLIB) libcamlrun.$(A) if test -d $(LIBDIR)/caml; then : ; else mkdir $(LIBDIR)/caml; fi diff --git a/byterun/Makefile.nt b/byterun/Makefile.nt index 3338e618db..455de6fa6c 100644 --- a/byterun/Makefile.nt +++ b/byterun/Makefile.nt @@ -13,105 +13,42 @@ # $Id$ -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)/jocamlrun.exe - cp ocamlrun.dll $(BINDIR)/jocamlrun.dll - cp ocamlrun.$(A) $(LIBDIR)/ocamlrun.$(A) - cp libcamlrun.$(A) $(LIBDIR)/libcamlrun.$(A) - test -d $(LIBDIR)/caml || mkdir -p $(LIBDIR)/caml - for i in $(PUBLIC_INCLUDES); do sed -f ../tools/cleanup-header $$i > $(LIBDIR)/caml/$$i; done - -clean: - rm -f *.exe *.dll *.$(O) *.$(A) - rm -f primitives prims.c opnames.h jumptbl.h - -primitives : $(PRIMS) - sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" \ - $(PRIMS) > primitives - -prims.c : primitives - (echo '#include "mlvalues.h"'; \ - echo '#include "prims.h"'; \ - sed -e 's/.*/extern value &();/' primitives; \ - echo 'c_primitive caml_builtin_cprim[] = {'; \ - sed -e 's/.*/ &,/' primitives; \ - echo ' 0 };'; \ - echo 'char * caml_names_of_builtin_cprim[] = {'; \ - sed -e 's/.*/ "&",/' primitives; \ - echo ' 0 };') > prims.c - -opnames.h : instruct.h - sed -e '/\/\*/d' \ - -e '/^#/d' \ - -e 's/enum /char * names_of_/' \ - -e 's/{$$/[] = {/' \ - -e 's/\([[:upper:]][[:upper:]_0-9]*\)/"\1"/g' instruct.h > opnames.h - -# jumptbl.h is required only if you have GCC 2.0 or later -jumptbl.h : instruct.h - sed -n -e "/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp" \ - -e "/^}/q" instruct.h > jumptbl.h - -version.h : ../VERSION - echo "#define OCAML_VERSION \"`head -1 ../VERSION`\"" >version.h - -main.$(DO): main.c - $(CC) $(DLLCCCOMPOPTS) -c main.c - mv main.$(O) main.$(DO) - -.SUFFIXES: .$(DO) .$(SO) .$(DBGO) - -.c.$(DO): - $(CC) $(CFLAGS) $(DLLCCCOMPOPTS) -c $< - mv $*.$(O) $*.$(DO) -.c.$(SO): +.c.$(O): $(CC) $(CFLAGS) $(BYTECCCOMPOPTS) -c $< - mv $*.$(O) $*.$(SO) + .c.$(DBGO): $(CC) $(CFLAGS) $(BYTECCDBGCOMPOPTS) -c $< mv $*.$(O) $*.$(DBGO) .depend.nt: .depend - sed -e '/\.d\.o/q' -e 's/^\(.*\)\.o:/\1.$$(DO) \1.$$(SO) \1.$$(DBGO):/' .depend > .depend.nt + rm -f .depend.win32 + echo "win32.o: win32.c fail.h compatibility.h misc.h config.h \\" >> .depend.win32 + echo " ../config/m.h ../config/s.h mlvalues.h memory.h gc.h \\" >> .depend.win32 + echo " major_gc.h freelist.h minor_gc.h osdeps.h signals.h" >> .depend.win32 + cat .depend >> .depend.win32 + sed -e '/\.d\.o/q' -e 's/^\(.*\)\.o:/\1.$$(O) \1.$$(DBGO):/' .depend.win32 > .depend.nt + rm -f .depend.win32 include .depend.nt diff --git a/byterun/array.c b/byterun/array.c index 468fe444a4..e282f0600e 100644 --- a/byterun/array.c +++ b/byterun/array.c @@ -21,8 +21,6 @@ #include "misc.h" #include "mlvalues.h" -#ifndef NATIVE_CODE - CAMLprim value caml_array_get_addr(value array, value index) { intnat idx = Long_val(index); @@ -125,8 +123,6 @@ CAMLprim value caml_array_unsafe_set(value array, value index, value newval) return caml_array_unsafe_set_addr(array, index, newval); } -#endif - CAMLprim value caml_make_vect(value len, value init) { CAMLparam2 (len, init); @@ -139,7 +135,7 @@ CAMLprim value caml_make_vect(value len, value init) res = Atom(0); } else if (Is_block(init) - && (Is_atom(init) || Is_young(init) || Is_in_heap(init)) + && Is_in_value_area(init) && Tag_val(init) == Double_tag) { d = Double_val(init); wsize = size * Double_wosize; @@ -181,7 +177,7 @@ CAMLprim value caml_make_array(value init) } else { v = Field(init, 0); if (Is_long(v) - || (!Is_atom(v) && !Is_young(v) && !Is_in_heap(v)) + || ! Is_in_value_area(v) || Tag_val(v) != Double_tag) { CAMLreturn (init); } else { diff --git a/byterun/backtrace.c b/byterun/backtrace.c index 2606020de2..2e645ab512 100644 --- a/byterun/backtrace.c +++ b/byterun/backtrace.c @@ -29,6 +29,7 @@ #include "intext.h" #include "exec.h" #include "fix_code.h" +#include "memory.h" #include "startup.h" #include "stacks.h" #include "sys.h" @@ -59,14 +60,32 @@ enum { POS_CNUM = 3 }; -/* Initialize the backtrace machinery */ +/* Start or stop the backtrace machinery */ -void caml_init_backtrace(void) +CAMLprim value caml_record_backtrace(value vflag) { - caml_backtrace_active = 1; - caml_register_global_root(&caml_backtrace_last_exn); - /* Note: lazy initialization of caml_backtrace_buffer in caml_stash_backtrace - to simplify the interface with the thread libraries */ + int flag = Int_val(vflag); + + if (flag != caml_backtrace_active) { + caml_backtrace_active = flag; + caml_backtrace_pos = 0; + if (flag) { + caml_register_global_root(&caml_backtrace_last_exn); + } else { + caml_remove_global_root(&caml_backtrace_last_exn); + } + /* Note: lazy initialization of caml_backtrace_buffer in + caml_stash_backtrace to simplify the interface with the thread + libraries */ + } + return Val_unit; +} + +/* Return the status of the backtrace machinery */ + +CAMLprim value caml_backtrace_status(value vunit) +{ + return Val_bool(caml_backtrace_active); } /* Store the return addresses contained in the given stack fragment @@ -166,18 +185,50 @@ static value event_for_location(value events, code_t pc) return Val_false; } -/* Print the location corresponding to the given PC */ +/* Extract location information for the given PC */ + +struct loc_info { + int loc_valid; + int loc_is_raise; + char * loc_filename; + int loc_lnum; + int loc_startchr; + int loc_endchr; +}; -static void print_location(value events, int index) +static void extract_location_info(value events, code_t pc, + /*out*/ struct loc_info * li) { - code_t pc = caml_backtrace_buffer[index]; - char * info; - value ev; + value ev, ev_start; ev = event_for_location(events, pc); - if (caml_is_instruction(*pc, RAISE)) { - /* Ignore compiler-inserted raise */ - if (ev == Val_false) return; + li->loc_is_raise = caml_is_instruction(*pc, RAISE); + if (ev == Val_false) { + li->loc_valid = 0; + return; + } + li->loc_valid = 1; + ev_start = Field (Field (ev, EV_LOC), LOC_START); + li->loc_filename = String_val (Field (ev_start, POS_FNAME)); + li->loc_lnum = Int_val (Field (ev_start, POS_LNUM)); + li->loc_startchr = + Int_val (Field (ev_start, POS_CNUM)) + - Int_val (Field (ev_start, POS_BOL)); + li->loc_endchr = + Int_val (Field (Field (Field (ev, EV_LOC), LOC_END), POS_CNUM)) + - Int_val (Field (ev_start, POS_BOL)); +} + +/* Print location information */ + +static void print_location(struct loc_info * li, int index) +{ + char * info; + + /* Ignore compiler-inserted raise */ + if (!li->loc_valid && li->loc_is_raise) return; + + if (li->loc_is_raise) { /* Initial raise if index == 0, re-raise otherwise */ if (index == 0) info = "Raised at"; @@ -189,18 +240,12 @@ static void print_location(value events, int index) else info = "Called from"; } - if (ev == Val_false) { + if (! li->loc_valid) { fprintf(stderr, "%s unknown location\n", info); } else { - value ev_start = Field (Field (ev, EV_LOC), LOC_START); - char *fname = String_val (Field (ev_start, POS_FNAME)); - int lnum = Int_val (Field (ev_start, POS_LNUM)); - int startchr = Int_val (Field (ev_start, POS_CNUM)) - - Int_val (Field (ev_start, POS_BOL)); - int endchr = Int_val (Field (Field (Field (ev, EV_LOC), LOC_END), POS_CNUM)) - - Int_val (Field (ev_start, POS_BOL)); - fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n", info, fname, - lnum, startchr, endchr); + fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n", + info, li->loc_filename, li->loc_lnum, + li->loc_startchr, li->loc_endchr); } } @@ -210,6 +255,7 @@ CAMLexport void caml_print_exception_backtrace(void) { value events; int i; + struct loc_info li; events = read_debug_info(); if (events == Val_false) { @@ -217,6 +263,44 @@ CAMLexport void caml_print_exception_backtrace(void) "(Program not linked with -g, cannot print stack backtrace)\n"); return; } - for (i = 0; i < caml_backtrace_pos; i++) - print_location(events, i); + for (i = 0; i < caml_backtrace_pos; i++) { + extract_location_info(events, caml_backtrace_buffer[i], &li); + print_location(&li, i); + } +} + +/* Convert the backtrace to a data structure usable from Caml */ + +CAMLprim value caml_get_exception_backtrace(value unit) +{ + CAMLparam0(); + CAMLlocal5(events, res, arr, p, fname); + int i; + struct loc_info li; + + events = read_debug_info(); + if (events == Val_false) { + res = Val_int(0); /* None */ + } else { + arr = caml_alloc(caml_backtrace_pos, 0); + for (i = 0; i < caml_backtrace_pos; i++) { + extract_location_info(events, caml_backtrace_buffer[i], &li); + if (li.loc_valid) { + fname = caml_copy_string(li.loc_filename); + p = caml_alloc_small(5, 0); + Field(p, 0) = Val_bool(li.loc_is_raise); + Field(p, 1) = fname; + Field(p, 2) = Val_int(li.loc_lnum); + Field(p, 3) = Val_int(li.loc_startchr); + Field(p, 4) = Val_int(li.loc_endchr); + } else { + p = caml_alloc_small(1, 1); + Field(p, 0) = Val_bool(li.loc_is_raise); + } + caml_modify(&Field(arr, i), p); + } + res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ + } + CAMLreturn(res); } + diff --git a/byterun/backtrace.h b/byterun/backtrace.h index 3e35b434f3..c2a21c2088 100644 --- a/byterun/backtrace.h +++ b/byterun/backtrace.h @@ -23,7 +23,7 @@ CAMLextern int caml_backtrace_pos; CAMLextern code_t * caml_backtrace_buffer; CAMLextern value caml_backtrace_last_exn; -extern void caml_init_backtrace(void); +CAMLprim value caml_record_backtrace(value vflag); #ifndef NATIVE_CODE extern void caml_stash_backtrace(value exn, code_t pc, value * sp); #endif diff --git a/byterun/compact.c b/byterun/compact.c index a6860d529c..ba1042fbe5 100644 --- a/byterun/compact.c +++ b/byterun/compact.c @@ -38,7 +38,7 @@ extern void caml_shrink_heap (char *); /* memory.c */ 1: integer or (unencoded) infix header 2: inverted pointer for infix header 3: integer or encoded (noninfix) header - + XXX Should be fixed: XXX The above assumes that all roots are aligned on a 4-byte boundary, XXX which is not always guaranteed by C. @@ -60,7 +60,7 @@ static void invert_pointer_at (word *p) /* Use Ecolor (q) == 0 instead of Is_block (q) because q could be an inverted pointer for an infix header (with Ecolor == 2). */ - if (Ecolor (q) == 0 && Is_in_heap (q)){ + if (Ecolor (q) == 0 && (Classify_addr (q) & In_heap)){ switch (Ecolor (Hd_val (q))){ case 0: case 3: /* Pointer or header: insert in inverted list. */ @@ -203,7 +203,7 @@ void caml_compact_heap (void) while (Ecolor (q) == 0) q = * (word *) q; sz = Whsize_ehd (q); t = Tag_ehd (q); - + if (t == Infix_tag){ /* Get the original header of this block. */ infixes = p + sz; @@ -252,18 +252,18 @@ void caml_compact_heap (void) ch = caml_heap_start; while (ch != NULL){ word *p = (word *) ch; - + chend = ch + Chunk_size (ch); while ((char *) p < chend){ word q = *p; - + if (Ecolor (q) == 0 || Tag_ehd (q) == Infix_tag){ /* There were (normal or infix) pointers to this block. */ size_t sz; tag_t t; char *newadr; word *infixes = NULL; - + while (Ecolor (q) == 0) q = * (word *) q; sz = Whsize_ehd (q); t = Tag_ehd (q); @@ -393,7 +393,7 @@ void caml_compact_heap (void) caml_gc_message (0x10, "done.\n", 0); } -uintnat caml_percent_max; /* used in gc_ctrl.c */ +uintnat caml_percent_max; /* used in gc_ctrl.c and memory.c */ void caml_compact_heap_maybe (void) { @@ -408,7 +408,7 @@ void caml_compact_heap_maybe (void) float fw, fp; Assert (caml_gc_phase == Phase_idle); if (caml_percent_max >= 1000000) return; - if (caml_stat_major_collections < 5 || caml_stat_heap_chunks < 2) return; + if (caml_stat_major_collections < 3 || caml_stat_heap_chunks < 3) return; fw = 3.0 * caml_fl_cur_size - 2.0 * caml_fl_size_at_phase_change; if (fw < 0) fw = caml_fl_cur_size; diff --git a/byterun/compare.c b/byterun/compare.c index 4cd6df29ea..35a7f66ce9 100644 --- a/byterun/compare.c +++ b/byterun/compare.c @@ -104,7 +104,7 @@ static intnat compare_val(value v1, value v2, int total) if (Is_long(v2)) return Long_val(v1) - Long_val(v2); /* Subtraction above cannot overflow and cannot result in UNORDERED */ - if ((Is_atom(v2) || Is_young(v2) || Is_in_heap(v2)) && + if (Is_in_value_area(v2) && Tag_val(v2) == Forward_tag) { v2 = Forward_val(v2); continue; @@ -112,7 +112,7 @@ static intnat compare_val(value v1, value v2, int total) return LESS; /* v1 long < v2 block */ } if (Is_long(v2)) { - if ((Is_atom(v1) || Is_young(v1) || Is_in_heap(v1)) && + if (Is_in_value_area(v1) && Tag_val(v1) == Forward_tag) { v1 = Forward_val(v1); continue; @@ -122,8 +122,7 @@ static intnat compare_val(value v1, value v2, int total) /* If one of the objects is outside the heap (but is not an atom), use address comparison. Since both addresses are 2-aligned, shift lsb off to avoid overflow in subtraction. */ - if ((!Is_atom(v1) && !Is_young(v1) && !Is_in_heap(v1)) || - (!Is_atom(v2) && !Is_young(v2) && !Is_in_heap(v2))) { + if (! Is_in_value_area(v1) || ! Is_in_value_area(v2)) { if (v1 == v2) goto next_item; return (v1 >> 1) - (v2 >> 1); /* Subtraction above cannot result in UNORDERED */ @@ -269,14 +268,14 @@ CAMLprim value caml_lessthan(value v1, value v2) { intnat res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); - return Val_int(res - 1 < -1); + return Val_int(res < 0 && res != UNORDERED); } CAMLprim value caml_lessequal(value v1, value v2) { intnat res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); - return Val_int(res - 1 <= -1); + return Val_int(res <= 0 && res != UNORDERED); } CAMLprim value caml_greaterthan(value v1, value v2) diff --git a/byterun/compatibility.h b/byterun/compatibility.h index 78860756dd..5c21774e06 100644 --- a/byterun/compatibility.h +++ b/byterun/compatibility.h @@ -211,7 +211,6 @@ /* **** major_gc.c */ #define heap_start caml_heap_start -#define heap_end caml_heap_end #define page_table caml_page_table /* **** md5.c */ @@ -237,8 +236,7 @@ #define young_end caml_young_end #define young_ptr caml_young_ptr #define young_limit caml_young_limit -#define ref_table_ptr caml_ref_table_ptr -#define ref_table_limit caml_ref_table_limit +#define ref_table caml_ref_table #define minor_collection caml_minor_collection #define check_urgent_gc caml_check_urgent_gc diff --git a/byterun/config.h b/byterun/config.h index 25681e7f5b..00c70978f1 100644 --- a/byterun/config.h +++ b/byterun/config.h @@ -107,7 +107,7 @@ typedef struct { uint32 l, h; } uint64, int64; /* Memory model parameters */ /* The size of a page for memory management (in bytes) is [1 << Page_log]. - It must be a multiple of [sizeof (value)]. */ + It must be a multiple of [sizeof (value)] and >= 8. */ #define Page_log 12 /* A page is 4 kilobytes. */ /* Initial size of stack (bytes). */ @@ -143,12 +143,13 @@ typedef struct { uint32 l, h; } uint64, int64; #define Heap_chunk_min (2 * Page_size / sizeof (value)) /* Default size increment when growing the heap. (words) - Must be a multiple of [Page_size / sizeof (value)]. */ -#define Heap_chunk_def (15 * Page_size) + Must be a multiple of [Page_size / sizeof (value)]. + (Approx 512 Kb for a 32-bit platform, 1 Mb for a 64-bit platform.) */ +#define Heap_chunk_def (31 * Page_size) /* Default initial size of the major heap (words); same constraints as for Heap_chunk_def. */ -#define Init_heap_def (15 * Page_size) +#define Init_heap_def (31 * Page_size) /* Default speed setting for the major GC. The heap will grow until diff --git a/byterun/debugger.c b/byterun/debugger.c index df399fc896..38b1923e6e 100644 --- a/byterun/debugger.c +++ b/byterun/debugger.c @@ -15,6 +15,10 @@ /* Interface with the debugger */ +#ifdef _WIN32 +#include <io.h> +#endif /* _WIN32 */ + #include <string.h> #include "config.h" @@ -32,7 +36,7 @@ int caml_debugger_in_use = 0; uintnat caml_event_count; -#if !defined(HAS_SOCKETS) || defined(_WIN32) +#if !defined(HAS_SOCKETS) void caml_debugger_init(void) { @@ -47,18 +51,28 @@ void caml_debugger(enum event_kind event) #ifdef HAS_UNISTD #include <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 */ @@ -67,16 +81,50 @@ static int dbg_socket = -1; /* The socket connected to the debugger */ static struct channel * dbg_in; /* Input channel on the socket */ static struct channel * dbg_out;/* Output channel on the socket */ +static char *dbg_addr = "(none)"; + static void open_connection(void) { +#ifdef _WIN32 + /* Set socket to synchronous mode so that file descriptor-oriented + functions (read()/write() etc.) can be used */ + + int oldvalue, oldvaluelen, newvalue, retcode; + oldvaluelen = sizeof(oldvalue); + retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &oldvalue, &oldvaluelen); + if (retcode == 0) { + newvalue = SO_SYNCHRONOUS_NONALERT; + setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &newvalue, sizeof(newvalue)); + } +#endif dbg_socket = socket(sock_domain, SOCK_STREAM, 0); +#ifdef _WIN32 + if (retcode == 0) { + /* Restore initial mode */ + setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &oldvalue, oldvaluelen); + } +#endif if (dbg_socket == -1 || - connect(dbg_socket, &sock_addr.s_gen, sock_addr_len) == -1) - caml_fatal_error("cannot connect to debugger"); + connect(dbg_socket, &sock_addr.s_gen, sock_addr_len) == -1){ + caml_fatal_error_arg2 ("cannot connect to debugger at %s", dbg_addr, + "error: %s\n", strerror (errno)); + } +#ifdef _WIN32 + dbg_socket = _open_osfhandle(dbg_socket, 0); + if (dbg_socket == -1) + caml_fatal_error("_open_osfhandle failed"); +#endif dbg_in = caml_open_descriptor_in(dbg_socket); dbg_out = caml_open_descriptor_out(dbg_socket); if (!caml_debugger_in_use) caml_putword(dbg_out, -1); /* first connection */ +#ifdef _WIN32 + caml_putword(dbg_out, _getpid()); +#else caml_putword(dbg_out, getpid()); +#endif caml_flush(dbg_out); } @@ -87,6 +135,20 @@ static void close_connection(void) dbg_socket = -1; /* was closed by caml_close_channel */ } +#ifdef _WIN32 +static void winsock_startup(void) +{ + WSADATA wsaData; + int err = WSAStartup(MAKEWORD(2, 0), &wsaData); + if (err) caml_fatal_error("WSAStartup failed"); +} + +static void winsock_cleanup(void) +{ + WSACleanup(); +} +#endif + void caml_debugger_init(void) { char * address; @@ -96,21 +158,30 @@ void caml_debugger_init(void) address = getenv("CAML_DEBUG_SOCKET"); if (address == NULL) return; + dbg_addr = address; +#ifdef _WIN32 + winsock_startup(); + (void)atexit(winsock_cleanup); +#endif /* Parse the address */ port = NULL; for (p = address; *p != 0; p++) { if (*p == ':') { *p = 0; port = p+1; break; } } if (port == NULL) { +#ifndef _WIN32 /* Unix domain */ sock_domain = PF_UNIX; sock_addr.s_unix.sun_family = AF_UNIX; strncpy(sock_addr.s_unix.sun_path, address, sizeof(sock_addr.s_unix.sun_path)); - sock_addr_len = + sock_addr_len = ((char *)&(sock_addr.s_unix.sun_path) - (char *)&(sock_addr.s_unix)) + strlen(address); +#else + caml_fatal_error("Unix sockets not supported"); +#endif } else { /* Internet domain */ sock_domain = PF_INET; @@ -211,7 +282,7 @@ void caml_debugger(enum event_kind event) caml_flush(dbg_out); command_loop: - + /* Read and execute the commands sent by the debugger */ while(1) { switch(getch(dbg_in)) { @@ -235,6 +306,7 @@ void caml_debugger(enum event_kind event) caml_set_instruction(caml_start_code + pos, caml_saved_code[pos]); break; case REQ_CHECKPOINT: +#ifndef _WIN32 i = fork(); if (i == 0) { close_connection(); /* Close parent connection. */ @@ -243,6 +315,10 @@ void caml_debugger(enum event_kind event) caml_putword(dbg_out, i); caml_flush(dbg_out); } +#else + caml_fatal_error("error: REQ_CHECKPOINT command"); + exit(-1); +#endif break; case REQ_GO: caml_event_count = caml_getword(dbg_in); @@ -251,7 +327,12 @@ void caml_debugger(enum event_kind event) exit(0); break; case REQ_WAIT: +#ifndef _WIN32 wait(NULL); +#else + caml_fatal_error("Fatal error: REQ_WAIT command"); + exit(-1); +#endif break; case REQ_INITIAL_FRAME: frame = caml_extern_sp + 1; diff --git a/byterun/dynlink.c b/byterun/dynlink.c index 11455e728c..462bb4f190 100644 --- a/byterun/dynlink.c +++ b/byterun/dynlink.c @@ -130,7 +130,7 @@ static void open_shared_lib(char * name) realname = caml_search_dll_in_path(&caml_shared_libs_path, name); caml_gc_message(0x100, "Loading shared library %s\n", (uintnat) realname); - handle = caml_dlopen(realname, 1); + handle = caml_dlopen(realname, 1, 1); if (handle == NULL) caml_fatal_error_arg2("Fatal error: cannot load shared library %s\n", name, "Reason: %s\n", caml_dlerror()); @@ -217,7 +217,7 @@ CAMLprim value caml_dynlink_open_lib(value mode, value filename) caml_gc_message(0x100, "Opening shared library %s\n", (uintnat) String_val(filename)); - handle = caml_dlopen(String_val(filename), Int_val(mode)); + handle = caml_dlopen(String_val(filename), Int_val(mode), 1); if (handle == NULL) caml_failwith(caml_dlerror()); result = caml_alloc_small(1, Abstract_tag); Handle_val(result) = handle; diff --git a/byterun/extern.c b/byterun/extern.c index eb7fb20064..7bdf56f9d2 100644 --- a/byterun/extern.c +++ b/byterun/extern.c @@ -397,7 +397,7 @@ static void extern_rec(value v) writecode32(CODE_INT32, n); return; } - if (Is_young(v) || Is_in_heap(v) || Is_atom(v)) { + if (Is_in_value_area(v)) { header_t hd = Hd_val(v); tag_t tag = Tag_hd(hd); mlsize_t sz = Wosize_hd(hd); @@ -405,9 +405,9 @@ static void extern_rec(value v) 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; @@ -755,7 +755,7 @@ CAMLexport void caml_serialize_float_4(float f) CAMLexport void caml_serialize_float_8(double f) { - caml_serialize_block_8(&f, 1); + caml_serialize_block_float_8(&f, 1); } CAMLexport void caml_serialize_block_1(void * data, intnat len) diff --git a/byterun/fail.c b/byterun/fail.c index a36b6afb41..b1a08c6110 100644 --- a/byterun/fail.c +++ b/byterun/fail.c @@ -60,6 +60,21 @@ CAMLexport void caml_raise_with_arg(value tag, value arg) CAMLnoreturn; } +CAMLexport void caml_raise_with_args(value tag, int nargs, value args[]) +{ + CAMLparam1 (tag); + CAMLxparamN (args, nargs); + value bucket; + int i; + + Assert(1 + nargs <= Max_young_wosize); + bucket = caml_alloc_small (1 + nargs, 0); + Field(bucket, 0) = tag; + for (i = 0; i < nargs; i++) Field(bucket, 1 + i) = args[i]; + caml_raise(bucket); + CAMLnoreturn; +} + CAMLexport void caml_raise_with_string(value tag, char const *msg) { CAMLparam1 (tag); diff --git a/byterun/fail.h b/byterun/fail.h index 5a55c57c5a..f092c8115f 100644 --- a/byterun/fail.h +++ b/byterun/fail.h @@ -60,6 +60,7 @@ extern value caml_exn_bucket; CAMLextern void caml_raise (value bucket) Noreturn; CAMLextern void caml_raise_constant (value tag) Noreturn; CAMLextern void caml_raise_with_arg (value tag, value arg) Noreturn; +CAMLextern void caml_raise_with_args (value tag, int nargs, value arg[]) Noreturn; CAMLextern void caml_raise_with_string (value tag, char const * msg) Noreturn; CAMLextern void caml_failwith (char const *) Noreturn; CAMLextern void caml_invalid_argument (char const *) Noreturn; diff --git a/byterun/finalise.c b/byterun/finalise.c index e411311489..1e176dd170 100644 --- a/byterun/finalise.c +++ b/byterun/finalise.c @@ -24,6 +24,7 @@ struct final { value fun; value val; + int offset; }; static struct final *final_table = NULL; @@ -67,7 +68,7 @@ void caml_final_update (void) { uintnat i, j, k; uintnat todo_count = 0; - + Assert (young == old); for (i = 0; i < old; i++){ Assert (Is_block (final_table[i].val)); @@ -84,10 +85,12 @@ void caml_final_update (void) Assert (Is_in_heap (final_table[i].val)); if (Is_white_val (final_table[i].val)){ if (Tag_val (final_table[i].val) == Forward_tag){ - value 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)){ + value fv; + Assert (final_table[i].offset == 0); + fv = Forward_val (final_table[i].val); + 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; @@ -136,7 +139,7 @@ void caml_final_do_calls (void) -- to_do_hd->size; f = to_do_hd->item[to_do_hd->size]; running_finalisation_function = 1; - caml_callback (f.fun, f.val); + caml_callback (f.fun, f.val + f.offset); running_finalisation_function = 0; } caml_gc_message (0x80, "Done calling finalisation functions.\n", 0); @@ -159,7 +162,7 @@ void caml_final_do_strong_roots (scanning_action f) Assert (old == young); for (i = 0; i < old; i++) Call_action (f, final_table[i].fun); - + for (todo = to_do_hd; todo != NULL; todo = todo->next){ for (i = 0; i < todo->size; i++){ Call_action (f, todo->item[i].fun); @@ -186,7 +189,7 @@ void caml_final_do_weak_roots (scanning_action f) void caml_final_do_young_roots (scanning_action f) { uintnat i; - + Assert (old <= young); for (i = old; i < young; i++){ Call_action (f, final_table[i].fun); @@ -206,11 +209,11 @@ void caml_final_empty_young (void) /* Put (f,v) in the recent set. */ CAMLprim value caml_final_register (value f, value v) { - if (!(Is_block (v) && (Is_in_heap (v) || Is_young (v)))){ + if (!(Is_block (v) && Is_in_heap_or_young(v))) { caml_invalid_argument ("Gc.finalise"); } Assert (old <= young); - + if (young >= size){ if (final_table == NULL){ uintnat new_size = 30; @@ -227,8 +230,13 @@ CAMLprim value caml_final_register (value f, value v) } Assert (young < size); final_table[young].fun = f; - if (Tag_val (v) == Infix_tag) v -= Infix_offset_val (v); - final_table[young].val = v; + if (Tag_val (v) == Infix_tag){ + final_table[young].offset = Infix_offset_val (v); + final_table[young].val = v - Infix_offset_val (v); + }else{ + final_table[young].offset = 0; + final_table[young].val = v; + } ++ young; return Val_unit; diff --git a/byterun/floats.c b/byterun/floats.c index e94a4c506b..c708cbe0d1 100644 --- a/byterun/floats.c +++ b/byterun/floats.c @@ -394,7 +394,7 @@ CAMLprim value caml_classify_float(value vd) #else union { double d; -#ifdef ARCH_BIG_ENDIAN +#if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__)) struct { uint32 h; uint32 l; } i; #else struct { uint32 l; uint32 h; } i; diff --git a/byterun/freelist.c b/byterun/freelist.c index c463d91f79..a2a8a0fb0a 100644 --- a/byterun/freelist.c +++ b/byterun/freelist.c @@ -13,10 +13,13 @@ /* $Id$ */ +#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" @@ -40,7 +43,6 @@ static struct { } sentinel = {0, Make_header (0, 0, Caml_blue), 0, 0}; #define Fl_head ((char *) (&(sentinel.first_bp))) -static char *fl_prev = Fl_head; /* Current allocation pointer. */ static char *fl_last = NULL; /* Last block in the list. Only valid just after [caml_fl_allocate] returns NULL. */ char *caml_fl_merge = Fl_head; /* Current insertion pointer. Managed @@ -48,29 +50,45 @@ 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 (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); } + #endif /* [allocate_block] is called by [caml_fl_allocate]. Given a suitable free @@ -87,7 +105,7 @@ static void fl_check (void) it is located in the high-address words of the free block. This way, the linking of the free-list does not change in case 2. */ -static char *allocate_block (mlsize_t wh_sz, char *prev, char *cur) +static char *allocate_block (mlsize_t wh_sz, int flpi, char *prev, char *cur) { header_t h = Hd_bp (cur); Assert (Whsize_hd (h) >= wh_sz); @@ -103,13 +121,18 @@ static char *allocate_block (mlsize_t wh_sz, char *prev, char *cur) In case 0, it gives an invalid header to the block. The function calling [caml_fl_allocate] will overwrite it. */ Hd_op (cur) = Make_header (0, 0, Caml_white); + if (flpi + 1 < flp_size && flp[flpi + 1] == cur){ + flp[flpi + 1] = prev; + }else if (flpi == flp_size - 1){ + beyond = (prev == Fl_head) ? NULL : prev; + -- flp_size; + } }else{ /* Case 2. */ caml_fl_cur_size -= wh_sz; Hd_op (cur) = Make_header (Wosize_hd (h) - wh_sz, 0, Caml_blue); } - fl_prev = prev; return cur + Bosize_hd (h) - Bsize_wsize (wh_sz); -} +} /* [caml_fl_allocate] does not set the header of the newly allocated block. The calling function must do it before any GC function gets called. @@ -117,33 +140,129 @@ static char *allocate_block (mlsize_t wh_sz, char *prev, char *cur) */ char *caml_fl_allocate (mlsize_t wo_sz) { - char *cur, *prev; + char *cur = NULL, *prev, *result; + int i; + mlsize_t sz, prevsz; Assert (sizeof (char *) == sizeof (value)); - Assert (fl_prev != NULL); Assert (wo_sz >= 1); - /* Search from [fl_prev] to the end of the list. */ - prev = fl_prev; - cur = Next (prev); - while (cur != NULL){ Assert (Is_in_heap (cur)); - if (Wosize_bp (cur) >= wo_sz){ - return allocate_block (Whsize_wosize (wo_sz), prev, cur); + /* Search in the flp array. */ + for (i = 0; i < flp_size; i++){ + sz = Wosize_bp (Next (flp[i])); + if (sz >= wo_sz){ + result = allocate_block (Whsize_wosize (wo_sz), i, flp[i], Next (flp[i])); + goto update_flp; } - prev = cur; + } + /* Extend the flp array. */ + if (flp_size == 0){ + prev = Fl_head; + prevsz = 0; + }else{ + prev = Next (flp[flp_size - 1]); + prevsz = Wosize_bp (prev); + if (beyond != NULL) prev = beyond; + } + while (flp_size < FLP_MAX){ cur = Next (prev); + if (cur == NULL){ + fl_last = prev; + beyond = (prev == Fl_head) ? NULL : prev; + return NULL; + }else{ + sz = Wosize_bp (cur); + if (sz > prevsz){ + flp[flp_size] = prev; + ++ flp_size; + if (sz >= wo_sz){ + beyond = cur; + i = flp_size - 1; + result = allocate_block (Whsize_wosize (wo_sz), flp_size - 1, prev, + cur); + goto update_flp; + } + prevsz = sz; + } + } + prev = cur; } - fl_last = prev; - /* Search from the start of the list to [fl_prev]. */ - prev = Fl_head; + beyond = cur; + + /* The flp table is full. Do a slow first-fit search. */ + + if (beyond != NULL){ + prev = beyond; + }else{ + prev = flp[flp_size - 1]; + } + prevsz = Wosize_bp (Next (flp[FLP_MAX-1])); + Assert (prevsz < wo_sz); cur = Next (prev); - while (prev != fl_prev){ - if (Wosize_bp (cur) >= wo_sz){ - return allocate_block (Whsize_wosize (wo_sz), prev, cur); + while (cur != NULL){ + Assert (Is_in_heap (cur)); + sz = Wosize_bp (cur); + if (sz < prevsz){ + beyond = cur; + }else if (sz >= wo_sz){ + return allocate_block (Whsize_wosize (wo_sz), flp_size, prev, cur); } prev = cur; cur = Next (prev); } - /* No suitable block was found. */ + fl_last = prev; return NULL; + + update_flp: /* (i, sz) */ + /* The block at [i] was removed or reduced. Update the table. */ + Assert (0 <= i && i < flp_size + 1); + if (i < flp_size){ + if (i > 0){ + prevsz = Wosize_bp (Next (flp[i-1])); + }else{ + prevsz = 0; + } + if (i == flp_size - 1){ + if (Wosize_bp (Next (flp[i])) <= prevsz){ + beyond = Next (flp[i]); + -- flp_size; + }else{ + beyond = NULL; + } + }else{ + char *buf [FLP_MAX]; + int j = 0; + mlsize_t oldsz = sz; + + prev = flp[i]; + while (prev != flp[i+1]){ + cur = Next (prev); + sz = Wosize_bp (cur); + if (sz > prevsz){ + buf[j++] = prev; + prevsz = sz; + if (sz >= oldsz){ + Assert (sz == oldsz); + break; + } + } + prev = cur; + } + if (FLP_MAX >= flp_size + j - 1){ + memmove (&flp[i+j], &flp[i+1], sizeof (block *) * (flp_size - i - 1)); + memmove (&flp[i], &buf[0], sizeof (block *) * j); + flp_size += j - 1; + }else{ + if (FLP_MAX > i + j){ + memmove (&flp[i+j], &flp[i+1], sizeof (block *) * (FLP_MAX - i - j)); + memmove (&flp[i], &buf[0], sizeof (block *) * j); + }else{ + memmove (&flp[i], &buf[0], sizeof (block *) * (FLP_MAX - i)); + } + flp_size = FLP_MAX - 1; + beyond = Next (flp[FLP_MAX - 1]); + } + } + } + return result; } static char *last_fragment; @@ -157,11 +276,22 @@ void caml_fl_init_merge (void) #endif } +static void truncate_flp (char *changed) +{ + if (changed == Fl_head){ + flp_size = 0; + beyond = NULL; + }else{ + while (flp_size > 0 && Next (flp[flp_size - 1]) >= changed) -- flp_size; + if (beyond >= changed) beyond = NULL; + } +} + /* This is called by caml_compact_heap. */ void caml_fl_reset (void) { - Next (Fl_head) = 0; - fl_prev = Fl_head; + Next (Fl_head) = NULL; + truncate_flp (Fl_head); caml_fl_cur_size = 0; caml_fl_init_merge (); } @@ -175,14 +305,9 @@ char *caml_fl_merge_block (char *bp) mlsize_t prev_wosz; caml_fl_cur_size += Whsize_hd (hd); - + #ifdef DEBUG - { - mlsize_t i; - for (i = 0; i < Wosize_hd (hd); i++){ - Field (Val_bp (bp), i) = Debug_free_major; - } - } + caml_set_fields (bp, 0, Debug_free_major); #endif prev = caml_fl_merge; cur = Next (prev); @@ -191,6 +316,8 @@ char *caml_fl_merge_block (char *bp) Assert (prev < bp || prev == Fl_head); Assert (cur > bp || cur == NULL); + truncate_flp (prev); + /* If [last_fragment] and [bp] are adjacent, merge them. */ if (last_fragment == Hp_bp (bp)){ mlsize_t bp_whsz = Whsize_bp (bp); @@ -211,7 +338,6 @@ char *caml_fl_merge_block (char *bp) if (Wosize_hd (hd) + cur_whsz <= Max_wosize){ Next (prev) = next_cur; - if (fl_prev == cur) fl_prev = prev; hd = Make_header (Wosize_hd (hd) + cur_whsz, 0, Caml_blue); Hd_bp (bp) = hd; adj = bp + Bosize_hd (hd); @@ -249,45 +375,47 @@ char *caml_fl_merge_block (char *bp) /* This is a heap extension. We have to insert it in the right place in the free-list. - [caml_fl_add_block] can only be called right after a call to + [caml_fl_add_blocks] can only be called right after a call to [caml_fl_allocate] that returned NULL. Most of the heap extensions are expected to be at the end of the free list. (This depends on the implementation of [malloc].) + + [bp] must point to a list of blocks chained by their field 0, + terminated by NULL, and field 1 of the first block must point to + the last block. */ -void caml_fl_add_block (char *bp) +void caml_fl_add_blocks (char *bp) { Assert (fl_last != NULL); Assert (Next (fl_last) == NULL); -#ifdef DEBUG - { - mlsize_t i; - for (i = 0; i < Wosize_bp (bp); i++){ - Field (Val_bp (bp), i) = Debug_free_major; - } - } -#endif - caml_fl_cur_size += Whsize_bp (bp); if (bp > fl_last){ Next (fl_last) = bp; - Next (bp) = NULL; + 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); Assert (cur > bp || cur == NULL); - Next (bp) = cur; + Next (Field (bp, 1)) = cur; Next (prev) = bp; - /* When inserting a block between [caml_fl_merge] and [caml_gc_sweep_hp], + /* When inserting blocks between [caml_fl_merge] and [caml_gc_sweep_hp], we must advance [caml_fl_merge] to the new block, so that [caml_fl_merge] is always the last free-list block before [caml_gc_sweep_hp]. */ - if (prev == caml_fl_merge && bp <= caml_gc_sweep_hp) caml_fl_merge = bp; + if (prev == caml_fl_merge && bp < caml_gc_sweep_hp){ + caml_fl_merge = (char *) Field (bp, 1); + } + truncate_flp (bp); } } diff --git a/byterun/freelist.h b/byterun/freelist.h index ea03ad9869..823748548f 100644 --- a/byterun/freelist.h +++ b/byterun/freelist.h @@ -28,7 +28,7 @@ char *caml_fl_allocate (mlsize_t); void caml_fl_init_merge (void); void caml_fl_reset (void); char *caml_fl_merge_block (char *); -void caml_fl_add_block (char *); +void caml_fl_add_blocks (char *); void caml_make_free_blocks (value *, mlsize_t, int); diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index 12bfc9b0a1..6a69cc1347 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -78,7 +78,7 @@ static void check_block (char *hp) mlsize_t i; value v = Val_hp (hp); value f; - + check_head (v); switch (Tag_hp (hp)){ case Abstract_tag: break; @@ -93,7 +93,7 @@ static void check_block (char *hp) case Custom_tag: Assert (!Is_in_heap (Custom_ops_val (v))); break; - + case Infix_tag: Assert (0); break; @@ -102,7 +102,10 @@ static void check_block (char *hp) Assert (Tag_hp (hp) < No_scan_tag); for (i = 0; i < Wosize_hp (hp); i++){ f = Field (v, i); - if (Is_block (f) && Is_in_heap (f)) check_head (f); + if (Is_block (f) && Is_in_heap (f)){ + check_head (f); + Assert (Color_val (f) != Caml_blue); + } } } } @@ -454,10 +457,7 @@ void caml_init_gc (uintnat minor_size, uintnat major_size, { uintnat major_heap_size = Bsize_wsize (norm_heapincr (major_size)); -#ifdef DEBUG - caml_gc_message (-1, "### O'Caml runtime: debug mode ###\n", 0); -#endif - + caml_page_table_initialize(Bsize_wsize(minor_size) + major_heap_size); caml_set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size))); caml_major_heap_increment = Bsize_wsize (norm_heapincr (major_incr)); caml_percent_free = norm_pfree (percent_fr); diff --git a/byterun/globroots.c b/byterun/globroots.c index b59b8ed967..5de3d1315b 100644 --- a/byterun/globroots.c +++ b/byterun/globroots.c @@ -18,12 +18,26 @@ #include "memory.h" #include "misc.h" #include "mlvalues.h" +#include "roots.h" #include "globroots.h" -/* The set of global memory roots is represented as a skip list +/* The sets of global memory roots are represented as skip lists (see William Pugh, "Skip lists: a probabilistic alternative to balanced binary trees", Comm. ACM 33(6), 1990). */ +struct global_root { + value * root; /* the address of the root */ + struct global_root * forward[1]; /* variable-length array */ +}; + +#define NUM_LEVELS 17 + +struct global_root_list { + value * root; /* dummy value for layout compatibility */ + struct global_root * forward[NUM_LEVELS]; /* forward chaining */ + int level; /* max used level */ +}; + /* Generate a random level for a new node: 0 with probability 3/4, 1 with probability 3/16, 2 with probability 3/64, etc. We use a simple linear congruential PRNG (see Knuth vol 2) instead @@ -49,24 +63,19 @@ static int random_level(void) return level; } -/* The initial global root list */ - -struct global_root_list caml_global_roots = { NULL, { NULL, }, 0 }; - -/* Register a global C root */ +/* Insertion in a global root list */ -CAMLexport void caml_register_global_root(value *r) +static void caml_insert_global_root(struct global_root_list * rootlist, + value * r) { struct global_root * update[NUM_LEVELS]; struct global_root * e, * f; int i, new_level; - Assert (((intnat) r & 3) == 0); /* compact.c demands this (for now) */ - /* Init "cursor" to list head */ - e = (struct global_root *) &caml_global_roots; + e = (struct global_root *) rootlist; /* Find place to insert new node */ - for (i = caml_global_roots.level; i >= 0; i--) { + for (i = rootlist->level; i >= 0; i--) { while (1) { f = e->forward[i]; if (f == NULL || f->root >= r) break; @@ -79,10 +88,10 @@ CAMLexport void caml_register_global_root(value *r) if (e != NULL && e->root == r) return; /* Insert additional element, updating list level if necessary */ new_level = random_level(); - if (new_level > caml_global_roots.level) { - for (i = caml_global_roots.level + 1; i <= new_level; i++) - update[i] = (struct global_root *) &caml_global_roots; - caml_global_roots.level = new_level; + if (new_level > rootlist->level) { + for (i = rootlist->level + 1; i <= new_level; i++) + update[i] = (struct global_root *) rootlist; + rootlist->level = new_level; } e = caml_stat_alloc(sizeof(struct global_root) + new_level * sizeof(struct global_root *)); @@ -93,18 +102,19 @@ CAMLexport void caml_register_global_root(value *r) } } -/* Un-register a global C root */ +/* Deletion in a global root list */ -CAMLexport void caml_remove_global_root(value *r) +static void caml_delete_global_root(struct global_root_list * rootlist, + value * r) { struct global_root * update[NUM_LEVELS]; struct global_root * e, * f; int i; /* Init "cursor" to list head */ - e = (struct global_root *) &caml_global_roots; + e = (struct global_root *) rootlist; /* Find element in list */ - for (i = caml_global_roots.level; i >= 0; i--) { + for (i = rootlist->level; i >= 0; i--) { while (1) { f = e->forward[i]; if (f == NULL || f->root >= r) break; @@ -116,14 +126,136 @@ CAMLexport void caml_remove_global_root(value *r) /* If not found, nothing to do */ if (e == NULL || e->root != r) return; /* Rebuild list without node */ - for (i = 0; i <= caml_global_roots.level; i++) { + for (i = 0; i <= rootlist->level; i++) { if (update[i]->forward[i] == e) update[i]->forward[i] = e->forward[i]; } /* Reclaim list element */ caml_stat_free(e); /* Down-correct list level */ - while (caml_global_roots.level > 0 && - caml_global_roots.forward[caml_global_roots.level] == NULL) - caml_global_roots.level--; + while (rootlist->level > 0 && + rootlist->forward[rootlist->level] == NULL) + rootlist->level--; +} + +/* Iterate over a global root list */ + +static void caml_iterate_global_roots(scanning_action f, + struct global_root_list * rootlist) +{ + struct global_root * gr; + + for (gr = rootlist->forward[0]; gr != NULL; gr = gr->forward[0]) { + f(*(gr->root), gr->root); + } +} + +/* Empty a global root list */ + +static void caml_empty_global_roots(struct global_root_list * rootlist) +{ + struct global_root * gr, * next; + int i; + + for (gr = rootlist->forward[0]; gr != NULL; /**/) { + next = gr->forward[0]; + caml_stat_free(gr); + gr = next; + } + for (i = 0; i <= rootlist->level; i++) rootlist->forward[i] = NULL; + rootlist->level = 0; +} + +/* The three global root lists */ + +struct global_root_list caml_global_roots = { NULL, { NULL, }, 0 }; + /* mutable roots, don't know whether old or young */ +struct global_root_list caml_global_roots_young = { NULL, { NULL, }, 0 }; + /* generational roots pointing to minor or major heap */ +struct global_root_list caml_global_roots_old = { NULL, { NULL, }, 0 }; + /* generational roots pointing to major heap */ + +/* Register a global C root of the mutable kind */ + +CAMLexport void caml_register_global_root(value *r) +{ + Assert (((intnat) r & 3) == 0); /* compact.c demands this (for now) */ + caml_insert_global_root(&caml_global_roots, r); +} + +/* Un-register a global C root of the mutable kind */ + +CAMLexport void caml_remove_global_root(value *r) +{ + caml_delete_global_root(&caml_global_roots, r); +} + +/* Register a global C root of the generational kind */ + +CAMLexport void caml_register_generational_global_root(value *r) +{ + value v = *r; + Assert (((intnat) r & 3) == 0); /* compact.c demands this (for now) */ + if (Is_block(v)) { + if (Is_young(v)) + caml_insert_global_root(&caml_global_roots_young, r); + else if (Is_in_heap(v)) + caml_insert_global_root(&caml_global_roots_old, r); + } +} + +/* Un-register a global C root of the generational kind */ + +CAMLexport void caml_remove_generational_global_root(value *r) +{ + value v = *r; + if (Is_block(v)) { + if (Is_young(v)) + caml_delete_global_root(&caml_global_roots_young, r); + else if (Is_in_heap(v)) + caml_delete_global_root(&caml_global_roots_old, r); + } +} + +/* Modify the value of a global C root of the generational kind */ + +CAMLexport void caml_modify_generational_global_root(value *r, value newval) +{ + value oldval = *r; + + /* It is OK to have a root in roots_young that suddenly points to + the old generation -- the next minor GC will take care of that. + What needs corrective action is a root in roots_old that suddenly + points to the young generation. */ + if (Is_block(newval) && Is_young(newval) && + Is_block(oldval) && Is_in_heap(oldval)) { + caml_delete_global_root(&caml_global_roots_old, r); + caml_insert_global_root(&caml_global_roots_young, r); + } + *r = newval; +} + +/* Scan all global roots */ + +void caml_scan_global_roots(scanning_action f) +{ + caml_iterate_global_roots(f, &caml_global_roots); + caml_iterate_global_roots(f, &caml_global_roots_young); + caml_iterate_global_roots(f, &caml_global_roots_old); +} + +/* Scan global roots for a minor collection */ + +void caml_scan_global_young_roots(scanning_action f) +{ + struct global_root * gr; + + caml_iterate_global_roots(f, &caml_global_roots); + caml_iterate_global_roots(f, &caml_global_roots_young); + /* Move young roots to old roots */ + for (gr = caml_global_roots_young.forward[0]; + gr != NULL; gr = gr->forward[0]) { + caml_insert_global_root(&caml_global_roots_old, gr->root); + } + caml_empty_global_roots(&caml_global_roots_young); } diff --git a/byterun/globroots.h b/byterun/globroots.h index 684860abc8..4dee35f23b 100644 --- a/byterun/globroots.h +++ b/byterun/globroots.h @@ -19,22 +19,9 @@ #define CAML_GLOBROOTS_H #include "mlvalues.h" +#include "roots.h" -/* Skip list structure */ - -struct global_root { - value * root; /* the address of the root */ - struct global_root * forward[1]; /* variable-length array */ -}; - -#define NUM_LEVELS 17 - -struct global_root_list { - value * root; /* dummy value for layout compatibility */ - struct global_root * forward[NUM_LEVELS]; /* forward chaining */ - int level; /* max used level */ -}; - -extern struct global_root_list caml_global_roots; +void caml_scan_global_roots(scanning_action f); +void caml_scan_global_young_roots(scanning_action f); #endif /* CAML_GLOBROOTS_H */ diff --git a/byterun/hash.c b/byterun/hash.c index 2b8a235756..a1d7864db8 100644 --- a/byterun/hash.c +++ b/byterun/hash.c @@ -62,7 +62,7 @@ static void hash_aux(value obj) We can inspect the block contents. */ Assert (Is_block (obj)); - if (Is_atom(obj) || Is_young(obj) || Is_in_heap(obj)) { + if (Is_in_value_area(obj)) { tag = Tag_val(obj); switch (tag) { case String_tag: @@ -142,7 +142,7 @@ static void hash_aux(value obj) /* Hashing variant tags */ -CAMLexport value caml_hash_variant(char * tag) +CAMLexport value caml_hash_variant(char const * tag) { value accu; /* Same hashing algorithm as in ../typing/btype.ml, function hash_variant */ diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c index 1932e08f61..3734d82412 100644 --- a/byterun/instrtrace.c +++ b/byterun/instrtrace.c @@ -181,9 +181,7 @@ caml_trace_value_file (value v, code_t prog, int proglen, FILE * f) fprintf (f, "%#lx", v); if (!v) return; - if (Is_atom (v)) - fprintf (f, "=atom%ld", v - Atom (0)); - else if (prog && v % sizeof (int) == 0 + if (prog && v % sizeof (int) == 0 && (code_t) v >= prog && (code_t) v < (code_t) ((char *) prog + proglen)) fprintf (f, "=code@%d", (code_t) v - prog); diff --git a/byterun/intern.c b/byterun/intern.c index 5225fb8b83..ba48fe0117 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -76,7 +76,7 @@ static value intern_block; (Sign_extend(intern_src[-2]) << 8) + intern_src[-1]) #define read32u() \ (intern_src += 4, \ - (intern_src[-4] << 24) + (intern_src[-3] << 16) + \ + ((uintnat)(intern_src[-4]) << 24) + (intern_src[-3] << 16) + \ (intern_src[-2] << 8) + intern_src[-1]) #define read32s() \ (intern_src += 4, \ diff --git a/byterun/interp.c b/byterun/interp.c index df2a1649bd..2d65b6af5b 100644 --- a/byterun/interp.c +++ b/byterun/interp.c @@ -66,9 +66,12 @@ sp is a local copy of the global variable caml_extern_sp. */ #define Setup_for_gc \ { sp -= 2; sp[0] = accu; sp[1] = env; caml_extern_sp = sp; } -#define Restore_after_gc { accu = sp[0]; env = sp[1]; sp += 2; } -#define Setup_for_c_call { saved_pc = pc; *--sp = env; caml_extern_sp = sp; } -#define Restore_after_c_call { sp = caml_extern_sp; env = *sp++; } +#define Restore_after_gc \ + { accu = sp[0]; env = sp[1]; sp += 2; } +#define Setup_for_c_call \ + { saved_pc = pc; *--sp = env; caml_extern_sp = sp; } +#define Restore_after_c_call \ + { sp = caml_extern_sp; env = *sp++; saved_pc = NULL; } /* An event frame must look like accu + a C_CALL frame + a RETURN 1 frame */ #define Setup_for_event \ @@ -211,7 +214,7 @@ value caml_interprete(code_t prog, asize_t prog_size) /* volatile ensures that initial_local_roots and saved_pc will keep correct value across longjmp */ struct caml__roots_block * volatile initial_local_roots; - volatile code_t saved_pc; + volatile code_t saved_pc = NULL; struct longjmp_buffer raise_buf; value * modify_dest, modify_newval; #ifndef THREADED_CODE @@ -245,7 +248,9 @@ value caml_interprete(code_t prog, asize_t prog_size) caml_local_roots = initial_local_roots; sp = caml_extern_sp; accu = caml_exn_bucket; - pc = saved_pc + 2; /* +2 adjustement for the sole purpose of backtraces */ + pc = saved_pc; saved_pc = NULL; + if (pc != NULL) pc += 2; + /* +2 adjustement for the sole purpose of backtraces */ goto raise_exception; } caml_external_raise = &raise_buf; diff --git a/byterun/ints.c b/byterun/ints.c index 23ee463296..ed18e6f446 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -551,15 +551,21 @@ CAMLprim value caml_int64_of_string(value s) CAMLprim value caml_int64_bits_of_float(value vd) { - union { double d; int64 i; } u; + union { double d; int64 i; int32 h[2]; } u; u.d = Double_val(vd); +#if defined(__arm__) && !defined(__ARM_EABI__) + { int32 t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } +#endif return caml_copy_int64(u.i); } CAMLprim value caml_int64_float_of_bits(value vi) { - union { double d; int64 i; } u; + union { double d; int64 i; int32 h[2]; } u; u.i = Int64_val(vi); +#if defined(__arm__) && !defined(__ARM_EABI__) + { int32 t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } +#endif return caml_copy_double(u.d); } diff --git a/byterun/io.h b/byterun/io.h index a35124ac9f..d02a5a72fc 100644 --- a/byterun/io.h +++ b/byterun/io.h @@ -52,7 +52,7 @@ struct channel { }; enum { - CHANNEL_FLAG_FROM_SOCKET = 1, /* For Windows */ + CHANNEL_FLAG_FROM_SOCKET = 1 /* For Windows */ }; /* For an output channel: @@ -102,6 +102,8 @@ CAMLextern void (*caml_channel_mutex_lock) (struct channel *); CAMLextern void (*caml_channel_mutex_unlock) (struct channel *); CAMLextern void (*caml_channel_mutex_unlock_exn) (void); +CAMLextern struct channel * caml_all_opened_channels; + #define Lock(channel) \ if (caml_channel_mutex_lock != NULL) (*caml_channel_mutex_lock)(channel) #define Unlock(channel) \ diff --git a/byterun/main.c b/byterun/main.c index 3454ffcd0c..e6afb1b326 100644 --- a/byterun/main.c +++ b/byterun/main.c @@ -28,6 +28,27 @@ CAMLextern void caml_expand_command_line (int *, char ***); int main(int argc, char **argv) { +#ifdef DEBUG + { + char *ocp; + char *cp; + int i; + + caml_gc_message (-1, "### OCaml runtime: debug mode ###\n", 0); +#if 0 + caml_gc_message (-1, "### command line:", 0); + for (i = 0; i < argc; i++){ + caml_gc_message (-1, " %s", argv[i]); + } + caml_gc_message (-1, "\n", 0); + ocp = getenv ("OCAMLRUNPARAM"); + caml_gc_message (-1, "### OCAMLRUNPARAM=%s\n", ocp == NULL ? "" : ocp); + cp = getenv ("CAMLRUNPARAM"); + caml_gc_message (-1, "### CAMLRUNPARAM=%s\n", cp == NULL ? "" : cp); + caml_gc_message (-1, "### working dir: %s\n", getcwd (NULL, 0)); +#endif + } +#endif #ifdef _WIN32 /* Expand wildcards and diversions in command line */ caml_expand_command_line(&argc, &argv); diff --git a/byterun/major_gc.c b/byterun/major_gc.c index 54759b26f5..312d9a4a24 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -31,9 +31,7 @@ uintnat caml_percent_free; intnat caml_major_heap_increment; -CAMLexport char *caml_heap_start, *caml_heap_end; -CAMLexport page_table_entry *caml_page_table; -asize_t caml_page_low, caml_page_high; +CAMLexport char *caml_heap_start; char *caml_gc_sweep_hp; int caml_gc_phase; /* always Phase_mark, Phase_sweep, or Phase_idle */ static value *gray_vals; @@ -50,12 +48,13 @@ extern char *caml_fl_merge; /* Defined in freelist.c. */ static char *markhp, *chunk, *limit; -static int gc_subphase; /* Subphase_main, Subphase_weak, Subphase_final */ -#define Subphase_main 10 -#define Subphase_weak 11 -#define Subphase_final 12 +int caml_gc_subphase; /* Subphase_{main,weak1,weak2,final} */ static value *weak_prev; +#ifdef DEBUG +static unsigned long major_gc_counter = 0; +#endif + static void realloc_gray_vals (void) { value *new; @@ -113,9 +112,10 @@ static void start_cycle (void) caml_gc_message (0x01, "Starting new major GC cycle\n", 0); caml_darken_all_roots(); caml_gc_phase = Phase_mark; - gc_subphase = Subphase_main; + caml_gc_subphase = Subphase_main; markhp = NULL; #ifdef DEBUG + ++ major_gc_counter; caml_heap_check (); #endif } @@ -128,6 +128,7 @@ static void mark_slice (intnat work) mlsize_t size, i; caml_gc_message (0x40, "Marking %ld words\n", work); + caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase); gray_vals_ptr = gray_vals_cur; while (work > 0){ if (gray_vals_ptr > gray_vals){ @@ -143,9 +144,9 @@ static void mark_slice (intnat work) hd = Hd_val (child); if (Tag_hd (hd) == Forward_tag){ value f = Forward_val (child); - if (Is_block (f) && (Is_young (f) || Is_in_heap (f)) - && (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag - || Tag_val (f) == Double_tag)){ + if (Is_block (f) + && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag + || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){ /* Do not short-circuit the pointer. */ }else{ Field (v, i) = f; @@ -189,34 +190,34 @@ static void mark_slice (intnat work) chunk = caml_heap_start; markhp = chunk; limit = chunk + Chunk_size (chunk); - }else if (gc_subphase == Subphase_main){ - /* The main marking phase is over. Start removing weak pointers to - dead values. */ - gc_subphase = Subphase_weak; - weak_prev = &caml_weak_list_head; - }else if (gc_subphase == Subphase_weak){ - value cur, curfield; - mlsize_t sz, i; - header_t hd; - - cur = *weak_prev; - if (cur != (value) NULL){ - hd = Hd_val (cur); - if (Color_hd (hd) == Caml_white){ - /* The whole array is dead, remove it from the list. */ - *weak_prev = Field (cur, 0); - }else{ + }else{ + switch (caml_gc_subphase){ + case Subphase_main: { + /* The main marking phase is over. Start removing weak pointers to + dead values. */ + caml_gc_subphase = Subphase_weak1; + weak_prev = &caml_weak_list_head; + } + break; + case Subphase_weak1: { + value cur, curfield; + mlsize_t sz, i; + header_t hd; + + cur = *weak_prev; + if (cur != (value) NULL){ + hd = Hd_val (cur); sz = Wosize_hd (hd); for (i = 1; i < sz; i++){ curfield = Field (cur, i); - weak_again: + weak_again: if (curfield != caml_weak_none && 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; @@ -230,27 +231,52 @@ static void mark_slice (intnat work) } } weak_prev = &Field (cur, 0); + work -= Whsize_hd (hd); + }else{ + /* Subphase_weak1 is done. Start removing dead weak arrays. */ + caml_gc_subphase = Subphase_weak2; + weak_prev = &caml_weak_list_head; } - work -= Whsize_hd (hd); - }else{ - /* Subphase_weak is done. Handle finalised values. */ + } + break; + case Subphase_weak2: { + value cur; + header_t hd; + + cur = *weak_prev; + if (cur != (value) NULL){ + hd = Hd_val (cur); + if (Color_hd (hd) == Caml_white){ + /* The whole array is dead, remove it from the list. */ + *weak_prev = Field (cur, 0); + }else{ + weak_prev = &Field (cur, 0); + } + work -= 1; + }else{ + /* Subphase_weak2 is done. Handle finalised values. */ + gray_vals_cur = gray_vals_ptr; + caml_final_update (); + gray_vals_ptr = gray_vals_cur; + caml_gc_subphase = Subphase_final; + } + } + break; + case Subphase_final: { + /* Initialise the sweep phase. */ gray_vals_cur = gray_vals_ptr; - caml_final_update (); - gray_vals_ptr = gray_vals_cur; - gc_subphase = Subphase_final; + caml_gc_sweep_hp = caml_heap_start; + caml_fl_init_merge (); + caml_gc_phase = Phase_sweep; + chunk = caml_heap_start; + caml_gc_sweep_hp = chunk; + limit = chunk + Chunk_size (chunk); + work = 0; + caml_fl_size_at_phase_change = caml_fl_cur_size; + } + break; + default: Assert (0); } - }else{ - Assert (gc_subphase == Subphase_final); - /* Initialise the sweep phase. */ - gray_vals_cur = gray_vals_ptr; - caml_gc_sweep_hp = caml_heap_start; - caml_fl_init_merge (); - caml_gc_phase = Phase_sweep; - chunk = caml_heap_start; - caml_gc_sweep_hp = chunk; - limit = chunk + Chunk_size (chunk); - work = 0; - caml_fl_size_at_phase_change = caml_fl_cur_size; } } gray_vals_cur = gray_vals_ptr; @@ -354,7 +380,7 @@ intnat caml_major_collection_slice (intnat howmuch) if (p < dp) p = dp; if (p < caml_extra_heap_resources) p = caml_extra_heap_resources; - caml_gc_message (0x40, "allocated_words = %" + caml_gc_message (0x40, "allocated_words = %" ARCH_INTNAT_PRINTF_FORMAT "u\n", caml_allocated_words); caml_gc_message (0x40, "extra_heap_resources = %" @@ -441,10 +467,6 @@ asize_t caml_round_heap_chunk_size (asize_t request) void caml_init_major_heap (asize_t heap_size) { - asize_t i; - asize_t page_table_size; - page_table_entry *page_table_block; - caml_stat_heap_size = clip_heap_chunk_size (heap_size); caml_stat_top_heap_size = caml_stat_heap_size; Assert (caml_stat_heap_size % Page_size == 0); @@ -452,23 +474,11 @@ void caml_init_major_heap (asize_t heap_size) if (caml_heap_start == NULL) caml_fatal_error ("Fatal error: not enough memory for the initial heap.\n"); Chunk_next (caml_heap_start) = NULL; - caml_heap_end = caml_heap_start + caml_stat_heap_size; - Assert ((uintnat) caml_heap_end % Page_size == 0); - caml_stat_heap_chunks = 1; - caml_page_low = Page (caml_heap_start); - caml_page_high = Page (caml_heap_end); - - page_table_size = caml_page_high - caml_page_low; - page_table_block = - (page_table_entry *) malloc (page_table_size * sizeof (page_table_entry)); - if (page_table_block == NULL){ - caml_fatal_error ("Fatal error: not enough memory for the initial heap.\n"); - } - caml_page_table = page_table_block - caml_page_low; - for (i = Page (caml_heap_start); i < Page (caml_heap_end); i++){ - caml_page_table [i] = In_heap; + if (caml_page_table_add(In_heap, caml_heap_start, + caml_heap_start + caml_stat_heap_size) != 0) { + caml_fatal_error ("Fatal error: not enough memory for the initial page table.\n"); } caml_fl_init_merge (); @@ -478,7 +488,7 @@ void caml_init_major_heap (asize_t heap_size) gray_vals_size = 2048; gray_vals = (value *) malloc (gray_vals_size * sizeof (value)); if (gray_vals == NULL) - caml_fatal_error ("Fatal error: not enough memory for the initial heap.\n"); + caml_fatal_error ("Fatal error: not enough memory for the gray cache.\n"); gray_vals_cur = gray_vals; gray_vals_end = gray_vals + gray_vals_size; heap_is_pure = 1; diff --git a/byterun/major_gc.h b/byterun/major_gc.h index 47aa5e59f7..5e48e3431f 100644 --- a/byterun/major_gc.h +++ b/byterun/major_gc.h @@ -33,6 +33,7 @@ typedef struct { #define Chunk_block(c) (((heap_chunk_head *) (c)) [-1]).block extern int caml_gc_phase; +extern int caml_gc_subphase; extern uintnat caml_allocated_words; extern double caml_extra_heap_resources; extern uintnat caml_dependent_size, caml_dependent_allocated; @@ -41,28 +42,15 @@ extern uintnat caml_fl_size_at_phase_change; #define Phase_mark 0 #define Phase_sweep 1 #define Phase_idle 2 - -#ifdef __alpha -typedef int page_table_entry; -#else -typedef char page_table_entry; -#endif +#define Subphase_main 10 +#define Subphase_weak1 11 +#define Subphase_weak2 12 +#define Subphase_final 13 CAMLextern char *caml_heap_start; -CAMLextern char *caml_heap_end; extern uintnat total_heap_size; -CAMLextern page_table_entry *caml_page_table; -extern asize_t caml_page_low, caml_page_high; extern char *caml_gc_sweep_hp; -#define In_heap 1 -#define Not_in_heap 0 -#define Page(p) ((uintnat) (p) >> Page_log) -#define Is_in_heap(p) \ - (Assert (Is_block ((value) (p))), \ - (addr)(p) >= (addr)caml_heap_start && (addr)(p) < (addr)caml_heap_end \ - && caml_page_table [Page (p)]) - void caml_init_major_heap (asize_t); /* size in bytes */ asize_t caml_round_heap_chunk_size (asize_t); /* size in bytes */ void caml_darken (value, value *); diff --git a/byterun/memory.c b/byterun/memory.c index 03d7286937..0141517bff 100644 --- a/byterun/memory.c +++ b/byterun/memory.c @@ -27,10 +27,161 @@ #include "mlvalues.h" #include "signals.h" -#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); +extern uintnat caml_percent_free; /* major_gc.c */ + +/* 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. @@ -44,13 +195,8 @@ char *caml_alloc_for_heap (asize_t request) char *mem; void *block; Assert (request % Page_size == 0); -#ifdef USE_MMAP_INSTEAD_OF_MALLOC - mem = caml_aligned_mmap (request + sizeof (heap_chunk_head), - sizeof (heap_chunk_head), &block); -#else mem = caml_aligned_malloc (request + sizeof (heap_chunk_head), sizeof (heap_chunk_head), &block); -#endif if (mem == NULL) return NULL; mem += sizeof (heap_chunk_head); Chunk_size (mem) = request; @@ -63,12 +209,7 @@ char *caml_alloc_for_heap (asize_t request) */ void caml_free_for_heap (char *mem) { -#ifdef USE_MMAP_INSTEAD_OF_MALLOC - caml_aligned_munmap (Chunk_block (mem), - Chunk_size (mem) + sizeof (heap_chunk_head)); -#else free (Chunk_block (mem)); -#endif } /* Take a chunk of memory as argument, which must be the result of a @@ -76,13 +217,12 @@ void caml_free_for_heap (char *mem) The contents of the chunk must be a sequence of valid blocks and fragments: no space between blocks and no trailing garbage. If some blocks are blue, they must be added to the free list by the - caller. All other blocks must have the color [caml_allocation_color(mem)]. + caller. All other blocks must have the color [caml_allocation_color(m)]. The caller must update [caml_allocated_words] if applicable. Return value: 0 if no error; -1 in case of error. */ int caml_add_to_heap (char *m) { - asize_t i; Assert (Chunk_size (m) % Page_size == 0); #ifdef DEBUG /* Should check the contents of the block. */ @@ -91,56 +231,9 @@ int caml_add_to_heap (char *m) caml_gc_message (0x04, "Growing heap to %luk bytes\n", (caml_stat_heap_size + Chunk_size (m)) / 1024); - /* Extend the page table as needed. */ - if (Page (m) < caml_page_low){ - page_table_entry *block, *new_page_table; - asize_t new_page_low = Page (m); - asize_t new_size = caml_page_high - new_page_low; - - caml_gc_message (0x08, "Growing page table to %lu entries\n", new_size); - block = malloc (new_size * sizeof (page_table_entry)); - if (block == NULL){ - caml_gc_message (0x08, "No room for growing page table\n", 0); - return -1; - } - new_page_table = block - new_page_low; - for (i = new_page_low; i < caml_page_low; i++){ - new_page_table [i] = Not_in_heap; - } - for (i = caml_page_low; i < caml_page_high; i++){ - new_page_table [i] = caml_page_table [i]; - } - free (caml_page_table + caml_page_low); - caml_page_table = new_page_table; - caml_page_low = new_page_low; - } - if (Page (m + Chunk_size (m)) > caml_page_high){ - page_table_entry *block, *new_page_table; - asize_t new_page_high = Page (m + Chunk_size (m)); - asize_t new_size = new_page_high - caml_page_low; - - caml_gc_message (0x08, "Growing page table to %lu entries\n", new_size); - block = malloc (new_size * sizeof (page_table_entry)); - if (block == NULL){ - caml_gc_message (0x08, "No room for growing page table\n", 0); - return -1; - } - new_page_table = block - caml_page_low; - for (i = caml_page_low; i < caml_page_high; i++){ - new_page_table [i] = caml_page_table [i]; - } - for (i = caml_page_high; i < new_page_high; i++){ - new_page_table [i] = Not_in_heap; - } - free (caml_page_table + caml_page_low); - caml_page_table = new_page_table; - caml_page_high = new_page_high; - } - - /* Mark the pages as being in the heap. */ - for (i = Page (m); i < Page (m + Chunk_size (m)); i++){ - caml_page_table [i] = In_heap; - } + /* Register block in page table */ + if (caml_page_table_add(In_heap, m, m + Chunk_size(m)) != 0) + return -1; /* Chain this heap chunk. */ { @@ -157,10 +250,6 @@ int caml_add_to_heap (char *m) ++ caml_stat_heap_chunks; } - /* Update the heap bounds as needed. */ - /* already done: if (m < caml_heap_start) heap_start = m; */ - if (m + Chunk_size (m) > caml_heap_end) caml_heap_end = m + Chunk_size (m); - caml_stat_heap_size += Chunk_size (m); if (caml_stat_heap_size > caml_stat_top_heap_size){ caml_stat_top_heap_size = caml_stat_heap_size; @@ -169,25 +258,52 @@ int caml_add_to_heap (char *m) } /* Allocate more memory from malloc for the heap. - Return a blue block of at least the requested size (in words). - The caller must insert the block into the free list. + Return a blue block of at least the requested size. + The blue block is chained to a sequence of blue blocks (through their + field 0); the last block of the chain is pointed by field 1 of the + first. There may be a fragment after the last block. + The caller must insert the blocks into the free list. The request must be less than or equal to Max_wosize. Return NULL when out of memory. */ static char *expand_heap (mlsize_t request) { - char *mem; - asize_t malloc_request; + char *mem, *hp, *prev; + asize_t over_request, malloc_request, remain; - malloc_request = caml_round_heap_chunk_size (Bhsize_wosize (request)); + Assert (request <= Max_wosize); + over_request = request + request / 100 * caml_percent_free; + malloc_request = caml_round_heap_chunk_size (Bhsize_wosize (over_request)); mem = caml_alloc_for_heap (malloc_request); if (mem == NULL){ caml_gc_message (0x04, "No room for growing heap\n", 0); return NULL; } - Assert (Wosize_bhsize (malloc_request) >= request); - Hd_hp (mem) = Make_header (Wosize_bhsize (malloc_request), 0, Caml_blue); - + remain = malloc_request; + prev = hp = mem; + /* XXX find a way to do this with a call to caml_make_free_blocks */ + while (Wosize_bhsize (remain) > Max_wosize){ + Hd_hp (hp) = Make_header (Max_wosize, 0, Caml_blue); +#ifdef DEBUG + caml_set_fields (Bp_hp (hp), 0, Debug_free_major); +#endif + hp += Bhsize_wosize (Max_wosize); + remain -= Bhsize_wosize (Max_wosize); + Field (Op_hp (mem), 1) = Field (Op_hp (prev), 0) = (value) Op_hp (hp); + prev = hp; + } + if (remain > 1){ + Hd_hp (hp) = Make_header (Wosize_bhsize (remain), 0, Caml_blue); +#ifdef DEBUG + caml_set_fields (Bp_hp (hp), 0, Debug_free_major); +#endif + Field (Op_hp (mem), 1) = Field (Op_hp (prev), 0) = (value) Op_hp (hp); + Field (Op_hp (hp), 0) = (value) NULL; + }else{ + Field (Op_hp (prev), 0) = (value) NULL; + if (remain == 1) Hd_hp (hp) = Make_header (0, 0, Caml_white); + } + Assert (Wosize_hp (mem) >= request); if (caml_add_to_heap (mem) != 0){ caml_free_for_heap (mem); return NULL; @@ -201,7 +317,6 @@ static char *expand_heap (mlsize_t request) void caml_shrink_heap (char *chunk) { char **cp; - asize_t i; /* Never deallocate the first block, because caml_heap_start is both the first block and the base address for page numbers, and we don't @@ -213,7 +328,7 @@ void caml_shrink_heap (char *chunk) caml_stat_heap_size -= Chunk_size (chunk); caml_gc_message (0x04, "Shrinking heap to %luk bytes\n", - caml_stat_heap_size / 1024); + (unsigned long) caml_stat_heap_size / 1024); #ifdef DEBUG { @@ -232,9 +347,7 @@ void caml_shrink_heap (char *chunk) *cp = Chunk_next (chunk); /* Remove the pages of [chunk] from the page table. */ - for (i = Page (chunk); i < Page (chunk + Chunk_size (chunk)); i++){ - caml_page_table [i] = Not_in_heap; - } + caml_page_table_remove(In_heap, chunk, chunk + Chunk_size (chunk)); /* Free the [malloc] block that contains [chunk]. */ caml_free_for_heap (chunk); @@ -267,7 +380,7 @@ CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag) else caml_raise_out_of_memory (); } - caml_fl_add_block (new_block); + caml_fl_add_blocks (new_block); hp = caml_fl_allocate (wosize); } @@ -358,10 +471,10 @@ void caml_initialize (value *fp, value val) { *fp = val; if (Is_block (val) && Is_young (val) && Is_in_heap (fp)){ - *caml_ref_table_ptr++ = fp; - if (caml_ref_table_ptr >= caml_ref_table_limit){ - caml_realloc_ref_table (); + if (caml_ref_table.ptr >= caml_ref_table.limit){ + caml_realloc_ref_table (&caml_ref_table); } + *caml_ref_table.ptr++ = fp; } } diff --git a/byterun/memory.h b/byterun/memory.h index d3962bfa5e..d7a07f6510 100644 --- a/byterun/memory.h +++ b/byterun/memory.h @@ -49,6 +49,23 @@ color_t caml_allocation_color (void *hp); /* <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; \ @@ -94,11 +111,11 @@ color_t caml_allocation_color (void *hp); if (caml_gc_phase == Phase_mark) caml_darken (_old_, NULL); \ if (Is_block (val) && Is_young (val) \ && ! (Is_block (_old_) && Is_young (_old_))){ \ - *caml_ref_table_ptr++ = (fp); \ - if (caml_ref_table_ptr >= caml_ref_table_limit){ \ - CAMLassert (caml_ref_table_ptr == caml_ref_table_limit); \ - caml_realloc_ref_table (); \ + if (caml_ref_table.ptr >= caml_ref_table.limit){ \ + CAMLassert (caml_ref_table.ptr == caml_ref_table.limit); \ + caml_realloc_ref_table (&caml_ref_table); \ } \ + *caml_ref_table.ptr++ = (fp); \ } \ } \ }while(0) @@ -389,5 +406,33 @@ CAMLextern void caml_register_global_root (value *); CAMLextern void caml_remove_global_root (value *); +/* [caml_register_generational_global_root] registers a global C + variable as a memory root for the duration of the program, or until + [caml_remove_generational_global_root] is called. + The program guarantees that the value contained in this variable + will not be assigned directly. If the program needs to change + the value of this variable, it must do so by calling + [caml_modify_generational_global_root]. The [value *] pointer + passed to [caml_register_generational_global_root] must contain + a valid Caml value before the call. + In return for these constraints, scanning of memory roots during + minor collection is made more efficient. */ + +CAMLextern void caml_register_generational_global_root (value *); + +/* [caml_remove_generational_global_root] removes a memory root + registered on a global C variable with + [caml_register_generational_global_root]. */ + +CAMLextern void caml_remove_generational_global_root (value *); + +/* [caml_modify_generational_global_root(r, newval)] + modifies the value contained in [r], storing [newval] inside. + In other words, the assignment [*r = newval] is performed, + but in a way that is compatible with the optimized scanning of + generational global roots. [r] must be a global memory root + previously registered with [caml_register_generational_global_root]. */ + +CAMLextern void caml_modify_generational_global_root(value *r, value newval); #endif /* CAML_MEMORY_H */ diff --git a/byterun/meta.c b/byterun/meta.c index 78f0b57b37..91143612ac 100644 --- a/byterun/meta.c +++ b/byterun/meta.c @@ -155,6 +155,12 @@ value caml_invoke_traced_function(value codeptr, value env, value arg) return Val_unit; /* not reached */ } +value caml_reify_bytecode(value prog, value len) +{ + caml_invalid_argument("Meta.reify_bytecode"); + return Val_unit; /* not reached */ +} + value * caml_stack_low; value * caml_stack_high; value * caml_stack_threshold; diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c index f4958939b1..91aa29799b 100644 --- a/byterun/minor_gc.c +++ b/byterun/minor_gc.c @@ -26,45 +26,81 @@ #include "mlvalues.h" #include "roots.h" #include "signals.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; -static value **ref_table = NULL, **ref_table_end, **ref_table_threshold; -CAMLexport value **caml_ref_table_ptr = NULL, **caml_ref_table_limit; -static asize_t ref_table_size, ref_table_reserve; + +CAMLexport struct caml_ref_table + caml_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}, + caml_weak_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0}; + int caml_in_minor_collection = 0; +#ifdef DEBUG +static unsigned long minor_gc_counter = 0; +#endif + +void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv) +{ + value **new_table; + + tbl->size = sz; + tbl->reserve = rsv; + new_table = (value **) caml_stat_alloc ((tbl->size + tbl->reserve) + * sizeof (value *)); + if (tbl->base != NULL) caml_stat_free (tbl->base); + tbl->base = new_table; + tbl->ptr = tbl->base; + tbl->threshold = tbl->base + tbl->size; + tbl->limit = tbl->threshold; + tbl->end = tbl->base + tbl->size + tbl->reserve; +} + +static void reset_table (struct caml_ref_table *tbl) +{ + tbl->size = 0; + tbl->reserve = 0; + if (tbl->base != NULL) caml_stat_free (tbl->base); + tbl->base = tbl->ptr = tbl->threshold = tbl->limit = tbl->end = NULL; +} + +static void clear_table (struct caml_ref_table *tbl) +{ + tbl->ptr = tbl->base; + tbl->limit = tbl->threshold; +} + void caml_set_minor_heap_size (asize_t size) { char *new_heap; - value **new_table; + 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; caml_young_ptr = caml_young_end; caml_minor_heap_size = size; - ref_table_size = caml_minor_heap_size / sizeof (value) / 8; - ref_table_reserve = 256; - new_table = (value **) caml_stat_alloc ((ref_table_size + ref_table_reserve) - * sizeof (value *)); - if (ref_table != NULL) caml_stat_free (ref_table); - ref_table = new_table; - caml_ref_table_ptr = ref_table; - ref_table_threshold = ref_table + ref_table_size; - caml_ref_table_limit = ref_table_threshold; - ref_table_end = ref_table + ref_table_size + ref_table_reserve; + reset_table (&caml_ref_table); + reset_table (&caml_weak_ref_table); } static value oldify_todo_list = 0; @@ -120,12 +156,16 @@ void caml_oldify_one (value v, value *p) }else{ value f = Forward_val (v); tag_t ft = 0; + int vv = 1; Assert (tag == Forward_tag); - if (Is_block (f) && (Is_young (f) || Is_in_heap (f))){ - ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f); + if (Is_block (f)){ + vv = Is_in_value_area(f); + if (vv) { + ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f); + } } - if (ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){ + if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){ /* Do not short-circuit the pointer. Copy as a normal block. */ Assert (Wosize_hd (hd) == 1); result = caml_alloc_shr (1, Forward_tag); @@ -187,16 +227,25 @@ void caml_empty_minor_heap (void) caml_in_minor_collection = 1; caml_gc_message (0x02, "<", 0); caml_oldify_local_roots(); - for (r = ref_table; r < caml_ref_table_ptr; r++){ + for (r = caml_ref_table.base; r < caml_ref_table.ptr; r++){ caml_oldify_one (**r, *r); } caml_oldify_mopup (); + for (r = caml_weak_ref_table.base; r < caml_weak_ref_table.ptr; r++){ + if (Is_block (**r) && Is_young (**r)){ + if (Hd_val (**r) == 0){ + **r = Field (**r, 0); + }else{ + **r = caml_weak_none; + } + } + } if (caml_young_ptr < caml_young_start) caml_young_ptr = caml_young_start; caml_stat_minor_words += Wsize_bsize (caml_young_end - caml_young_ptr); caml_young_ptr = caml_young_end; caml_young_limit = caml_young_start; - caml_ref_table_ptr = ref_table; - caml_ref_table_limit = ref_table_threshold; + clear_table (&caml_ref_table); + clear_table (&caml_weak_ref_table); caml_gc_message (0x02, ">", 0); caml_in_minor_collection = 0; } @@ -207,6 +256,7 @@ void caml_empty_minor_heap (void) for (p = (value *) caml_young_start; p < (value *) caml_young_end; ++p){ *p = Debug_free_minor; } + ++ minor_gc_counter; } #endif } @@ -238,32 +288,34 @@ CAMLexport value caml_check_urgent_gc (value extra_root) CAMLreturn (extra_root); } -void caml_realloc_ref_table (void) -{ Assert (caml_ref_table_ptr == caml_ref_table_limit); - Assert (caml_ref_table_limit <= ref_table_end); - Assert (caml_ref_table_limit >= ref_table_threshold); +void caml_realloc_ref_table (struct caml_ref_table *tbl) +{ Assert (tbl->ptr == tbl->limit); + Assert (tbl->limit <= tbl->end); + Assert (tbl->limit >= tbl->threshold); - if (caml_ref_table_limit == ref_table_threshold){ + if (tbl->base == NULL){ + caml_alloc_table (tbl, caml_minor_heap_size / sizeof (value) / 8, 256); + }else if (tbl->limit == tbl->threshold){ caml_gc_message (0x08, "ref_table threshold crossed\n", 0); - caml_ref_table_limit = ref_table_end; + tbl->limit = tbl->end; caml_urge_major_slice (); }else{ /* This will almost never happen with the bytecode interpreter. */ asize_t sz; - asize_t cur_ptr = caml_ref_table_ptr - ref_table; + asize_t cur_ptr = tbl->ptr - tbl->base; Assert (caml_force_major_slice); - ref_table_size *= 2; - sz = (ref_table_size + ref_table_reserve) * sizeof (value *); - caml_gc_message (0x08, "Growing ref_table to %" + tbl->size *= 2; + sz = (tbl->size + tbl->reserve) * sizeof (value *); + caml_gc_message (0x08, "Growing ref_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n", (intnat) sz/1024); - ref_table = (value **) realloc ((char *) ref_table, sz); - if (ref_table == NULL){ + tbl->base = (value **) realloc ((char *) tbl->base, sz); + if (tbl->base == NULL){ caml_fatal_error ("Fatal error: ref_table overflow\n"); } - ref_table_end = ref_table + ref_table_size + ref_table_reserve; - ref_table_threshold = ref_table + ref_table_size; - caml_ref_table_ptr = ref_table + cur_ptr; - caml_ref_table_limit = ref_table_end; + tbl->end = tbl->base + tbl->size + tbl->reserve; + tbl->threshold = tbl->base + tbl->size; + tbl->ptr = tbl->base + cur_ptr; + tbl->limit = tbl->end; } } diff --git a/byterun/minor_gc.h b/byterun/minor_gc.h index a569d3a907..8e834129bf 100644 --- a/byterun/minor_gc.h +++ b/byterun/minor_gc.h @@ -21,10 +21,20 @@ CAMLextern char *caml_young_start, *caml_young_ptr; CAMLextern char *caml_young_end, *caml_young_limit; -CAMLextern value **caml_ref_table_ptr, **caml_ref_table_limit; extern asize_t caml_minor_heap_size; extern int caml_in_minor_collection; +struct caml_ref_table { + value **base; + value **end; + value **threshold; + value **ptr; + value **limit; + asize_t size; + asize_t reserve; +}; +CAMLextern struct caml_ref_table caml_ref_table, caml_weak_ref_table; + #define Is_young(val) \ (Assert (Is_block (val)), \ (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start) @@ -33,7 +43,8 @@ extern void caml_set_minor_heap_size (asize_t); extern void caml_empty_minor_heap (void); CAMLextern void caml_minor_collection (void); CAMLextern void garbage_collection (void); /* def in asmrun/signals.c */ -extern void caml_realloc_ref_table (void); +extern void caml_realloc_ref_table (struct caml_ref_table *); +extern void caml_alloc_table (struct caml_ref_table *, asize_t, asize_t); extern void caml_oldify_one (value, value *); extern void caml_oldify_mopup (void); diff --git a/byterun/misc.c b/byterun/misc.c index 2a660219c4..e8597ee38c 100644 --- a/byterun/misc.c +++ b/byterun/misc.c @@ -29,6 +29,14 @@ int caml_failed_assert (char * expr, char * file, int line) return 1; /* not reached */ } +void caml_set_fields (char *bp, unsigned long start, unsigned long filler) +{ + mlsize_t i; + for (i = start; i < Wosize_bp (bp); i++){ + Field (Val_bp (bp), i) = (value) filler; + } +} + #endif /* DEBUG */ uintnat caml_verb_gc = 0; @@ -54,7 +62,7 @@ CAMLexport void caml_fatal_error_arg (char *fmt, char *arg) } CAMLexport void caml_fatal_error_arg2 (char *fmt1, char *arg1, - char *fmt2, char *arg2) + char *fmt2, char *arg2) { fprintf (stderr, fmt1, arg1); fprintf (stderr, fmt2, arg2); diff --git a/byterun/misc.h b/byterun/misc.h index a1b2b92607..d0aaffd1a2 100644 --- a/byterun/misc.h +++ b/byterun/misc.h @@ -49,19 +49,9 @@ typedef char * addr; /* Export control (to mark primitives and to handle Windows DLL) */ -#if defined(_WIN32) && defined(CAML_DLL) -# define CAMLexport __declspec(dllexport) -# define CAMLprim __declspec(dllexport) -# if defined(IN_OCAMLRUN) -# define CAMLextern __declspec(dllexport) extern -# else -# define CAMLextern __declspec(dllimport) extern -# endif -#else -# define CAMLexport -# define CAMLprim -# define CAMLextern extern -#endif +#define CAMLexport +#define CAMLprim +#define CAMLextern extern /* Assertions */ @@ -76,8 +66,8 @@ CAMLextern int caml_failed_assert (char *, char *, int); CAMLextern void caml_fatal_error (char *msg) Noreturn; CAMLextern void caml_fatal_error_arg (char *fmt, char *arg) Noreturn; -CAMLextern void caml_fatal_error_arg2 (char *fmt1, char *arg1, - char *fmt2, char *arg2) Noreturn; +CAMLextern void caml_fatal_error_arg2 (char *fmt1, char *arg1, + char *fmt2, char *arg2) Noreturn; /* Data structures */ @@ -132,6 +122,8 @@ char *caml_aligned_malloc (asize_t, int, void **); #define Debug_filler_align Debug_tag (0x85) #define Debug_uninit_stat 0xD7 + +extern void caml_set_fields (char *, unsigned long, unsigned long); #endif /* DEBUG */ diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h index 14c6c9dc1a..a472988346 100644 --- a/byterun/mlvalues.h +++ b/byterun/mlvalues.h @@ -188,7 +188,11 @@ typedef opcode_t * code_t; #define Class_val(val) Field((val), 0) #define Oid_val(val) Long_val(Field((val), 1)) CAMLextern value caml_get_public_method (value obj, value tag); -/* called as: callback(caml_get_public_method(obj, hash_variant(name)), obj) */ +/* Called as: + caml_callback(caml_get_public_method(obj, caml_hash_variant(name)), obj) */ +/* caml_get_public_method returns 0 if tag not in the table. + Note however that tags being hashed, same tag does not necessarily mean + same method name. */ /* Special case of tuples of fields: closures */ #define Closure_tag 247 @@ -204,7 +208,7 @@ CAMLextern value caml_get_public_method (value obj, value tag); /* <JOCAML */ /* 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. */ @@ -272,22 +276,6 @@ CAMLextern int64 caml_Int64_val(value v); CAMLextern header_t caml_atom_table[]; #define Atom(tag) (Val_hp (&(caml_atom_table [(tag)]))) -/* Is_atom tests whether a well-formed block is statically allocated - outside the heap. For the bytecode system, only zero-sized block (Atoms) - fall in this class. For the native-code generator, data - emitted by the code generator (as described in the table - caml_data_segments) are also atoms. */ - -#ifndef NATIVE_CODE -#define Is_atom(v) ((v) >= Atom(0) && (v) <= Atom(255)) -#else -CAMLextern char * caml_static_data_start, * caml_static_data_end; -#define Is_atom(v) \ - ((((char *)(v) >= caml_static_data_start \ - && (char *)(v) < caml_static_data_end) \ - || ((v) >= Atom(0) && (v) <= Atom(255)))) -#endif - /* Booleans are integers 0 or 1 */ #define Val_bool(x) Val_int((x) != 0) diff --git a/byterun/obj.c b/byterun/obj.c index ee16ba5752..ded8416b1e 100644 --- a/byterun/obj.c +++ b/byterun/obj.c @@ -66,11 +66,13 @@ CAMLprim value caml_obj_is_block(value arg) CAMLprim value caml_obj_tag(value arg) { if (Is_long (arg)){ - return Val_int (1000); - }else if (Is_young (arg) || Is_in_heap (arg) || Is_atom (arg)){ + return Val_int (1000); /* int_tag */ + }else if ((long) arg & (sizeof (value) - 1)){ + return Val_int (1002); /* unaligned_tag */ + }else if (Is_in_value_area (arg)){ return Val_int(Tag_val(arg)); }else{ - return Val_int (1001); + return Val_int (1001); /* out_of_heap_tag */ } } @@ -171,7 +173,7 @@ CAMLprim value caml_obj_truncate (value v, value newsize) CAMLprim value caml_lazy_follow_forward (value v) { - if (Is_block (v) && (Is_young (v) || Is_in_heap (v)) + if (Is_block (v) && Is_in_value_area(v) && Tag_val (v) == Forward_tag){ return Forward_val (v); }else{ @@ -189,7 +191,7 @@ CAMLprim value caml_lazy_make_forward (value v) CAMLreturn (res); } -/* For camlinternalOO.ml +/* For mlvalues.h and camlinternalOO.ml See also GETPUBMET in interp.c */ @@ -202,7 +204,8 @@ CAMLprim value caml_get_public_method (value obj, value tag) if (tag < Field(meths,mi)) hi = mi-2; else li = mi; } - return Field (meths, li-1); + /* return 0 if tag is not there */ + return (tag == Field(meths,li) ? Field (meths, li-1) : 0); } /* these two functions might be useful to an hypothetical JIT */ diff --git a/byterun/osdeps.h b/byterun/osdeps.h index 2dababedf1..3646fb4f78 100644 --- a/byterun/osdeps.h +++ b/byterun/osdeps.h @@ -41,8 +41,10 @@ extern char * caml_search_dll_in_path(struct ext_table * path, char * name); can be called. If [for_execution] is false, functions from this shared library will not be called, but just checked for presence, so symbol resolution can be skipped. + If [global] is true, symbols from the shared library can be used + to resolve for other libraries to be opened later on. Return [NULL] on error. */ -extern void * caml_dlopen(char * libname, int for_execution); +extern void * caml_dlopen(char * libname, int for_execution, int global); /* Close a shared library handle */ extern void caml_dlclose(void * handle); @@ -51,6 +53,8 @@ extern void caml_dlclose(void * handle); Return [NULL] if not found, or symbol value if found. */ extern void * caml_dlsym(void * handle, char * name); +extern void * caml_globalsym(char * name); + /* Return an error message describing the most recent dynlink failure. */ extern char * caml_dlerror(void); diff --git a/byterun/parsing.c b/byterun/parsing.c index 2d90fa5524..23228bf7bc 100644 --- a/byterun/parsing.c +++ b/byterun/parsing.c @@ -291,3 +291,12 @@ CAMLprim value caml_parse_engine(struct parser_tables *tables, } } + +/* Control printing of debugging info */ + +CAMLprim value caml_set_parser_trace(value flag) +{ + value oldflag = Val_bool(caml_parser_trace); + caml_parser_trace = Bool_val(flag); + return oldflag; +} diff --git a/byterun/roots.c b/byterun/roots.c index 2ff8762165..ff726bd319 100644 --- a/byterun/roots.c +++ b/byterun/roots.c @@ -36,7 +36,6 @@ CAMLexport void (*caml_scan_roots_hook) (scanning_action f) = NULL; void caml_oldify_local_roots (void) { register value * sp; - struct global_root * gr; struct caml__roots_block *lr; intnat i, j; @@ -54,9 +53,7 @@ void caml_oldify_local_roots (void) } } /* Global C roots */ - for (gr = caml_global_roots.forward[0]; gr != NULL; gr = gr->forward[0]) { - caml_oldify_one(*(gr->root), gr->root); - } + caml_scan_global_young_roots(&caml_oldify_one); /* Finalised values */ caml_final_do_young_roots (&caml_oldify_one); /* Hook */ @@ -72,18 +69,12 @@ void caml_darken_all_roots (void) void caml_do_roots (scanning_action f) { - struct global_root * gr; - /* Global variables */ f(caml_global_data, &caml_global_data); - /* The stack and the local C roots */ caml_do_local_roots(f, caml_extern_sp, caml_stack_high, caml_local_roots); - /* Global C roots */ - for (gr = caml_global_roots.forward[0]; gr != NULL; gr = gr->forward[0]) { - f(*(gr->root), gr->root); - } + caml_scan_global_roots(f); /* Finalised values */ caml_final_do_strong_roots (f); /* Hook */ diff --git a/byterun/startup.c b/byterun/startup.c index c2cea2c4bd..40db222224 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -72,6 +72,10 @@ static void init_atoms(void) { int i; for(i = 0; i < 256; i++) caml_atom_table[i] = Make_header(0, i, Caml_white); + if (caml_page_table_add(In_static_data, + caml_atom_table, caml_atom_table + 256) != 0) { + caml_fatal_error("Fatal error: not enough memory for the initial page table"); + } } /* Read the trailer of a bytecode file */ @@ -254,7 +258,7 @@ static int parse_command_line(char **argv) exit(0); break; case 'b': - caml_init_backtrace(); + caml_record_backtrace(Val_true); break; case 'I': if (argv[i + 1] != NULL) { @@ -307,7 +311,7 @@ static void parse_camlrunparam(void) case 'o': scanmult (opt, &percent_free_init); break; case 'O': scanmult (opt, &max_percent_free_init); break; case 'v': scanmult (opt, &caml_verb_gc); break; - case 'b': caml_init_backtrace(); break; + case 'b': caml_record_backtrace(Val_true); break; case 'p': caml_parser_trace = 1; break; } } diff --git a/byterun/unix.c b/byterun/unix.c index 7d3f857883..b0e606ccc7 100644 --- a/byterun/unix.c +++ b/byterun/unix.c @@ -15,6 +15,9 @@ /* Unix-specific stuff */ +#define _GNU_SOURCE + /* Helps finding RTLD_DEFAULT in glibc */ + #include <stddef.h> #include <stdlib.h> #include <string.h> @@ -23,8 +26,8 @@ #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 @@ -165,112 +168,34 @@ char * caml_search_dll_in_path(struct ext_table * path, char * name) } #ifdef SUPPORT_DYNAMIC_LINKING -#ifdef HAS_NSLINKMODULE -/* Use MacOSX bundles */ - -static char *dlerror_string = "No error"; - -/* Need to emulate dlopen behaviour by caching open libraries */ -typedef struct bundle_entry { - struct bundle_entry *next; - char *name; - void *handle; - int count; -} entry_t; - -entry_t bundle_list = {NULL,NULL,NULL,0}; +#ifdef __CYGWIN32__ +/* Use flexdll */ -entry_t *caml_lookup_bundle(const char *name) +void * caml_dlopen(char * libname, int for_execution, int global) { - entry_t *current = bundle_list.next, *last = &bundle_list; - - while (current !=NULL) { - if (!strcmp(name,current->name)) - return current; - last = current; - current = current->next; - } - current = (entry_t*) malloc(sizeof(entry_t)+strlen(name)+1); - current->name = (char*)(current+1); - strcpy(current->name, name); - current->count = 0; - current->next = NULL; - last->next = current; - return current; + int flags = (global ? FLEXDLL_RTLD_GLOBAL : 0); + if (!for_execution) flags |= FLEXDLL_RTLD_NOEXEC; + return flexdll_dlopen(libname, flags); } -void * caml_dlopen(char * libname, int for_execution) +void caml_dlclose(void * handle) { - NSObjectFileImage image; - entry_t *bentry = caml_lookup_bundle(libname); - NSObjectFileImageReturnCode retCode; - void *result = NULL; - - if (bentry->count > 0) - return bentry->handle; - - retCode = NSCreateObjectFileImageFromFile(libname, &image); - switch (retCode) { - case NSObjectFileImageSuccess: - dlerror_string = NULL; - result = (void*)NSLinkModule(image, libname, NSLINKMODULE_OPTION_BINDNOW - | NSLINKMODULE_OPTION_RETURN_ON_ERROR); - if (result != NULL) { - bentry->count++; - bentry->handle = result; - } - else NSDestroyObjectFileImage(image); - break; - case NSObjectFileImageAccess: - dlerror_string = "cannot access this bundle"; break; - case NSObjectFileImageArch: - dlerror_string = "this bundle has wrong CPU architecture"; break; - case NSObjectFileImageFormat: - case NSObjectFileImageInappropriateFile: - dlerror_string = "this file is not a proper bundle"; break; - default: - dlerror_string = "could not read object file"; break; - } - return result; + flexdll_dlclose(handle); } -void caml_dlclose(void * handle) +void * caml_dlsym(void * handle, char * name) { - entry_t *current = bundle_list.next; - int close = 1; - - dlerror_string = NULL; - while (current != NULL) { - if (current->handle == handle) { - current->count--; - close = (current->count == 0); - break; - } - current = current->next; - } - if (close) - NSUnLinkModule((NSModule)handle, NSUNLINKMODULE_OPTION_NONE); + return flexdll_dlsym(handle, name); } -void * caml_dlsym(void * handle, char * name) +void * caml_globalsym(char * name) { - NSSymbol sym; - char _name[1000] = "_"; - strncat (_name, name, 998); - dlerror_string = NULL; - sym = NSLookupSymbolInModule((NSModule)handle, _name); - if (sym != NULL) return NSAddressOfSymbol(sym); - else return NULL; + return flexdll_dlsym(flexdll_dlopen(NULL,0,1), name); } char * caml_dlerror(void) { - NSLinkEditErrors c; - int errnum; - const char *fileName, *errorString; - if (dlerror_string != NULL) return dlerror_string; - NSLinkEditError(&c,&errnum,&fileName,&errorString); - return (char *) errorString; + return flexdll_dlerror(); } #else @@ -283,9 +208,9 @@ char * caml_dlerror(void) #define RTLD_NODELETE 0 #endif -void * caml_dlopen(char * libname, int for_execution) +void * caml_dlopen(char * libname, int for_execution, int global) { - return dlopen(libname, RTLD_NOW | RTLD_GLOBAL | RTLD_NODELETE); + return dlopen(libname, RTLD_NOW | (global ? RTLD_GLOBAL : 0) | RTLD_NODELETE); /* Could use RTLD_LAZY if for_execution == 0, but needs testing */ } @@ -304,15 +229,24 @@ void * caml_dlsym(void * handle, char * name) return dlsym(handle, name); } +void * caml_globalsym(char * name) +{ +#ifdef RTLD_DEFAULT + return caml_dlsym(RTLD_DEFAULT, name); +#else + return NULL; +#endif +} + char * caml_dlerror(void) { - return dlerror(); + return (char*) dlerror(); } #endif #else -void * caml_dlopen(char * libname, int for_execution) +void * caml_dlopen(char * libname, int for_execution, int global) { return NULL; } @@ -326,57 +260,14 @@ void * caml_dlsym(void * handle, char * name) return NULL; } -char * caml_dlerror(void) +void * caml_globalsym(char * name) { - return "dynamic loading not supported on this platform"; -} - -#endif - -#ifdef USE_MMAP_INSTEAD_OF_MALLOC - -/* The code below supports the use of mmap() rather than malloc() - for allocating the chunks composing the major heap. - This code is needed for the IA64 under Linux, where the native - malloc() implementation can return pointers several *exabytes* apart, - (some coming from mmap(), other from sbrk()); this makes the - page table *way* too large. - No other tested platform requires this hack so far. However, it could - be useful for other 64-bit platforms in the future. */ - -#include <sys/mman.h> - -char *caml_aligned_mmap (asize_t size, int modulo, void **block) -{ - char *raw_mem; - uintnat aligned_mem; - Assert (modulo < Page_size); - raw_mem = (char *) mmap(NULL, size + Page_size, PROT_READ | PROT_WRITE, - MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); - if (raw_mem == MAP_FAILED) return NULL; - *block = raw_mem; - raw_mem += modulo; /* Address to be aligned */ - aligned_mem = (((uintnat) raw_mem / Page_size + 1) * Page_size); -#ifdef DEBUG - { - uintnat *p; - uintnat *p0 = (void *) *block, - *p1 = (void *) (aligned_mem - modulo), - *p2 = (void *) (aligned_mem - modulo + size), - *p3 = (void *) ((char *) *block + size + Page_size); - - for (p = p0; p < p1; p++) *p = Debug_filler_align; - for (p = p1; p < p2; p++) *p = Debug_uninit_align; - for (p = p2; p < p3; p++) *p = Debug_filler_align; - } -#endif - return (char *) (aligned_mem - modulo); + return NULL; } -void caml_aligned_munmap (char * addr, asize_t size) +char * caml_dlerror(void) { - int retcode = munmap (addr, size + Page_size); - Assert(retcode == 0); + return "dynamic loading not supported on this platform"; } #endif diff --git a/byterun/weak.c b/byterun/weak.c index 0cea2a6dc3..c6c4a223fe 100644 --- a/byterun/weak.c +++ b/byterun/weak.c @@ -45,6 +45,24 @@ CAMLprim value caml_weak_create (value len) #define None_val (Val_int(0)) #define Some_tag 0 +static void do_set (value ar, mlsize_t offset, value v) +{ + if (Is_block (v) && Is_young (v)){ + /* modified version of Modify */ + value old = Field (ar, offset); + Field (ar, offset) = v; + if (!(Is_block (old) && Is_young (old))){ + if (caml_weak_ref_table.ptr >= caml_weak_ref_table.limit){ + CAMLassert (caml_weak_ref_table.ptr == caml_weak_ref_table.limit); + caml_realloc_ref_table (&caml_weak_ref_table); + } + *caml_weak_ref_table.ptr++ = &Field (ar, offset); + } + }else{ + Field (ar, offset) = v; + } +} + CAMLprim value caml_weak_set (value ar, value n, value el) { mlsize_t offset = Long_val (n) + 1; @@ -52,15 +70,11 @@ CAMLprim value caml_weak_set (value ar, value n, value el) if (offset < 1 || offset >= Wosize_val (ar)){ caml_invalid_argument ("Weak.set"); } - Field (ar, offset) = caml_weak_none; - if (el != None_val){ - value v; Assert (Wosize_val (el) == 1); - v = Field (el, 0); - if (Is_block (v) && (Is_young (v) || Is_in_heap (v))){ - Modify (&Field (ar, offset), v); - }else{ - Field (ar, offset) = v; - } + if (el != None_val && Is_block (el)){ + Assert (Wosize_val (el) == 1); + do_set (ar, offset, Field (el, 0)); + }else{ + Field (ar, offset) = caml_weak_none; } return Val_unit; } @@ -106,7 +120,7 @@ CAMLprim value caml_weak_get_copy (value ar, value n) v = Field (ar, offset); if (v == caml_weak_none) CAMLreturn (None_val); - if (Is_block (v) && (Is_young (v) || Is_in_heap (v))){ + if (Is_block (v) && Is_in_heap_or_young(v)) { elt = caml_alloc (Wosize_val (v), Tag_val (v)); /* The GC may erase or move v during this call to caml_alloc. */ v = Field (ar, offset); @@ -141,3 +155,39 @@ CAMLprim value caml_weak_check (value ar, value n) } return Val_bool (Field (ar, offset) != caml_weak_none); } + +CAMLprim value caml_weak_blit (value ars, value ofs, + value ard, value ofd, value len) +{ + mlsize_t offset_s = Long_val (ofs) + 1; + mlsize_t offset_d = Long_val (ofd) + 1; + mlsize_t length = Long_val (len); + long i; + Assert (Is_in_heap (ars)); + Assert (Is_in_heap (ard)); + if (offset_s < 1 || offset_s + length > Wosize_val (ars)){ + caml_invalid_argument ("Weak.blit"); + } + if (offset_d < 1 || offset_d + length > Wosize_val (ard)){ + caml_invalid_argument ("Weak.blit"); + } + if (caml_gc_phase == Phase_mark && caml_gc_subphase == Subphase_weak1){ + for (i = 0; i < length; i++){ + value v = Field (ars, offset_s + i); + if (v != caml_weak_none && Is_block (v) && Is_in_heap (v) + && Is_white_val (v)){ + Field (ars, offset_s + i) = caml_weak_none; + } + } + } + if (offset_d < offset_s){ + for (i = 0; i < length; i++){ + do_set (ard, offset_d + i, Field (ars, offset_s + i)); + } + }else{ + for (i = length - 1; i >= 0; i--){ + do_set (ard, offset_d + i, Field (ars, offset_s + i)); + } + } + return Val_unit; +} diff --git a/config/Makefile-templ b/config/Makefile-templ index d212b32867..c77c585681 100644 --- a/config/Makefile-templ +++ b/config/Makefile-templ @@ -180,26 +180,19 @@ SHARPBANGSCRIPTS=true # at run-time for shared libraries #NATIVECCRPATH=-Wl,-rpath -### Flags for the assembler +### Command and flags to use for assembling ocamlopt-generated code # For the Alpha or the Mips: -#ASFLAGS=-O2 +#AS=as -O2 # For the PowerPC: -#ASFLAGS=-u -m ppc -w -# For the RS6000: -#ASFLAGS=-u -m pwr -w +#AS=as -u -m ppc -w # Otherwise: -#ASFLAGS= +#AS=as ### Command and flags to use for assembling .S files (often with preprocessing) # If gcc is available: -#ASPP=gcc -#ASPPFLAGS=-c -DSYS_$(SYSTEM) +#ASPP=gcc -c # On SunOS and Solaris: -#ASPP=$(AS) -#ASPPFLAGS=-P -DSYS_$(SYSTEM) -# Otherwise: -#ASPP=$(AS) -#ASPPFLAGS= +#ASPP=as -P ### Extra flags to use for assembling .S files in profiling mode # On Digital Unix: diff --git a/config/Makefile.mingw b/config/Makefile.mingw index d15f44d398..a3da402837 100644 --- a/config/Makefile.mingw +++ b/config/Makefile.mingw @@ -61,16 +61,16 @@ SHAREDCCCOMPOPTS= MKSHAREDLIBRPATH= NATIVECCPROFOPTS= NATIVECCRPATH= -ASFLAGS= -ASPP= -ASPPFLAGS= +ASM=as +ASPP=gcc ASPPPROFFLAGS= PROFILING=noprof DYNLINKOPTS= -DEBUGGER= +DEBUGGER=ocamldebugger CC_PROFILE= SYSTHREAD_SUPPORT=true EXTRALIBS= +CMXS=cmxs ########## Configuration for the bytecode compiler @@ -87,19 +87,19 @@ BYTECCLINKOPTS= DLLCCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused -DCAML_DLL ### Libraries needed -BYTECCLIBS= -NATIVECCLIBS= +BYTECCLIBS=-lws2_32 +NATIVECCLIBS=-lws2_32 ### How to invoke the C preprocessor CPP=$(BYTECC) -E -### How to build an EXE -MKEXE=$(BYTECC) -o $(1) $(2) -#ml let mkexe out files opts = Printf.sprintf "%s -o %s %s %s" bytecc out opts files;; - -### How to build a DLL -MKDLL=$(BYTECC) -shared -o $(1) -Wl,--out-implib,$(2) $(3) -#ml let mkdll out implib files opts = Printf.sprintf "%s -shared -o %s -Wl,--out-implib,%s %s %s" bytecc out implib files opts;; +### Flexlink +FLEXLINK=flexlink -chain mingw +FLEXDIR=$(shell $(FLEXLINK) -where) +IFLEXDIR=-I"$(FLEXDIR)" +MKDLL=$(FLEXLINK) +MKEXE=$(FLEXLINK) -exe +MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library MKLIB=rm -f $(1); ar rcs $(1) $(2) @@ -134,12 +134,11 @@ NATIVECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused NATIVECCLINKOPTS= ### Build partially-linked object file -PARTIALLD=ld -r $(NATIVECCLINKOPTS) -PACKLD=$(PARTIALLD) -o #there must be a space after this '-o' +PACKLD=ld -r $(NATIVECCLINKOPTS) -o #there must be a space after this '-o' ############# Configuration for the contributed libraries -OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray labltk +OTHERLIBRARIES=win32unix str num win32graph dynlink bigarray systhreads labltk ### Name of the target architecture for the "num" library BNG_ARCH=ia32 @@ -150,7 +149,8 @@ BNG_ASM_LEVEL=1 # There must be no spaces or special characters in $(TK_ROOT) TK_ROOT=c:/tcl TK_DEFS=-I$(TK_ROOT)/include -TK_LINK=$(TK_ROOT)/lib/tk84.lib $(TK_ROOT)/lib/tcl84.lib +TK_LINK=$(TK_ROOT)/bin/tk83.dll $(TK_ROOT)/bin/tcl83.dll -lws2_32 +#TK_LINK=$(TK_ROOT)/lib/tk84.lib $(TK_ROOT)/lib/tcl84.lib -lws2_32 ############# Aliases for common commands diff --git a/config/Makefile.msvc b/config/Makefile.msvc index 0e91a9a458..d932e87973 100644 --- a/config/Makefile.msvc +++ b/config/Makefile.msvc @@ -60,16 +60,16 @@ SUPPORTS_SHARED_LIBRARIES=true SHAREDCCCOMPOPTS= NATIVECCPROFOPTS= NATIVECCRPATH= -ASFLAGS= +ASM=ml /nologo /coff /Cp /c /Fo ASPP= -ASPPFLAGS= ASPPPROFFLAGS= PROFILING=noprof DYNLINKOPTS= -DEBUGGER= +DEBUGGER=ocamldebugger CC_PROFILE= SYSTHREAD_SUPPORT=true EXTRALIBS= +CMXS=cmxs ########## Configuration for the bytecode compiler @@ -77,36 +77,28 @@ EXTRALIBS= BYTECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE ### Additional compile-time options for $(BYTECC). (For static linking.) -BYTECCCOMPOPTS=/Ox /MT +BYTECCCOMPOPTS=/Ox /MD ### Additional link-time options for $(BYTECC). (For static linking.) -BYTECCLINKOPTS=/MT +BYTECCLINKOPTS=/MD /F16777216 ### Additional compile-time options for $(BYTECC). (For building a DLL.) -DLLCCCOMPOPTS=/Ox /MD -DCAML_DLL +DLLCCCOMPOPTS=/Ox /MD ### Libraries needed -BYTECCLIBS=advapi32.lib -NATIVECCLIBS=advapi32.lib +BYTECCLIBS=advapi32.lib ws2_32.lib +NATIVECCLIBS=advapi32.lib ws2_32.lib ### How to invoke the C preprocessor CPP=cl /nologo /EP -### How to merge a .manifest (if any) in a .exe -MERGEMANIFESTEXE=test ! -f $(1).manifest || mt -nologo -outputresource:$(1) -manifest $(1).manifest && rm -f $(1).manifest -#ml let mergemanifestexe out = Printf.sprintf "test ! -f %s.manifest || mt -nologo -outputresource:%s -manifest %s.manifest && rm -f %s.manifest" out out out out;; - -### How to build an EXE -MKEXE=$(BYTECC) /Fe$(1) $(2) && ($(MERGEMANIFESTEXE)) -#ml let mkexe out files opts = Printf.sprintf "%s /Fe%s %s %s && (%s)" bytecc out opts files (mergemanifestexe out);; - -### How to merge a .manifest (if any) in a .dll -MERGEMANIFESTDLL=test ! -f $(1).manifest || mt -nologo -outputresource:"$(1);\#2" -manifest $(1).manifest && rm -f $(1).manifest -#ml let mergemanifestdll out = Printf.sprintf "test ! -f %s.manifest || mt -nologo -outputresource:\"%s;\\#2\" -manifest %s.manifest && rm -f %s.manifest" out out out out;; - -### How to build a DLL -MKDLL=link /nologo /dll /out:$(1) /implib:$(2) $(3) && ($(MERGEMANIFESTDLL)) -#ml let mkdll out implib files opts = Printf.sprintf "link /nologo /dll /out:%s /implib:%s %s %s && (%s)" out implib opts files (mergemanifestdll out);; +### Flexlink +FLEXLINK=flexlink -merge-manifest +FLEXDIR=$(shell $(FLEXLINK) -where) +IFLEXDIR=-I"$(FLEXDIR)" +MKDLL=$(FLEXLINK) +MKEXE=$(FLEXLINK) -exe +MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library MKLIB=link /lib /nologo /out:$(1) $(2) @@ -118,7 +110,7 @@ SYSLIB=$(1).lib #ml let syslib x = x ^ ".lib";; ### The ranlib command -RANLIB= +RANLIB=echo RANLIBCMD= ############# Configuration for the native-code compiler @@ -136,13 +128,12 @@ SYSTEM=win32 NATIVECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE ### Additional compile-time options for $(NATIVECC). -NATIVECCCOMPOPTS=/Ox /MT +NATIVECCCOMPOPTS=/Ox /MD ### Additional link-time options for $(NATIVECC) -NATIVECCLINKOPTS=/MT +NATIVECCLINKOPTS=/MD /F16777216 ### Build partially-linked object file -PARTIALLD=link /lib /nologo PACKLD=link /lib /nologo /out:# there must be no space after this '/out:' ############# Configuration for the contributed libraries @@ -161,10 +152,11 @@ TK_DEFS=-I$(TK_ROOT)/include # produced by OCaml, and is therefore required for binary distribution # of these libraries. However, $(TK_ROOT) must be added to the LIB # environment variable, as described in README.win32. -TK_LINK=tk84.lib tcl84.lib +#TK_LINK=tk84.lib tcl84.lib ws2_32.lib +TK_LINK=tk83.lib tcl83.lib ws2_32.lib # An alternative definition that avoids mucking with the LIB variable, # but hard-wires the Tcl/Tk location in the binaries -# TK_LINK=$(TK_ROOT)/tk83.lib $(TK_ROOT)/tcl83.lib +# TK_LINK=$(TK_ROOT)/tk83.lib $(TK_ROOT)/tcl83.lib ws2_32.lib ############# Aliases for common commands diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64 index f6f3e81e45..a067fd0653 100644 --- a/config/Makefile.msvc64 +++ b/config/Makefile.msvc64 @@ -61,15 +61,15 @@ SUPPORTS_SHARED_LIBRARIES=true SHAREDCCCOMPOPTS= NATIVECCPROFOPTS= NATIVECCRPATH= -ASFLAGS= +ASM=ml64 /nologo /Cp /c /Fo ASPP= -ASPPFLAGS= ASPPPROFFLAGS= PROFILING=noprof DYNLINKOPTS= -DEBUGGER= +DEBUGGER=ocamldebugger CC_PROFILE= SYSTHREAD_SUPPORT=true +CMXS=cmxs ########## Configuration for the bytecode compiler @@ -77,36 +77,32 @@ SYSTHREAD_SUPPORT=true BYTECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE ### Additional compile-time options for $(BYTECC). (For static linking.) -BYTECCCOMPOPTS=/Ox /MT +BYTECCCOMPOPTS=/Ox /MD ### Additional compile-time options for $(BYTECC). (For debug version.) BYTECCDBGCOMPOPTS=-DDEBUG /Zi /W3 /Wp64 ### Additional link-time options for $(BYTECC). (For static linking.) -BYTECCLINKOPTS=/MT +BYTECCLINKOPTS=/MD /F33554432 ### Additional compile-time options for $(BYTECC). (For building a DLL.) -DLLCCCOMPOPTS=/Ox /MD -DCAML_DLL +DLLCCCOMPOPTS=/Ox /MD ### Libraries needed EXTRALIBS=bufferoverflowu.lib -BYTECCLIBS=advapi32.lib $(EXTRALIBS) -NATIVECCLIBS=advapi32.lib $(EXTRALIBS) +BYTECCLIBS=advapi32.lib ws2_32.lib $(EXTRALIBS) +NATIVECCLIBS=advapi32.lib ws2_32.lib $(EXTRALIBS) ### How to invoke the C preprocessor CPP=cl /nologo /EP -### How to merge a .manifest (if any) in a .exe or .dll -MERGEMANIFEST=test ! -f $(1).manifest || mt -nologo -outputresource:$(1) -manifest $(1).manifest && rm -f $(1).manifest -#ml let mergemanifest out = Printf.sprintf "test ! -f %s.manifest || mt -nologo -outputresource:%s -manifest %s.manifest && rm -f %s.manifest" out out out out;; - -### How to build an EXE -MKEXE=$(BYTECC) /Fe$(1) $(2) && ($(MERGEMANIFEST)) -#ml let mkexe out files opts = Printf.sprintf "%s /Fe%s %s %s && (%s)" bytecc out opts files (mergemanifest out);; - -### How to build a DLL -MKDLL=link /nologo /dll /machine:AMD64 /out:$(1) /implib:$(2) $(3) $(EXTRALIBS) && ($(MERGEMANIFEST)) -#ml let mkdll out implib files opts = Printf.sprintf "link /nologo /dll /machine:AMD64 /out:%s /implib:%s %s %s && (%s)" out implib opts files (mergemanifest out);; +### Flexlink +FLEXLINK=flexlink -x64 -merge-manifest +FLEXDIR=$(shell $(FLEXLINK) -where) +IFLEXDIR=-I"$(FLEXDIR)" +MKDLL=$(FLEXLINK) +MKEXE=$(FLEXLINK) -exe +MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library MKLIB=link /lib /nologo /machine:AMD64 /out:$(1) $(2) @@ -118,7 +114,7 @@ SYSLIB=$(1).lib #ml let syslib x = x ^ ".lib";; ### The ranlib command -RANLIB= +RANLIB=echo RANLIBCMD= ############# Configuration for the native-code compiler @@ -136,13 +132,12 @@ SYSTEM=win64 NATIVECC=cl /nologo ### Additional compile-time options for $(NATIVECC). -NATIVECCCOMPOPTS=/Ox /MT +NATIVECCCOMPOPTS=/Ox /MD ### Additional link-time options for $(NATIVECC) -NATIVECCLINKOPTS=/MT +NATIVECCLINKOPTS=/MD /F33554432 ### Build partially-linked object file -PARTIALLD=link /lib /nologo /machine:AMD64 PACKLD=link /lib /nologo /machine:AMD64 /out:# there must be no space after this '/out:' ############# Configuration for the contributed libraries diff --git a/config/auto-aux/stackov.c b/config/auto-aux/stackov.c index a1aa0b7ecf..7f06e9711f 100644 --- a/config/auto-aux/stackov.c +++ b/config/auto-aux/stackov.c @@ -43,7 +43,7 @@ static void segv_handler(int signo, siginfo_t * info, void * context) int main(int argc, char ** argv) { - struct sigaltstack stk; + stack_t stk; struct sigaction act; stk.ss_sp = sig_alt_stack; @@ -23,6 +23,8 @@ mandir='' manext=1 host_type=unknown ccoption='' +asoption='' +asppoption='' cclibs='' curseslibs='' mathlib='-lm' @@ -78,6 +80,10 @@ while : ; do host_type=$2; shift;; -cc*) ccoption="$2"; shift;; + -as) + asoption="$2"; shift;; + -aspp) + asppoption="$2"; shift;; -lib*) cclibs="$2 $cclibs"; shift;; -dldefs*|--dldefs*) @@ -267,10 +273,13 @@ esac # Configure the bytecode compiler bytecc="$cc" +mkexe="\$(BYTECC)" bytecccompopts="" bytecclinkopts="" +dllccompopts="" ostype="Unix" exe="" +iflexdir="" case "$bytecc,$host" in cc,*-*-nextstep*) @@ -325,6 +334,11 @@ case "$bytecc,$host" in bytecccompopts="-D_XOPEN_SOURCE=500";; gcc*,*-*-cygwin*) bytecccompopts="-fno-defer-pop $gcc_warnings -U_WIN32" + dllccompopts="-D_WIN32 -DCAML_DLL" + flexlink="flexlink -chain cygwin -merge-manifest" + flexdir=`$flexlink -where | dos2unix` + iflexdir="-I\"$flexdir\"" + mkexe="$flexlink -exe" exe=".exe" ostype="Cygwin";; gcc*,x86_64-*-linux*) @@ -519,27 +533,36 @@ sharedcccompopts='' mksharedlib='' byteccrpath='' mksharedlibrpath='' +natdynlinkopts="" +cmxs="cmxa" if test $withsharedlibs = "yes"; then case "$host" in - *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-netbsd*|*-*-gnu*) + *-*-cygwin*) + cmxs="cmxs" + mksharedlib="$flexlink" + mkmaindll="$flexlink -maindll" + shared_libraries_supported=true;; + *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-openbsd*|*-*-netbsd*|*-*-gnu*) + cmxs="cmxs" sharedcccompopts="-fPIC" - mksharedlib="$bytecc -shared -o" + mksharedlib="$bytecc -shared" bytecclinkopts="$bytecclinkopts -Wl,-E" byteccrpath="-Wl,-rpath," mksharedlibrpath="-Wl,-rpath," + natdynlinkopts="-Wl,-E" shared_libraries_supported=true;; alpha*-*-osf*) case "$bytecc" in gcc*) sharedcccompopts="-fPIC" - mksharedlib="$bytecc -shared -o" + mksharedlib="$bytecc -shared" byteccrpath="-Wl,-rpath," mksharedlibrpath="-Wl,-rpath," shared_libraries_supported=true;; cc*) sharedcccompopts="" - mksharedlib="ld -shared -expect_unresolved '*' -o" + mksharedlib="ld -shared -expect_unresolved '*'" byteccrpath="-Wl,-rpath," mksharedlibrpath="-rpath " shared_libraries_supported=true;; @@ -549,12 +572,13 @@ if test $withsharedlibs = "yes"; then gcc*) sharedcccompopts="-fPIC" if sh ./solaris-ld; then - mksharedlib="$bytecc -shared -o" + mksharedlib="$bytecc -shared" byteccrpath="-R" mksharedlibrpath="-R" else - mksharedlib="$bytecc -shared -o" + mksharedlib="$bytecc -shared" bytecclinkopts="$bytecclinkopts -Wl,-E" + natdynlinkopts="-Wl,-E" byteccrpath="-Wl,-rpath," mksharedlibrpath="-Wl,-rpath," fi @@ -563,7 +587,7 @@ if test $withsharedlibs = "yes"; then sharedcccompopts="-KPIC" byteccrpath="-R" mksharedlibrpath="-R" - mksharedlib="/usr/ccs/bin/ld -G -o" + mksharedlib="/usr/ccs/bin/ld -G" shared_libraries_supported=true;; esac;; mips*-*-irix[56]*) @@ -571,26 +595,45 @@ if test $withsharedlibs = "yes"; then cc*) sharedcccompopts="";; gcc*) sharedcccompopts="-fPIC";; esac - mksharedlib="ld -shared -rdata_shared -o" + mksharedlib="ld -shared -rdata_shared" byteccrpath="-Wl,-rpath," mksharedlibrpath="-rpath " shared_libraries_supported=true;; + i[3456]86-*-darwin*) + dyld=ld + if test -f /usr/bin/ld_classic; then + # The new linker in Mac OS X 10.5 does not support read_only_relocs + # dyld=/usr/bin/ld_classic XXX FIXME incompatible with X11 libs + : + fi + mksharedlib="$dyld -bundle -flat_namespace -undefined suppress -read_only_relocs suppress" + bytecccompopts="$dl_defs $bytecccompopts" + dl_needs_underscore=false + shared_libraries_supported=true;; *-apple-darwin*) - mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress -o" + mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress" bytecccompopts="$dl_defs $bytecccompopts" #sharedcccompopts="-fnocommon" - dl_needs_underscore=true + dl_needs_underscore=false + shared_libraries_supported=true;; + m88k-*-openbsd*) + shared_libraries_supported=false;; + vax-*-openbsd*) + shared_libraries_supported=false;; + *-*-openbsd*) + sharedcccompopts="-fPIC" + mksharedlib="$bytecc -shared" + bytecclinkopts="$bytecclinkopts -Wl,-E" + natdynlinkopts="-Wl,-E" + byteccrpath="-Wl,-rpath," + mksharedlibrpath="-Wl,-rpath," shared_libraries_supported=true;; esac fi -# Further machine-specific hacks - -case "$host" in - ia64-*-linux*|alpha*-*-linux*|x86_64-*-linux*) - 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 @@ -623,7 +666,7 @@ case "$host" in hppa2.0*-*-hpux*) arch=hppa; system=hpux;; hppa*-*-linux*) arch=hppa; system=linux;; hppa*-*-gnu*) arch=hppa; system=gnu;; - powerpc-*-linux*) arch=power; model=ppc; system=elf;; + powerpc*-*-linux*) arch=power; model=ppc; system=elf;; powerpc-*-netbsd*) arch=power; model=ppc; system=elf;; powerpc-*-rhapsody*) arch=power; model=ppc; system=rhapsody;; powerpc-*-darwin*) arch=power; system=rhapsody @@ -640,6 +683,17 @@ case "$host" in x86_64-*-openbsd*) arch=amd64; system=openbsd;; esac +# Some platforms exist both in 32-bit and 64-bit variants, not distinguished +# by $host. Turn off native code compilation on platforms where 64-bit mode +# is not supported. (PR#4441) + +if $arch64; then + case "$arch,$model" in + sparc,default|mips,default|hppa,default|power,ppc) + arch=none; model=default; system=unknown;; + esac +fi + if test -z "$ccoption"; then case "$arch,$system,$cc" in alpha,digital,gcc*) nativecc=cc;; @@ -668,40 +722,46 @@ case "$arch,$nativecc,$system,$host_type" in *,gcc*,*,*) nativecccompopts="$gcc_warnings";; esac -asflags='' -aspp='$(AS)' -asppflags='' asppprofflags='-DPROFILING' case "$arch,$model,$system" in - alpha,*,digital) 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) 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)';; - *) 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';; @@ -1014,10 +1074,8 @@ if sh ./hasgot -i locale.h && sh ./hasgot setlocale; then echo "#define HAS_LOCALE" >> s.h fi -if sh ./hasgot -i mach-o/dyld.h && sh ./hasgot NSLinkModule; then - echo "NSLinkModule() found. Using darwin dynamic loading." - echo "#define HAS_NSLINKMODULE" >> s.h -elif sh ./hasgot $dllib dlopen; then + +if sh ./hasgot $dllib dlopen; then echo "dlopen() found." elif sh ./hasgot $dllib -ldl dlopen; then echo "dlopen() found in -ldl." @@ -1245,6 +1303,7 @@ for dir in \ /usr/x386/lib \ /usr/XFree86/lib/X11 \ \ + /usr/lib64 \ /usr/lib \ /usr/local/lib \ /usr/unsupported/lib \ @@ -1259,12 +1318,16 @@ do if test -f $dir/libX11.a || \ test -f $dir/libX11.so || \ test -f $dir/libX11.dll.a || \ + test -f $dir/libX11.dylib || \ test -f $dir/libX11.sa; then if test $dir = /usr/lib; then x11_link="-lX11" else - x11_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 @@ -1357,6 +1420,9 @@ if test $has_tk = true; then tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c` for tk_incs in \ "-I/usr/local/include" \ + "-I/usr/include" \ + "-I/usr/local/include/tcl8.5 -I/usr/local/include/tk8.5" \ + "-I/usr/include/tcl8.5 -I/usr/include/tk8.5" \ "-I/usr/local/include/tcl8.4 -I/usr/local/include/tk8.4" \ "-I/usr/include/tcl8.4 -I/usr/include/tk8.4" \ "-I/usr/local/include/tcl8.3 -I/usr/local/include/tk8.3" \ @@ -1379,6 +1445,7 @@ if test $has_tk = true; then 8.2) tclmaj=8 tclmin=2 tkmaj=8 tkmin=2 ;; 8.3) tclmaj=8 tclmin=3 tkmaj=8 tkmin=3 ;; 8.4) tclmaj=8 tclmin=4 tkmaj=8 tkmin=4 ;; + 8.5) tclmaj=8 tclmin=5 tkmaj=8 tkmin=5 ;; *) echo "This version is not known."; has_tk=false ;; esac else @@ -1414,7 +1481,10 @@ if test $has_tk = true; then -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin -lpthread $tkauxlibs \ Tcl_DoOneEvent then - tk_libs="-L/usr/pkg/lib $tk_libs $tk_x11_libs -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin -lpthread $tkauxlibs" + case "$host" in + *-*-*bsd*) tk_libs="-R/usr/pkg/lib -L/usr/pkg/lib $tk_libs $tk_x11_libs -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin -lpthread $tkauxlibs";; + *) tk_libs="-L/usr/pkg/lib $tk_libs $tk_x11_libs -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin -lpthread $tkauxlibs";; + esac else echo "Tcl library not found." has_tk=false @@ -1425,11 +1495,17 @@ if test $has_tk = true; then if sh ./hasgot $tk_libs $tk_x11_libs $tkauxlibs Tk_SetGrid; then echo "Tcl/Tk libraries found." elif sh ./hasgot -L/sw/lib $tk_libs $tk_x11_libs $tkauxlibs Tk_SetGrid; then - tk_libs="-L/sw/lib $tk_libs" + case "$host" in + *-*-*bsd*) tk_libs="-R/sw/lib -L/sw/lib $tk_libs";; + *) tk_libs="-L/sw/lib $tk_libs";; + esac echo "Tcl/Tk libraries found." elif sh ./hasgot -L/usr/pkg/lib $tk_libs $tk_x11_libs $tkauxlibs \ Tk_SetGrid; then - tk_libs="-L/usr/pkg/lib $tk_libs" + case "$host" in + *-*-*bsd*) tk_libs="-R/usr/pkg/lib -L/usr/pkg/lib $tk_libs";; + *) tk_libs="-L/usr/pkg/lib $tk_libs";; + esac echo "Tcl/Tk libraries found." else echo "Tcl library found." @@ -1475,17 +1551,11 @@ echo "EXE=$exe" >> Makefile echo "SUPPORTS_SHARED_LIBRARIES=$shared_libraries_supported" >> Makefile echo "SHAREDCCCOMPOPTS=$sharedcccompopts" >> Makefile echo "MKSHAREDLIBRPATH=$mksharedlibrpath" >> Makefile +echo "NATDYNLINKOPTS=$natdynlinkopts" >> Makefile cat >> Makefile <<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;; @@ -1499,9 +1569,8 @@ echo "NATIVECCPROFOPTS=$nativeccprofopts" >> Makefile echo "NATIVECCLINKOPTS=$nativecclinkopts" >> Makefile echo "NATIVECCRPATH=$nativeccrpath" >> Makefile echo "NATIVECCLIBS=$cclibs $dllib" >> Makefile -echo "ASFLAGS=$asflags" >> Makefile +echo "ASM=$as" >> Makefile echo "ASPP=$aspp" >> Makefile -echo "ASPPFLAGS=$asppflags" >> Makefile echo "ASPPPROFFLAGS=$asppprofflags" >> Makefile echo "PROFILING=$profiling" >> Makefile echo "DYNLINKOPTS=$dllib" >> Makefile @@ -1510,9 +1579,12 @@ echo "DEBUGGER=$debugger" >> Makefile echo "CC_PROFILE=$cc_profile" >> Makefile echo "SYSTHREAD_SUPPORT=$systhread_support" >> Makefile echo "PARTIALLD=$partialld" >> Makefile -echo "DLLCCCOMPOPTS=" >> Makefile +echo "PACKLD=\$(PARTIALLD) \$(NATIVECCLINKOPTS) -o " >> Makefile +echo "DLLCCCOMPOPTS=$dllccompopts" >> Makefile +echo "IFLEXDIR=$iflexdir" >> Makefile echo "O=o" >> Makefile echo "A=a" >> Makefile +echo "SO=so" >> Makefile echo "EXT_OBJ=.o" >> Makefile echo "EXT_ASM=.s" >> Makefile echo "EXT_LIB=.a" >> Makefile @@ -1520,6 +1592,10 @@ echo "EXT_DLL=.so" >> Makefile echo "EXTRALIBS=" >> Makefile echo "CCOMPTYPE=cc" >> Makefile echo "TOOLCHAIN=cc" >> Makefile +echo "CMXS=$cmxs" >> Makefile +echo "MKEXE=$mkexe" >> Makefile +echo "MKDLL=$mksharedlib" >> Makefile +echo "MKMAINDLL=$mkmaindll" >> Makefile rm -f tst hasgot.c rm -f ../m.h ../s.h ../Makefile @@ -1549,7 +1625,7 @@ echo " options for linking....... $bytecclinkopts $cclibs $dllib $cursesl if $shared_libraries_supported; then echo " shared libraries are supported" echo " options for compiling..... $sharedcccompopts $bytecccompopts" -echo " command for building...... $mksharedlib lib.so $mksharedlibrpath/a/path objs" +echo " command for building...... $mksharedlib -o lib.so $mksharedlibrpath/a/path objs" else echo " shared libraries not supported" fi @@ -1569,8 +1645,8 @@ else echo " C compiler used........... $nativecc" echo " options for compiling..... $nativecccompopts" echo " options for linking....... $nativecclinkopts $cclibs" - echo " assembler ................ \$(AS) $asflags" - echo " preprocessed assembler ... $aspp $asppflags" + echo " assembler ................ $as" + echo " preprocessed assembler ... $aspp" if test "$profiling" = "prof"; then echo " profiling with gprof ..... supported" else diff --git a/driver/compile.ml b/driver/compile.ml index 0de3392a7b..645fff437f 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -48,12 +48,35 @@ let initial_env () = with Not_found -> fatal_error "cannot open pervasives.cmi" +(* Note: this function is duplicated in optcompile.ml *) +let check_unit_name ppf filename name = + try + begin match name.[0] with + | 'A'..'Z' -> () + | _ -> + Location.print_warning (Location.in_file filename) ppf + (Warnings.Bad_module_name name); + raise Exit; + end; + for i = 1 to String.length name - 1 do + match name.[i] with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> () + | _ -> + Location.print_warning (Location.in_file filename) ppf + (Warnings.Bad_module_name name); + raise Exit; + done; + with Exit -> () +;; + (* Compile a .mli file *) let interface ppf sourcefile outputprefix = + Location.input_name := sourcefile; init_path (); let modulename = String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in + check_unit_name ppf sourcefile modulename; Env.set_unit_name modulename; let inputfile = Pparse.preprocess sourcefile in try @@ -81,9 +104,11 @@ let print_if ppf flag printer arg = let (++) x f = f x let implementation ppf sourcefile outputprefix = + Location.input_name := sourcefile; init_path (); let modulename = String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in + check_unit_name ppf sourcefile modulename; Env.set_unit_name modulename; let inputfile = Pparse.preprocess sourcefile in let env = initial_env() in @@ -95,7 +120,7 @@ let implementation ppf sourcefile outputprefix = with x -> Pparse.remove_preprocessed_if_ast inputfile; raise x - end else begin + end else begin let objfile = outputprefix ^ ".cmo" in let oc = open_out_bin objfile in try @@ -111,14 +136,17 @@ let implementation ppf sourcefile outputprefix = ++ print_if ppf Clflags.dump_instr Printinstr.instrlist ++ Emitcode.to_file oc modulename; Warnings.check_fatal (); - Pparse.remove_preprocessed inputfile; close_out oc; + Pparse.remove_preprocessed inputfile; + Stypes.dump (outputprefix ^ ".annot"); with x -> close_out oc; remove_file objfile; Pparse.remove_preprocessed_if_ast inputfile; + Stypes.dump (outputprefix ^ ".annot"); raise x end let c_file name = + Location.input_name := name; if Ccomp.compile_file name <> 0 then exit 2 diff --git a/driver/errors.ml b/driver/errors.ml index 56c4e2f3cb..22dd1fc6a0 100644 --- a/driver/errors.ml +++ b/driver/errors.ml @@ -13,7 +13,8 @@ (* $Id$ *) (* WARNING: if you change something in this file, you must look at - opterrors.ml to see if you need to make the same changes there. + opterrors.ml and ocamldoc/odoc_analyse.ml + to see if you need to make the same changes there. *) open Format @@ -23,47 +24,58 @@ open Format let report_error ppf exn = let report ppf = function | Lexer.Error(err, loc) -> - Location.print ppf loc; + Location.print_error ppf loc; Lexer.report_error ppf err | Syntaxerr.Error err -> Syntaxerr.report_error ppf err | Pparse.Error -> + Location.print_error_cur_file ppf; fprintf ppf "Preprocessor error" | Env.Error err -> + Location.print_error_cur_file ppf; Env.report_error ppf err - | Ctype.Tags(l, l') -> fprintf ppf + | Ctype.Tags(l, l') -> + Location.print_error_cur_file ppf; + fprintf ppf "In this program,@ variant constructors@ `%s and `%s@ \ have the same hash value.@ Change one of them." l l' | Typecore.Error(loc, err) -> - Location.print ppf loc; Typecore.report_error ppf err + Location.print_error ppf loc; Typecore.report_error ppf err | Typetexp.Error(loc, err) -> - Location.print ppf loc; Typetexp.report_error ppf err + Location.print_error ppf loc; Typetexp.report_error ppf err | Typedecl.Error(loc, err) -> - Location.print ppf loc; Typedecl.report_error ppf err + Location.print_error ppf loc; Typedecl.report_error ppf err | Typeclass.Error(loc, err) -> - Location.print ppf loc; Typeclass.report_error ppf err + Location.print_error ppf loc; Typeclass.report_error ppf err | Includemod.Error err -> + Location.print_error_cur_file ppf; Includemod.report_error ppf err | Typemod.Error(loc, err) -> - Location.print ppf loc; Typemod.report_error ppf err + Location.print_error ppf loc; Typemod.report_error ppf err | Translcore.Error(loc, err) -> - Location.print ppf loc; Translcore.report_error ppf err + Location.print_error ppf loc; Translcore.report_error ppf err | Translclass.Error(loc, err) -> - Location.print ppf loc; Translclass.report_error ppf err + Location.print_error ppf loc; Translclass.report_error ppf err | Translmod.Error(loc, err) -> - Location.print ppf loc; Translmod.report_error ppf err + Location.print_error ppf loc; Translmod.report_error ppf err | Symtable.Error code -> + Location.print_error_cur_file ppf; Symtable.report_error ppf code | Bytelink.Error code -> + Location.print_error_cur_file ppf; Bytelink.report_error ppf code | Bytelibrarian.Error code -> + Location.print_error_cur_file ppf; Bytelibrarian.report_error ppf code | Bytepackager.Error code -> + Location.print_error_cur_file ppf; Bytepackager.report_error ppf code | Sys_error msg -> + Location.print_error_cur_file ppf; fprintf ppf "I/O error: %s" msg | Warnings.Errors (n) -> - fprintf ppf "@.Error: error-enabled warnings (%d occurrences)" n + Location.print_error_cur_file ppf; + fprintf ppf "Error-enabled warnings (%d occurrences)" n | x -> fprintf ppf "@]"; raise x in fprintf ppf "@[%a@]@." report exn diff --git a/driver/main.ml b/driver/main.ml index 3c365f2f07..8c90134542 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -95,15 +95,15 @@ module Options = Main_args.Make_options (struct let set r () = r := true let unset r () = r := false let _a = set make_archive + let _annot = set annotations let _c = set compile_only - let _cc s = c_compiler := s; c_linker := s + let _cc s = c_compiler := 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 @@ -147,12 +147,13 @@ module Options = Main_args.Make_options (struct let anonymous = anonymous end) +let fatal err = + prerr_endline err; + exit 2 + let extract_output = function | Some s -> s - | None -> - prerr_endline - "Please specify the name of the output file, using option -o"; - exit 2 + | None -> fatal "Please specify the name of the output file, using option -o" let default_output = function | Some s -> s @@ -161,6 +162,12 @@ let default_output = function let main () = try Arg.parse Options.list anonymous usage; + if + List.length (List.filter (fun x -> !x) + [make_archive;make_package;compile_only;output_c_object]) > 1 + then + fatal "Please specify at most one of -pack, -a, -c, -output-obj"; + if !make_archive then begin Compile.init_path(); Bytelibrarian.create_archive (List.rev !objfiles) @@ -172,8 +179,24 @@ let main () = (extract_output !output_name) end else if not !compile_only && !objfiles <> [] then begin + let target = + if !output_c_object then + let s = extract_output !output_name in + if (Filename.check_suffix s Config.ext_obj + || Filename.check_suffix s Config.ext_dll + || Filename.check_suffix s ".c") + then s + else + fatal + (Printf.sprintf + "The extension of the output file must be .c, %s or %s" + Config.ext_obj Config.ext_dll + ) + else + default_output !output_name + in Compile.init_path(); - Bytelink.link (List.rev !objfiles) (default_output !output_name) + Bytelink.link (List.rev !objfiles) target end; exit 0 with x -> diff --git a/driver/main_args.ml b/driver/main_args.ml index b4bc031a7c..47472c247f 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -15,6 +15,7 @@ module Make_options (F : sig val _a : unit -> unit + val _annot : unit -> unit val _c : unit -> unit val _cc : string -> unit val _cclib : string -> unit @@ -23,7 +24,6 @@ module Make_options (F : val _custom : unit -> unit val _dllib : string -> unit val _dllpath : string -> unit - val _dtypes : unit -> unit val _g : unit -> unit val _i : unit -> unit val _I : string -> unit @@ -66,6 +66,7 @@ module Make_options (F : 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"; @@ -79,7 +80,7 @@ struct "<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"; diff --git a/driver/main_args.mli b/driver/main_args.mli index d84e783986..ed6d9bb960 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -15,6 +15,7 @@ module Make_options (F : sig val _a : unit -> unit + val _annot : unit -> unit val _c : unit -> unit val _cc : string -> unit val _cclib : string -> unit @@ -23,7 +24,6 @@ module Make_options (F : val _custom : unit -> unit val _dllib : string -> unit val _dllpath : string -> unit - val _dtypes : unit -> unit val _g : unit -> unit val _i : unit -> unit val _I : string -> unit diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 105fe47bf7..9c9aa857d0 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -45,14 +45,37 @@ let initial_env () = then Env.initial else Env.open_pers_signature "Pervasives" Env.initial with Not_found -> - fatal_error "cannot open Pervasives.cmi" + fatal_error "cannot open pervasives.cmi" + +(* Note: this function is duplicated in compile.ml *) +let check_unit_name ppf filename name = + try + begin match name.[0] with + | 'A'..'Z' -> () + | _ -> + Location.print_warning (Location.in_file filename) ppf + (Warnings.Bad_module_name name); + raise Exit; + end; + for i = 1 to String.length name - 1 do + match name.[i] with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> () + | _ -> + Location.print_warning (Location.in_file filename) ppf + (Warnings.Bad_module_name name); + raise Exit; + done; + with Exit -> () +;; (* Compile a .mli file *) let interface ppf sourcefile outputprefix = + Location.input_name := sourcefile; init_path (); let modulename = String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in + check_unit_name ppf sourcefile modulename; Env.set_unit_name modulename; let inputfile = Pparse.preprocess sourcefile in try @@ -66,9 +89,11 @@ let interface ppf sourcefile outputprefix = Warnings.check_fatal (); if not !Clflags.print_types then Env.save_signature sg modulename (outputprefix ^ ".cmi"); - Pparse.remove_preprocessed inputfile + Pparse.remove_preprocessed inputfile; + Stypes.dump (outputprefix ^ ".annot"); with e -> Pparse.remove_preprocessed_if_ast inputfile; + Stypes.dump (outputprefix ^ ".annot"); raise e (* Compile a .ml file *) @@ -81,9 +106,11 @@ let (++) x f = f x let (+++) (x, y) f = (x, f y) let implementation ppf sourcefile outputprefix = + Location.input_name := sourcefile; init_path (); let modulename = String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in + check_unit_name ppf sourcefile modulename; Env.set_unit_name modulename; let inputfile = Pparse.preprocess sourcefile in let env = initial_env() in diff --git a/driver/opterrors.ml b/driver/opterrors.ml index 6a5f032e0f..581781997d 100644 --- a/driver/opterrors.ml +++ b/driver/opterrors.ml @@ -23,49 +23,61 @@ open Format let report_error ppf exn = let report ppf = function | Lexer.Error(err, l) -> - Location.print ppf l; + Location.print_error ppf l; Lexer.report_error ppf err | Syntaxerr.Error err -> Syntaxerr.report_error ppf err | Pparse.Error -> + Location.print_error_cur_file ppf; fprintf ppf "Preprocessor error" | Env.Error err -> + Location.print_error_cur_file ppf; Env.report_error ppf err - | Ctype.Tags(l, l') -> fprintf ppf + | Ctype.Tags(l, l') -> + Location.print_error_cur_file ppf; + fprintf ppf "In this program,@ variant constructors@ `%s and `%s@ \ have the same hash value.@ Change one of them." l l' | Typecore.Error(loc, err) -> - Location.print ppf loc; Typecore.report_error ppf err + Location.print_error ppf loc; Typecore.report_error ppf err | Typetexp.Error(loc, err) -> - Location.print ppf loc; Typetexp.report_error ppf err + Location.print_error ppf loc; Typetexp.report_error ppf err | Typedecl.Error(loc, err) -> - Location.print ppf loc; Typedecl.report_error ppf err + Location.print_error ppf loc; Typedecl.report_error ppf err | Typeclass.Error(loc, err) -> - Location.print ppf loc; Typeclass.report_error ppf err + Location.print_error ppf loc; Typeclass.report_error ppf err | Includemod.Error err -> + Location.print_error_cur_file ppf; Includemod.report_error ppf err | Typemod.Error(loc, err) -> - Location.print ppf loc; Typemod.report_error ppf err + Location.print_error ppf loc; Typemod.report_error ppf err | Translcore.Error(loc, err) -> - Location.print ppf loc; Translcore.report_error ppf err + Location.print_error ppf loc; Translcore.report_error ppf err | Translclass.Error(loc, err) -> - Location.print ppf loc; Translclass.report_error ppf err + Location.print_error ppf loc; Translclass.report_error ppf err | Translmod.Error(loc, err) -> - Location.print ppf loc; Translmod.report_error ppf err + Location.print_error ppf loc; Translmod.report_error ppf err | Compilenv.Error code -> + Location.print_error_cur_file ppf; Compilenv.report_error ppf code | Asmgen.Error code -> + Location.print_error_cur_file ppf; Asmgen.report_error ppf code | Asmlink.Error code -> + Location.print_error_cur_file ppf; Asmlink.report_error ppf code | Asmlibrarian.Error code -> + Location.print_error_cur_file ppf; Asmlibrarian.report_error ppf code | Asmpackager.Error code -> + Location.print_error_cur_file ppf; Asmpackager.report_error ppf code | Sys_error msg -> + Location.print_error_cur_file ppf; fprintf ppf "I/O error: %s" msg | Warnings.Errors (n) -> - fprintf ppf "@.Error: error-enabled warnings (%d occurrences)" n + Location.print_error_cur_file ppf; + fprintf ppf "Error-enabled warnings (%d occurrences)" n | x -> fprintf ppf "@]"; raise x in fprintf ppf "@[%a@]@." report exn diff --git a/driver/optmain.ml b/driver/optmain.ml index 0bd4037554..7d3048a58f 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -32,11 +32,8 @@ let process_implementation_file ppf name = let process_file ppf name = if Filename.check_suffix name ".ml" - || Filename.check_suffix name ".mlt" then begin - let opref = output_prefix name in - Optcompile.implementation ppf name opref; - objfiles := (opref ^ ".cmx") :: !objfiles - end + || Filename.check_suffix name ".mlt" then + process_implementation_file ppf name else if Filename.check_suffix name !Config.interface_suffix then begin let opref = output_prefix name in Optcompile.interface ppf name opref; @@ -77,12 +74,14 @@ let print_version_string () = let print_standard_library () = print_string Config.standard_library; print_newline(); exit 0 +let fatal err = + prerr_endline err; + exit 2 + let extract_output = function | Some s -> s | None -> - prerr_endline - "Please specify the name of the output file, using option -o"; - exit 2 + fatal "Please specify the name of the output file, using option -o" let default_output = function | Some s -> s @@ -98,13 +97,14 @@ let show_config () = let main () = native_code := true; c_compiler := Config.native_c_compiler; - c_linker := Config.native_c_linker; let ppf = Format.err_formatter in try Arg.parse (Arch.command_line_options @ [ "-a", Arg.Set make_archive, " Build a library"; + "-annot", Arg.Set annotations, + " Save information in <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 := s), "<comp> Use <comp> as the C compiler and linker"; "-cclib", Arg.String(fun s -> ccobjs := Misc.rev_split_words s @ !ccobjs), @@ -115,12 +115,13 @@ let main () = " Optimize code size rather than speed"; "-config", Arg.Unit show_config, " print configuration values and exit"; - "-dtypes", Arg.Set save_types, - " Save type information in <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), @@ -140,7 +141,9 @@ let main () = " Link all modules, even unused ones"; "-noassert", Arg.Set noassert, " Don't compile assertion checks"; "-noautolink", Arg.Set no_auto_link, - " Don't automatically link C libraries specified in .cma files"; + " Don't automatically link C libraries specified in .cmxa files"; + "-nodynlink", Arg.Clear dlcode, + " Enable optimizations for code that will not be dynlinked"; "-nolabels", Arg.Set classic, " Ignore non-optional labels in types"; "-nostdlib", Arg.Set no_std_include, " do not add standard directory to the list of include directories"; @@ -159,6 +162,8 @@ let main () = " Check principality of type inference"; "-rectypes", Arg.Set recursive_types, " Allow arbitrary recursive types"; + "-shared", Arg.Unit (fun () -> shared := true; dlcode := true), + " Produce a dynlinkable plugin"; (*> JOCAML *) "-nojoin", Arg.Unit (fun () -> nojoin := true ; use_threads := false), " Be a ocaml compiler"; @@ -219,19 +224,44 @@ let main () = "-", 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 -> diff --git a/emacs/README b/emacs/README index f6bf63e842..7ddb362b4e 100644 --- a/emacs/README +++ b/emacs/README @@ -63,6 +63,14 @@ For other bindings, see C-h b. Changes log: ----------- +Version 3.10.1: +--------------- +* use caml-font.el from Olivier Andrieu + old version is left as caml-font-old.el for compatibility + +Version 3.07: +------------- +* support for showing type information <Damien Doligez> Version 3.05: ------------- @@ -195,4 +203,4 @@ in other cases may confuse the phrase selection function. Comments and bug reports to - Jacques Garrigue <garrigue@kurims.kyoto-u.ac.jp> + Jacques Garrigue <garrigue@math.nagoya-u.ac.jp> diff --git a/emacs/caml-font.el b/emacs/caml-font.el index d302e8c7a9..299f1ce79c 100644 --- a/emacs/caml-font.el +++ b/emacs/caml-font.el @@ -1,140 +1,114 @@ -;(***********************************************************************) -;(* *) -;(* Objective Caml *) -;(* *) -;(* Jacques Garrigue and Ian T Zimmerman *) -;(* *) -;(* Copyright 1997 Institut National de Recherche en Informatique et *) -;(* en Automatique. All rights reserved. This file is distributed *) -;(* under the terms of the GNU General Public License. *) -;(* *) -;(***********************************************************************) +;; caml-font: font-lock support for OCaml files +;; +;; rewrite and clean-up. +;; Changes: +;; - fontify strings and comments using syntactic font lock +;; - define a `font-lock-syntactic-face-function' to fontify ocamldoc comments +;; - fontify infix operators like mod, land, lsl, etc. +;; - fontify line number directives +;; - fontify "failwith" and "invalid_arg" like "raise" +;; - fontify '\x..' character constants +;; - use the regexp-opt function to build regexps (more readable) +;; - use backquote and comma in sexp (more readable) +;; - drop the `caml-quote-char' variable (I don't use caml-light :)) +;; - stop doing weird things with faces -;(* $Id$ *) -;; useful colors +(require 'font-lock) -(cond - ((x-display-color-p) - (require 'font-lock) - (cond - ((not (boundp 'font-lock-type-face)) - ; make the necessary faces - (make-face 'Firebrick) - (set-face-foreground 'Firebrick "Firebrick") - (make-face 'RosyBrown) - (set-face-foreground 'RosyBrown "RosyBrown") - (make-face 'Purple) - (set-face-foreground 'Purple "Purple") - (make-face 'MidnightBlue) - (set-face-foreground 'MidnightBlue "MidnightBlue") - (make-face 'DarkGoldenRod) - (set-face-foreground 'DarkGoldenRod "DarkGoldenRod") - (make-face 'DarkOliveGreen) - (set-face-foreground 'DarkOliveGreen "DarkOliveGreen4") - (make-face 'CadetBlue) - (set-face-foreground 'CadetBlue "CadetBlue") - ; assign them as standard faces - (setq font-lock-comment-face 'Firebrick) - (setq font-lock-string-face 'RosyBrown) - (setq font-lock-keyword-face 'Purple) - (setq font-lock-function-name-face 'MidnightBlue) - (setq font-lock-variable-name-face 'DarkGoldenRod) - (setq font-lock-type-face 'DarkOliveGreen) - (setq font-lock-reference-face 'CadetBlue))) - ; extra faces for documention - (make-face 'Stop) - (set-face-foreground 'Stop "White") - (set-face-background 'Stop "Red") - (make-face 'Doc) - (set-face-foreground 'Doc "Red") - (setq font-lock-stop-face 'Stop) - (setq font-lock-doccomment-face 'Doc) -)) +(defvar caml-font-stop-face + (progn + (make-face 'caml-font-stop-face) + (set-face-foreground 'caml-font-stop-face "White") + (set-face-background 'caml-font-stop-face "Red") + 'caml-font-stop-face)) -; The same definition is in caml.el: -; we don't know in which order they will be loaded. -(defvar caml-quote-char "'" - "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.") +(defvar caml-font-doccomment-face + (progn + (make-face 'caml-font-doccomment-face) + (set-face-foreground 'caml-font-doccomment-face "Red") + 'caml-font-doccomment-face)) + +(unless (facep 'font-lock-preprocessor-face) + (defvar font-lock-preprocessor-face + (copy-face 'font-lock-builtin-face + 'font-lock-preprocessor-face))) (defconst caml-font-lock-keywords - (list -;stop special comments - '("\\(^\\|[^\"]\\)\\((\\*\\*/\\*\\*)\\)" - 2 font-lock-stop-face) -;doccomments - '("\\(^\\|[^\"]\\)\\((\\*\\*[^*]*\\([^)*][^*]*\\*+\\)*)\\)" - 2 font-lock-doccomment-face) -;comments - '("\\(^\\|[^\"]\\)\\((\\*[^*]*\\*+\\([^)*][^*]*\\*+\\)*)\\)" - 2 font-lock-comment-face) + `( ;character literals - (cons (concat caml-quote-char "\\(\\\\\\([ntbr" caml-quote-char "\\]\\|" - "[0-9][0-9][0-9]\\)\\|.\\)" caml-quote-char - "\\|\"[^\"\\]*\\(\\\\\\(.\\|\n\\)[^\"\\]*\\)*\"") - 'font-lock-string-face) + ("'\\(.\\|\\\\\\([ntbr\"'\\\\]\\|[0-9]\\{3\\}\\|x[0-9A-Fa-f]\\{2\\}\\)\\)'" + . font-lock-string-face) ;modules and constructors - '("`?\\<[A-Z][A-Za-z0-9_']*\\>" . font-lock-function-name-face) + ("`?\\<[A-Z][A-Za-z0-9_']*\\>" . font-lock-function-name-face) ;definition - (cons (concat - "\\<\\(a\\(nd\\|s\\)\\|c\\(onstraint\\|lass\\)\\|def" - "\\|ex\\(ception\\|ternal\\)\\|fun\\(ct\\(ion\\|or\\)\\)?" - "\\|in\\(herit\\|itializer\\)?\\|let" - "\\|m\\(ethod\\|utable\\|odule\\)" - "\\|o\\(f\\|r\\)\\|p\\(arser\\|rivate\\)\\|rec\\|type" - "\\|v\\(al\\|irtual\\)\\)\\>") - 'font-lock-type-face) + (,(regexp-opt '("and" "as" "constraint" "class" "def" + "exception" "external" "fun" "function" "functor" + "in" "inherit" "initializer" "let" + "method" "mutable" "module" "of" "or" "private" "rec" + "type" "val" "virtual") + 'words) + . font-lock-type-face) ;blocking - '("\\<\\(begin\\|end\\|object\\|s\\(ig\\|truct\\)\\)\\>" - . font-lock-keyword-face) + (,(regexp-opt '("begin" "end" "object" "sig" "struct") 'words) + . font-lock-keyword-face) +;linenums + ("# *[0-9]+" . font-lock-preprocessor-face) +;infix operators + (,(regexp-opt '("asr" "land" "lor" "lsl" "lsr" "lxor" "mod") 'words) + . font-lock-builtin-face) ;control - (cons (concat - "\\<\\(do\\(ne\\|wnto\\)?\\|else\\|for\\|i\\(f\\|gnore\\)" - "\\|lazy\\|match\\|new\\|reply\\|spawn\\|t\\(hen\\|o\\|ry\\)" - "\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\)\\>" - "\\|\|\\|->\\|&\\|#") - 'font-lock-reference-face) - '("\\<raise\\>" . font-lock-comment-face) + (,(concat "[|#&]\\|->\\|" + (regexp-opt '("do" "done" "dowto" "else" "for" "if" "ignore" + "lazy" "match" "new" "reply" + "spawn" "then" "to" "try" + "when" "while" "with") + 'words)) + . font-lock-constant-face) + ("\\<raise\\|failwith\\|invalid_arg\\>" + . font-lock-comment-face) ;labels (and open) - '("\\(\\([~?]\\|\\<\\)[a-z][a-zA-Z0-9_']*:\\)[^:=]" 1 - font-lock-variable-name-face) - '("\\<\\(assert\\|open\\|include\\)\\>\\|[~?][ (]*[a-z][a-zA-Z0-9_']*" - . font-lock-variable-name-face))) + ("\\(\\([~?]\\|\\<\\)[a-z][a-zA-Z0-9_']*:\\)[^:=]" + 1 font-lock-variable-name-face) + ("\\<\\(assert\\|open\\|include\\)\\>\\|[~?][ (]*[a-z][a-zA-Z0-9_']*" + . font-lock-variable-name-face))) -(defconst inferior-caml-font-lock-keywords - (append - (list -;inferior - '("^[#-]" . font-lock-comment-face)) - caml-font-lock-keywords)) -;; font-lock commands are similar for caml-mode and inferior-caml-mode -(add-hook 'caml-mode-hook - '(lambda () - (cond - ((fboundp 'global-font-lock-mode) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - '(caml-font-lock-keywords nil nil ((?' . "w") (?_ . "w"))))) - (t - (setq font-lock-keywords caml-font-lock-keywords))) - (make-local-variable 'font-lock-keywords-only) - (setq font-lock-keywords-only t) - (font-lock-mode 1))) +(defun caml-font-syntactic-face (s) + (let ((in-string (nth 3 s)) + (in-comment (nth 4 s)) + (start (nth 8 s))) + (cond + (in-string 'font-lock-string-face) + (in-comment + (goto-char start) + (cond + ((looking-at "(\\*\\*/\\*\\*)") 'caml-font-stop-face) + ((looking-at "(\\*\\*[^*]") 'caml-font-doccomment-face) + (t 'font-lock-comment-face)))))) -(defun inferior-caml-mode-font-hook () - (cond - ((fboundp 'global-font-lock-mode) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - '(inferior-caml-font-lock-keywords - nil nil ((?' . "w") (?_ . "w"))))) - (t - (setq font-lock-keywords inferior-caml-font-lock-keywords))) - (make-local-variable 'font-lock-keywords-only) - (setq font-lock-keywords-only t) + +;; font-lock commands are similar for caml-mode and inferior-caml-mode +(defun caml-font-set-font-lock () + (setq font-lock-defaults + '(caml-font-lock-keywords + nil nil nil nil + (font-lock-syntactic-face-function . caml-font-syntactic-face))) (font-lock-mode 1)) +(add-hook 'caml-mode-hook 'caml-font-set-font-lock) -(add-hook 'inferior-caml-mode-hooks 'inferior-caml-mode-font-hook) + + +(defconst inferior-caml-font-lock-keywords + `(("^[#-]" . font-lock-comment-face) + ,@caml-font-lock-keywords)) + +(defun inferior-caml-set-font-lock () + (setq font-lock-defaults + '(inferior-caml-font-lock-keywords + nil nil nil nil + (font-lock-syntactic-face-function . caml-font-syntactic-face))) + (font-lock-mode 1)) +(add-hook 'inferior-caml-mode-hooks 'inferior-caml-set-font-lock) (provide 'caml-font) diff --git a/emacs/caml-types.el b/emacs/caml-types.el index 74ec5be9e1..44f09a031e 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -12,12 +12,12 @@ ;(* $Id$ *) -; An emacs-lisp complement to the "-dtypes" option of ocamlc and ocamlopt. +; An emacs-lisp complement to the "-annot" option of ocamlc and ocamlopt. ;; XEmacs compatibility (eval-and-compile - (if (and (boundp 'running-xemacs) running-xemacs) + (if (and (boundp 'running-xemacs) running-xemacs) (require 'caml-xemacs) (require 'caml-emacs))) @@ -25,15 +25,15 @@ (defvar caml-types-location-re nil "Regexp to parse *.annot files. -Annotation files *.annot may be generated with the \"-dtypes\" option -of ocamlc and ocamlopt. +Annotation files *.annot may be generated with the \"-annot\" option +of ocamlc and ocamlopt. Their format is: file ::= block * block ::= position <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) @@ -52,38 +52,60 @@ Their format is: - the char number within the line is the difference between the third and second nums. -For the moment, the only possible keyword is \"type\"." +The current list of keywords is: +type call ident" ) (let* ((caml-types-filename-re "\"\\(\\([^\\\"]\\|\\\\.\\)*\\)\"") - (caml-types-number-re "\\([0-9]*\\)") - (caml-types-position-re + (caml-types-number-re "\\([0-9]*\\)")) + (setq caml-types-position-re (concat caml-types-filename-re " " caml-types-number-re " " caml-types-number-re " " - caml-types-number-re))) + caml-types-number-re)) (setq caml-types-location-re (concat "^" caml-types-position-re " " caml-types-position-re))) (defvar caml-types-expr-ovl (make-overlay 1 1)) - -(make-face 'caml-types-face) -(set-face-doc-string 'caml-types-face +(make-face 'caml-types-expr-face) +(set-face-doc-string 'caml-types-expr-face "face for hilighting expressions and types") -(if (not (face-differs-from-default-p 'caml-types-face)) - (set-face-background 'caml-types-face "#88FF44")) +(if (not (face-differs-from-default-p 'caml-types-expr-face)) + (set-face-background 'caml-types-expr-face "#88FF44")) +(overlay-put caml-types-expr-ovl 'face 'caml-types-expr-face) (defvar caml-types-typed-ovl (make-overlay 1 1)) - (make-face 'caml-types-typed-face) (set-face-doc-string 'caml-types-typed-face "face for hilighting typed expressions") (if (not (face-differs-from-default-p 'caml-types-typed-face)) (set-face-background 'caml-types-typed-face "#FF8844")) - -(overlay-put caml-types-expr-ovl 'face 'caml-types-face) (overlay-put caml-types-typed-ovl 'face 'caml-types-typed-face) +(defvar caml-types-scope-ovl (make-overlay 1 1)) +(make-face 'caml-types-scope-face) +(set-face-doc-string 'caml-types-scope-face + "face for hilighting variable scopes") +(if (not (face-differs-from-default-p 'caml-types-scope-face)) + (set-face-background 'caml-types-scope-face "#BBFFFF")) +(overlay-put caml-types-scope-ovl 'face 'caml-types-scope-face) + +(defvar caml-types-def-ovl (make-overlay 1 1)) +(make-face 'caml-types-def-face) +(set-face-doc-string 'caml-types-def-face + "face for hilighting binding occurrences") +(if (not (face-differs-from-default-p 'caml-types-def-face)) + (set-face-background 'caml-types-def-face "#FF4444")) +(overlay-put caml-types-def-ovl 'face 'caml-types-def-face) + +(defvar caml-types-occ-ovl (make-overlay 1 1)) +(make-face 'caml-types-occ-face) +(set-face-doc-string 'caml-types-occ-face + "face for hilighting variable occurrences") +(if (not (face-differs-from-default-p 'caml-types-occ-face)) + (set-face-background 'caml-types-occ-face "#44FF44")) +(overlay-put caml-types-occ-ovl 'face 'caml-types-occ-face) + (defvar caml-types-annotation-tree nil) (defvar caml-types-annotation-date nil) @@ -113,7 +135,7 @@ For the moment, the only possible keyword is \"type\"." in the file, up to where the type checker failed. Types are also displayed in the buffer *caml-types*, which is -displayed when the command is called with Prefix argument 4. +displayed when the command is called with Prefix argument 4. See also `caml-types-explore' for exploration by mouse dragging. See `caml-types-location-re' for annotation file format. @@ -124,13 +146,11 @@ See `caml-types-location-re' for annotation file format. (target-line (1+ (count-lines (point-min) (caml-line-beginning-position)))) (target-bol (caml-line-beginning-position)) - (target-cnum (point)) - (type-file (concat (file-name-sans-extension (buffer-file-name)) - ".annot"))) - (caml-types-preprocess type-file) + (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 () + (node (caml-types-find-location targ-loc "type" () caml-types-annotation-tree))) (cond ((null node) @@ -139,7 +159,7 @@ See `caml-types-location-re' for annotation file format. (t (let ((left (caml-types-get-pos target-buf (elt node 0))) (right (caml-types-get-pos target-buf (elt node 1))) - (type (elt node 2))) + (type (cdr (assoc "type" (elt node 2))))) (move-overlay caml-types-expr-ovl left right target-buf) (with-current-buffer caml-types-buffer (erase-buffer) @@ -154,28 +174,195 @@ See `caml-types-location-re' for annotation file format. (delete-overlay caml-types-expr-ovl) ))) -(defun caml-types-preprocess (type-file) - (let* ((type-date (nth 5 (file-attributes type-file))) +(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)))) (target-date (nth 5 (file-attributes target-file)))) (unless (and caml-types-annotation-tree type-date caml-types-annotation-date (not (caml-types-date< caml-types-annotation-date type-date))) (if (and type-date target-date (caml-types-date< type-date target-date)) - (error (format "%s is more recent than %s" target-file type-file))) + (error (format "`%s' is more recent than `%s'" target-path type-path))) (message "Reading annotation file...") - (let* ((type-buf (caml-types-find-file type-file)) + (let* ((type-buf (caml-types-find-file type-path)) (tree (with-current-buffer type-buf (widen) (goto-char (point-min)) - (caml-types-build-tree target-file)))) + (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) + (let ((sibling (concat (file-name-sans-extension target-path) ".annot"))) + (if (file-exists-p sibling) + sibling + (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 + (expand-file-name + (file-relative-name sibling project-dir) + (expand-file-name "_build" project-dir))))) + (if (equal project-dir (parent-dir project-dir)) + (error (concat "No annotation file. " + "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)) @@ -191,18 +378,26 @@ See `caml-types-location-re' for annotation file format. (symbol-name (intern elem table))) +(defun next-annotation () + (forward-char 1) + (if (re-search-forward "^[a-z\"]" () t) + (forward-char -1) + (goto-char (point-max))) + (looking-at "[a-z]") +) + ; tree of intervals ; each node is a vector -; [ pos-left pos-right type-info child child child... ] -; type-info = -; () if this node does not correspond to an annotated interval -; (type-start . type-end) address of the annotation in the .annot file +; [ pos-left pos-right annotation child child child... ] +; annotation is a list of: +; (kind . info) where kind = "type" "call" etc. +; and info = the contents of the annotation (defun caml-types-build-tree (target-file) (let ((stack ()) (accu ()) (table (caml-types-make-hash-table)) - (type-info ())) + (annotation ())) (while (re-search-forward caml-types-location-re () t) (let ((l-file (file-name-nondirectory (match-string 1))) (l-line (string-to-int (match-string 3))) @@ -213,14 +408,13 @@ See `caml-types-location-re' for annotation file format. (r-bol (string-to-int (match-string 9))) (r-cnum (string-to-int (match-string 10)))) (unless (caml-types-not-in-file l-file r-file target-file) - (while (and (re-search-forward "^" () t) - (not (looking-at "type")) - (not (looking-at "\\\""))) - (forward-char 1)) - (setq type-info - (if (looking-at - "^type(\n\\( \\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)") - (caml-types-hcons (match-string 1) table))) + (setq annotation ()) + (while (next-annotation) + (cond ((looking-at + "^\\([a-z]+\\)(\n \\(\\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)") + (let ((kind (caml-types-hcons (match-string 1) table)) + (info (caml-types-hcons (match-string 2) table))) + (setq annotation (cons (cons kind info) annotation)))))) (setq accu ()) (while (and stack (caml-types-pos-contains l-cnum r-cnum (car stack))) @@ -228,7 +422,7 @@ See `caml-types-location-re' for annotation file format. (setq stack (cdr stack))) (let* ((left-pos (vector l-file l-line l-bol l-cnum)) (right-pos (vector r-file r-line r-bol r-cnum)) - (node (caml-types-make-node left-pos right-pos type-info + (node (caml-types-make-node left-pos right-pos annotation accu))) (setq stack (cons node stack)))))) (if (null stack) @@ -245,12 +439,12 @@ See `caml-types-location-re' for annotation file format. (and (not (string= r-file target-file)) (not (string= r-file ""))))) -(defun caml-types-make-node (left-pos right-pos type-info children) +(defun caml-types-make-node (left-pos right-pos annotation children) (let ((result (make-vector (+ 3 (length children)) ())) (i 3)) (aset result 0 left-pos) (aset result 1 right-pos) - (aset result 2 type-info) + (aset result 2 annotation) (while children (aset result i (car children)) (setq children (cdr children)) @@ -261,15 +455,15 @@ See `caml-types-location-re' for annotation file format. (and (<= l-cnum (elt (elt node 0) 3)) (>= r-cnum (elt (elt node 1) 3)))) -(defun caml-types-find-location (targ-pos curr node) +(defun caml-types-find-location (targ-pos kind curr node) (if (not (caml-types-pos-inside targ-pos node)) curr - (if (elt node 2) + (if (and (elt node 2) (assoc kind (elt node 2))) (setq curr node)) (let ((i (caml-types-search node targ-pos))) (if (and (> i 3) (caml-types-pos-inside targ-pos (elt node (1- i)))) - (caml-types-find-location targ-pos curr (elt node (1- i))) + (caml-types-find-location targ-pos kind curr (elt node (1- i))) curr)))) ; trouve le premier fils qui commence apres la position @@ -377,7 +571,7 @@ See `caml-types-location-re' for annotation file format. (with-current-buffer buf (toggle-read-only 1)) ) (t - (error "No annotation file. You should compile with option \"-dtypes\".")) + (error (format "Can't read the annotation file `%s'" name))) ) buf)) @@ -393,12 +587,12 @@ See `caml-types-location-re' for annotation file format. (defun caml-types-explore (event) "Explore type annotations by mouse dragging. -The expression under the mouse is highlighted and its type is displayed +The expression under the mouse is highlighted and its type is displayed in the minibuffer, until the move is released, much as `caml-types-show-type'. -The function uses two overlays. +The function uses two overlays. - . One overlay delimits the largest region whose all subnodes - are well-typed. + . One overlay delimits the largest region whose all subnodes + are well-typed. . Another overlay delimits the current node under the mouse (whose type annotation is beeing displayed). " @@ -406,8 +600,6 @@ The function uses two overlays. (set-buffer (window-buffer (caml-event-window event))) (let* ((target-buf (current-buffer)) (target-file (file-name-nondirectory (buffer-file-name))) - (type-file (concat (file-name-sans-extension (buffer-file-name)) - ".annot")) (target-line) (target-bol) target-pos Left Right limits cnum node mes type @@ -421,7 +613,7 @@ The function uses two overlays. (select-window window) (unwind-protect (progn - (caml-types-preprocess type-file) + (caml-types-preprocess (buffer-file-name)) (setq target-tree caml-types-annotation-tree) (setq caml-types-buffer (get-buffer-create caml-types-buffer-name)) ;; (message "Drag the mouse to explore types") @@ -429,7 +621,7 @@ The function uses two overlays. (caml-track-mouse (while event (cond - ;; we ignore non mouse events + ;; we ignore non mouse events ((caml-ignore-event-p event)) ;; we stop when the original button is released ((caml-release-event-p original-event event) @@ -447,7 +639,7 @@ The function uses two overlays. ) (while (and (caml-sit-for 0 (/ 500 speed)) - (setq time (caml-types-time)) + (setq time (caml-types-time)) (> (- time last-time) (/ 500 speed)) (setq mouse (caml-mouse-vertical-position)) (or (< mouse top) (>= mouse bottom)) @@ -464,7 +656,7 @@ The function uses two overlays. (condition-case nil (scroll-up 1) (error (message "End of buffer!")))) - ) + ) (setq speed (* speed speed)) ))) ;; main action, when the motion is inside the window @@ -476,7 +668,7 @@ The function uses two overlays. (<= (car region) cnum) (< cnum (cdr region))) ;; mouse remains in outer region nil - ;; otherwise, reset the outer region + ;; otherwise, reset the outer region (setq region (caml-types-typed-make-overlay target-buf (caml-event-point-start event)))) @@ -494,7 +686,7 @@ The function uses two overlays. target-pos (vector target-file target-line target-bol cnum)) (save-excursion - (setq node (caml-types-find-location + (setq node (caml-types-find-location "type" target-pos () target-tree)) (set-buffer caml-types-buffer) (erase-buffer) @@ -539,7 +731,7 @@ The function uses two overlays. ;; However, it could also be a key stroke before mouse release. ;; Emacs does not allow to test whether mouse is up or down. ;; Not sure it is robust to loop for mouse release after an error - ;; occured, as is done for exploration. + ;; occured, as is done for exploration. ;; So far, we just ignore next event. (Next line also be uncommenting.) (if event (caml-read-event)) ))) @@ -567,7 +759,7 @@ The function uses two overlays. (defun caml-types-version () "internal version number of caml-types.el" (interactive) - (message "2") + (message "4") ) (provide 'caml-types) diff --git a/emacs/caml.el b/emacs/caml.el index 40c308011e..9eb728fa94 100644 --- a/emacs/caml.el +++ b/emacs/caml.el @@ -298,7 +298,9 @@ have caml-electric-indent on, which see.") (define-key caml-mode-map "\177" 'backward-delete-char-untabify)) ;; caml-types - (define-key caml-mode-map [?\C-c?\C-t] 'caml-types-show-type) + (define-key caml-mode-map [?\C-c?\C-t] 'caml-types-show-type) ; "type" + (define-key caml-mode-map [?\C-c?\C-f] 'caml-types-show-call) ; "function" + (define-key caml-mode-map [?\C-c?\C-l] 'caml-types-show-ident) ; "let" ;; must be a mouse-down event. Can be any button and any prefix (define-key caml-mode-map [?\C-c down-mouse-1] 'caml-types-explore) ;; caml-help @@ -544,12 +546,14 @@ have caml-electric-indent on, which see.") (run-hooks 'caml-mode-hook)) (defun caml-set-compile-command () - "Hook to set compile-command locally, unless there is a Makefile in the - current directory." + "Hook to set compile-command locally, unless there is a Makefile or + a _build directory or a _tags file in the current directory." (interactive) (unless (or (null buffer-file-name) (file-exists-p "makefile") - (file-exists-p "Makefile")) + (file-exists-p "Makefile") + (file-exists-p "_build") + (file-exists-p "_tags")) (let* ((filename (file-name-nondirectory buffer-file-name)) (basename (file-name-sans-extension filename)) (command nil)) @@ -565,7 +569,7 @@ have caml-electric-indent on, which see.") (setq command "ocamlyacc")) ) (if command - (progn + (progn (make-local-variable 'compile-command) (setq compile-command (concat command " " filename)))) ))) @@ -592,7 +596,7 @@ have caml-electric-indent on, which see.") (inferior-caml-eval-region start end)) ;; old version ---to be deleted later -; +; ; (defun caml-eval-phrase () ; "Send the current Caml phrase to the inferior Caml process." ; (interactive) @@ -602,15 +606,15 @@ have caml-electric-indent on, which see.") (defun caml-eval-phrase (arg &optional min max) "Send the phrase containing the point to the CAML process. -With prefix-arg send as many phrases as its numeric value, +With prefix-arg send as many phrases as its numeric value, If an error occurs during evalutaion, stop at this phrase and -repport the error. +repport the error. Return nil if noerror and position of error if any. If arg's numeric value is zero or negative, evaluate the current phrase -or as many as prefix arg, ignoring evaluation errors. -This allows to jump other erroneous phrases. +or as many as prefix arg, ignoring evaluation errors. +This allows to jump other erroneous phrases. Optional arguments min max defines a region within which the phrase should lies." @@ -809,6 +813,10 @@ from an error message produced by camlc.") ;; Wrapper around next-error. (defvar caml-error-overlay nil) +(defvar caml-next-error-skip-warnings-flag nil) + +(defun caml-string-to-int (x) + (if (fboundp 'string-to-number) (string-to-number x) (string-to-int x))) ;;itz 04-21-96 somebody didn't get the documetation for next-error ;;right. When the optional argument is a number n, it should move @@ -825,7 +833,7 @@ fragment. The erroneous fragment is also temporarily highlighted if possible." (if (eq major-mode 'caml-mode) - (let (bol beg end) + (let (skip bol beg end) (save-excursion (set-buffer (if (boundp 'compilation-last-buffer) @@ -835,12 +843,19 @@ possible." (goto-char (window-point (get-buffer-window (current-buffer)))) (if (looking-at caml-error-chars-regexp) (setq beg - (string-to-int + (caml-string-to-int (buffer-substring (match-beginning 1) (match-end 1))) end - (string-to-int - (buffer-substring (match-beginning 2) (match-end 2))))))) - (cond (beg + (caml-string-to-int + (buffer-substring (match-beginning 2) (match-end 2))))) + (next-line) + (beginning-of-line) + (if (and (looking-at "Warning") + caml-next-error-skip-warnings-flag) + (setq skip 't)))) + (cond + (skip (next-error)) + (beg (setq end (- end beg)) (beginning-of-line) (forward-byte beg) @@ -860,6 +875,14 @@ possible." (sit-for 60)) (delete-overlay caml-error-overlay))))))))) +(defun caml-next-error-skip-warnings (&rest args) + (let ((old-flag caml-next-error-skip-warnings-flag)) + (unwind-protect + (progn (setq caml-next-error-skip-warnings-flag 't) + (apply 'next-error args)) + (setq caml-next-error-skip-warnings-flag old-flag)))) + + ;; Usual match-string doesn't work properly with font-lock-mode ;; on some emacs. @@ -973,7 +996,7 @@ to the end. (push-mark) (goto-char beg) (cons beg end))) - + ;;itz Fri Sep 25 12:58:13 PDT 1998 support for adding change-log entries (defun caml-current-defun () (save-excursion @@ -1764,7 +1787,7 @@ by |, insert one." ;; to mark phrases, so that repeated calls will take several of them ;; knows little about Ocaml appart literals and comments, so it should work -;; with other dialects as long as ;; marks the end of phrase. +;; with other dialects as long as ;; marks the end of phrase. (defun caml-indent-phrase (arg) "Indent current phrase diff --git a/lex/lexgen.ml b/lex/lexgen.ml index 5df5bcf10a..1a12f0d49d 100644 --- a/lex/lexgen.ml +++ b/lex/lexgen.ml @@ -626,7 +626,7 @@ type 'a dfa_state = {final : int * ('a * int TagMap.t) ; others : ('a * int TagMap.t) MemMap.t} -(* + let dtag oc t = fprintf oc "%s<%s>" t.id (if t.start then "s" else "e") @@ -653,7 +653,7 @@ let dstate {final=(act,(_,m)) ; others=o} = dtag_map (fun x -> eprintf "%d" x) (fun () -> prerr_string " ,") m) (fun () -> prerr_endline "") o -*) + let dfa_state_empty = {final=(no_action, (max_int,TagMap.empty)) ; @@ -752,18 +752,25 @@ let tag_cells = Hashtbl.create 17 let state_table = Table.create dfa_state_empty -let reset_state_mem () = - state_map := StateMap.empty; +(* Initial reset of state *) +let reset_state () = Stack.clear todo; next_state_num := 0 ; let _ = Table.trim state_table in () -(* Allocation of memory cells *) -let reset_cell_mem ntags = +(* Reset state before processing a given automata. + We clear both the memory mapping and + the state mapping, as state sharing beetween different + automata may lead to incorret estimation of the cell memory size + BUG ID 0004517 *) + + +let reset_state_partial ntags = next_mem_cell := ntags ; Hashtbl.clear tag_cells ; - temp_pending := false + temp_pending := false ; + state_map := StateMap.empty let do_alloc_temp () = temp_pending := true ; @@ -1095,7 +1102,6 @@ let translate_state shortest_match tags chars follow st = reachs chars follow st.others) end -(* let dtags chan tags = Tags.iter (fun t -> fprintf chan " %a" dtag t) @@ -1117,7 +1123,7 @@ let dfollow t = dtransset t.(i) done ; prerr_endline "]" -*) + let make_tag_entry id start act a r = match a with | Sum (Mem m,0) -> @@ -1146,13 +1152,13 @@ let make_dfa lexdef = (* dfollow follow ; *) - reset_state_mem () ; + reset_state () ; let r_states = ref [] in let initial_states = List.map (fun (le,args,shortest) -> let tags = extract_tags le.lex_actions in - reset_cell_mem le.lex_mem_tags ; + reset_state_partial le.lex_mem_tags ; let pos_set = firstpos le.lex_regexp in (* prerr_string "trans={" ; dtransset pos_set ; prerr_endline "}" ; @@ -1181,6 +1187,7 @@ let make_dfa lexdef = *) let actions = Array.create !next_state_num (Perform (0,[])) in List.iter (fun (act, i) -> actions.(i) <- act) states; - reset_state_mem () ; - reset_cell_mem 0 ; +(* Useless state reset, so as to restrict GC roots *) + reset_state () ; + reset_state_partial 0 ; (initial_states, actions) diff --git a/ocamldoc/.depend b/ocamldoc/.depend index 9e0b54bdca..f9db8e1aec 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -1,8 +1,9 @@ odoc_analyse.cmo: ../utils/warnings.cmi ../typing/typetexp.cmi \ - ../typing/typemod.cmi ../typing/typedtree.cmi ../typing/typedecl.cmi \ - ../typing/typecore.cmi ../typing/typeclass.cmi ../bytecomp/translcore.cmi \ - ../bytecomp/translclass.cmi ../parsing/syntaxerr.cmi ../parsing/parse.cmi \ - odoc_types.cmi odoc_sig.cmi odoc_module.cmo odoc_misc.cmi \ + ../typing/types.cmi ../typing/typemod.cmi ../typing/typedtree.cmi \ + ../typing/typedecl.cmi ../typing/typecore.cmi ../typing/typeclass.cmi \ + ../bytecomp/translcore.cmi ../bytecomp/translclass.cmi \ + ../parsing/syntaxerr.cmi ../parsing/parse.cmi odoc_types.cmi \ + odoc_text.cmi odoc_sig.cmi odoc_module.cmo odoc_misc.cmi \ odoc_messages.cmo odoc_merge.cmi odoc_global.cmi odoc_dep.cmo \ odoc_cross.cmi odoc_comments.cmi odoc_class.cmo odoc_ast.cmi \ odoc_args.cmi ../utils/misc.cmi ../parsing/location.cmi \ @@ -10,10 +11,11 @@ odoc_analyse.cmo: ../utils/warnings.cmi ../typing/typetexp.cmi \ ../typing/ctype.cmi ../utils/config.cmi ../utils/clflags.cmi \ ../utils/ccomp.cmi odoc_analyse.cmi odoc_analyse.cmx: ../utils/warnings.cmx ../typing/typetexp.cmx \ - ../typing/typemod.cmx ../typing/typedtree.cmx ../typing/typedecl.cmx \ - ../typing/typecore.cmx ../typing/typeclass.cmx ../bytecomp/translcore.cmx \ - ../bytecomp/translclass.cmx ../parsing/syntaxerr.cmx ../parsing/parse.cmx \ - odoc_types.cmx odoc_sig.cmx odoc_module.cmx odoc_misc.cmx \ + ../typing/types.cmx ../typing/typemod.cmx ../typing/typedtree.cmx \ + ../typing/typedecl.cmx ../typing/typecore.cmx ../typing/typeclass.cmx \ + ../bytecomp/translcore.cmx ../bytecomp/translclass.cmx \ + ../parsing/syntaxerr.cmx ../parsing/parse.cmx odoc_types.cmx \ + odoc_text.cmx odoc_sig.cmx odoc_module.cmx odoc_misc.cmx \ odoc_messages.cmx odoc_merge.cmx odoc_global.cmx odoc_dep.cmx \ odoc_cross.cmx odoc_comments.cmx odoc_class.cmx odoc_ast.cmx \ odoc_args.cmx ../utils/misc.cmx ../parsing/location.cmx \ @@ -54,6 +56,8 @@ odoc_comments.cmx: odoc_types.cmx odoc_text.cmx odoc_see_lexer.cmx \ odoc_comments_global.cmx odoc_comments.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 \ @@ -79,9 +83,9 @@ odoc_exception.cmx: ../typing/types.cmx odoc_types.cmx odoc_name.cmx odoc_global.cmo: ../utils/clflags.cmi odoc_global.cmi odoc_global.cmx: ../utils/clflags.cmx odoc_global.cmi odoc_html.cmo: odoc_text.cmi odoc_ocamlhtml.cmo odoc_messages.cmo \ - odoc_info.cmi odoc_dag2html.cmi + odoc_info.cmi odoc_dag2html.cmi ../parsing/asttypes.cmi odoc_html.cmx: odoc_text.cmx odoc_ocamlhtml.cmx odoc_messages.cmx \ - odoc_info.cmx odoc_dag2html.cmx + odoc_info.cmx odoc_dag2html.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 \ @@ -94,18 +98,22 @@ odoc_info.cmx: ../typing/printtyp.cmx odoc_value.cmx odoc_types.cmx \ odoc_misc.cmx odoc_messages.cmx odoc_global.cmx odoc_exception.cmx \ odoc_dep.cmx odoc_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 @@ -136,6 +144,8 @@ odoc_name.cmo: ../typing/path.cmi ../parsing/longident.cmi \ ../typing/ident.cmi odoc_name.cmi odoc_name.cmx: ../typing/path.cmx ../parsing/longident.cmx \ ../typing/ident.cmx odoc_name.cmi +odoc_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 \ @@ -164,28 +174,32 @@ odoc_see_lexer.cmo: odoc_parser.cmi odoc_see_lexer.cmx: odoc_parser.cmx odoc_sig.cmo: ../typing/types.cmi ../typing/typedtree.cmi ../typing/path.cmi \ ../parsing/parsetree.cmi odoc_value.cmo odoc_types.cmi odoc_type.cmo \ - odoc_print.cmi odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ - odoc_misc.cmi odoc_messages.cmo odoc_merge.cmi odoc_global.cmi \ - odoc_exception.cmo odoc_env.cmi odoc_class.cmo odoc_args.cmi \ - ../utils/misc.cmi ../parsing/location.cmi ../typing/btype.cmi \ - ../parsing/asttypes.cmi odoc_sig.cmi + odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_misc.cmi \ + odoc_messages.cmo odoc_merge.cmi odoc_global.cmi odoc_exception.cmo \ + odoc_env.cmi odoc_class.cmo odoc_args.cmi ../utils/misc.cmi \ + ../parsing/location.cmi ../typing/btype.cmi ../parsing/asttypes.cmi \ + odoc_sig.cmi odoc_sig.cmx: ../typing/types.cmx ../typing/typedtree.cmx ../typing/path.cmx \ ../parsing/parsetree.cmi odoc_value.cmx odoc_types.cmx odoc_type.cmx \ - odoc_print.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ - odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx odoc_global.cmx \ - odoc_exception.cmx odoc_env.cmx odoc_class.cmx odoc_args.cmx \ - ../utils/misc.cmx ../parsing/location.cmx ../typing/btype.cmx \ - ../parsing/asttypes.cmi odoc_sig.cmi + odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_misc.cmx \ + odoc_messages.cmx odoc_merge.cmx odoc_global.cmx odoc_exception.cmx \ + odoc_env.cmx odoc_class.cmx odoc_args.cmx ../utils/misc.cmx \ + ../parsing/location.cmx ../typing/btype.cmx ../parsing/asttypes.cmi \ + odoc_sig.cmi odoc_str.cmo: ../typing/types.cmi ../typing/printtyp.cmi odoc_value.cmo \ odoc_type.cmo odoc_print.cmi odoc_name.cmi odoc_misc.cmi \ - odoc_messages.cmo odoc_exception.cmo odoc_class.cmo odoc_str.cmi + odoc_messages.cmo odoc_exception.cmo odoc_class.cmo \ + ../parsing/asttypes.cmi odoc_str.cmi odoc_str.cmx: ../typing/types.cmx ../typing/printtyp.cmx odoc_value.cmx \ odoc_type.cmx odoc_print.cmx odoc_name.cmx odoc_misc.cmx \ - odoc_messages.cmx odoc_exception.cmx odoc_class.cmx odoc_str.cmi + odoc_messages.cmx odoc_exception.cmx odoc_class.cmx \ + ../parsing/asttypes.cmi odoc_str.cmi odoc_test.cmo: odoc_info.cmi odoc_test.cmx: odoc_info.cmx -odoc_texi.cmo: odoc_to_text.cmo odoc_messages.cmo odoc_info.cmi -odoc_texi.cmx: odoc_to_text.cmx odoc_messages.cmx odoc_info.cmx +odoc_texi.cmo: odoc_to_text.cmo odoc_messages.cmo odoc_info.cmi \ + ../parsing/asttypes.cmi +odoc_texi.cmx: odoc_to_text.cmx odoc_messages.cmx odoc_info.cmx \ + ../parsing/asttypes.cmi odoc_text_lexer.cmo: odoc_text_parser.cmi odoc_text_lexer.cmx: odoc_text_parser.cmx odoc_text.cmo: odoc_types.cmi odoc_text_parser.cmi odoc_text_lexer.cmo \ @@ -196,8 +210,10 @@ odoc_text_parser.cmo: odoc_types.cmi odoc_misc.cmi odoc_text_parser.cmi odoc_text_parser.cmx: odoc_types.cmx odoc_misc.cmx odoc_text_parser.cmi odoc_to_text.cmo: odoc_messages.cmo odoc_info.cmi odoc_to_text.cmx: odoc_messages.cmx odoc_info.cmx -odoc_type.cmo: ../typing/types.cmi odoc_types.cmi odoc_name.cmi -odoc_type.cmx: ../typing/types.cmx odoc_types.cmx odoc_name.cmx +odoc_type.cmo: ../typing/types.cmi odoc_types.cmi odoc_name.cmi \ + ../parsing/asttypes.cmi +odoc_type.cmx: ../typing/types.cmx odoc_types.cmx odoc_name.cmx \ + ../parsing/asttypes.cmi odoc_types.cmo: odoc_messages.cmo odoc_types.cmi odoc_types.cmx: odoc_messages.cmx odoc_types.cmi odoc_value.cmo: ../typing/types.cmi ../typing/printtyp.cmi odoc_types.cmi \ @@ -208,10 +224,13 @@ odoc_analyse.cmi: odoc_module.cmo odoc_args.cmi odoc_args.cmi: odoc_types.cmi odoc_module.cmo odoc_ast.cmi: ../typing/types.cmi ../typing/typedtree.cmi ../typing/path.cmi \ ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi odoc_module.cmo +odoc_comments_global.cmi: odoc_comments.cmi: odoc_types.cmi +odoc_config.cmi: odoc_cross.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 @@ -229,3 +248,4 @@ odoc_str.cmi: ../typing/types.cmi odoc_value.cmo odoc_type.cmo \ odoc_exception.cmo odoc_class.cmo odoc_text.cmi: odoc_types.cmi odoc_text_parser.cmi: odoc_types.cmi +odoc_types.cmi: diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index f7a9cb86b5..b8cf983a00 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -69,7 +69,7 @@ INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) COMPFLAGS=$(INCLUDES) -warn-error A -LINKFLAGS=$(INCLUDES) +LINKFLAGS=$(INCLUDES) -nostdlib CMOFILES= odoc_config.cmo \ odoc_global.cmo\ @@ -262,7 +262,7 @@ install: dummy if test -d $(INSTALL_BINDIR); then : ; else $(MKDIR) $(INSTALL_BINDIR); fi if test -d $(INSTALL_LIBDIR); then : ; else $(MKDIR) $(INSTALL_LIBDIR); fi if test -d $(INSTALL_CUSTOMDIR); then : ; else $(MKDIR) $(INSTALL_CUSTOMDIR); fi - $(CP) $(OCAMLDOC)$(EXE) $(INSTALL_BINDIR)/$(OCAMLDOC)$(EXE) + $(CP) $(OCAMLDOC) $(INSTALL_BINDIR)/$(OCAMLDOC)$(EXE) $(CP) ocamldoc.hva *.cmi $(OCAMLDOC_LIBCMA) $(INSTALL_LIBDIR) $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR) if test -d $(INSTALL_MANODIR); then : ; else $(MKDIR) $(INSTALL_MANODIR); fi @@ -335,7 +335,7 @@ autotest_stdlib: dummy clean:: dummy @rm -f *~ \#*\# - @rm -f $(OCAMLDOC)$(EXE) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.a *.o + @rm -f $(OCAMLDOC) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.a *.o @rm -f odoc_parser.output odoc_text_parser.output @rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml @rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt index 3a5a4ba24f..9957ce125a 100644 --- a/ocamldoc/Makefile.nt +++ b/ocamldoc/Makefile.nt @@ -63,7 +63,7 @@ INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) COMPFLAGS=$(INCLUDES) -LINKFLAGS=$(INCLUDES) +LINKFLAGS=$(INCLUDES) -nostdlib CMOFILES= odoc_config.cmo \ odoc_global.cmo\ diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 07b03d643d..034f7ce2f5 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -157,35 +157,41 @@ module Sig_analyser = Odoc_sig.Analyser (Odoc_comments.Basic_info_retriever) let process_error exn = let report ppf = function | Lexer.Error(err, loc) -> - Location.print ppf loc; + Location.print_error ppf loc; Lexer.report_error ppf err | Syntaxerr.Error err -> Syntaxerr.report_error ppf err | Env.Error err -> + Location.print_error_cur_file ppf; Env.report_error ppf err - | Ctype.Tags(l, l') -> fprintf ppf + | Ctype.Tags(l, l') -> + Location.print_error_cur_file ppf; + fprintf ppf "In this program,@ variant constructors@ `%s and `%s@ \ have the same hash value." l l' | Typecore.Error(loc, err) -> - Location.print ppf loc; Typecore.report_error ppf err + Location.print_error ppf loc; Typecore.report_error ppf err | Typetexp.Error(loc, err) -> - Location.print ppf loc; Typetexp.report_error ppf err + Location.print_error ppf loc; Typetexp.report_error ppf err | Typedecl.Error(loc, err) -> - Location.print ppf loc; Typedecl.report_error ppf err + Location.print_error ppf loc; Typedecl.report_error ppf err | Includemod.Error err -> + Location.print_error_cur_file ppf; Includemod.report_error ppf err | Typemod.Error(loc, err) -> - Location.print ppf loc; Typemod.report_error ppf err + Location.print_error ppf loc; Typemod.report_error ppf err | Translcore.Error(loc, err) -> - Location.print ppf loc; Translcore.report_error ppf err + Location.print_error ppf loc; Translcore.report_error ppf err | Sys_error msg -> + Location.print_error_cur_file ppf; fprintf ppf "I/O error: %s" msg | Typeclass.Error(loc, err) -> - Location.print ppf loc; Typeclass.report_error ppf err + Location.print_error ppf loc; Typeclass.report_error ppf err | Translclass.Error(loc, err) -> - Location.print ppf loc; Translclass.report_error ppf err + Location.print_error ppf loc; Translclass.report_error ppf err | Warnings.Errors (n) -> - fprintf ppf "@.Error: %d error-enabled warnings occurred." 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." @@ -203,6 +209,7 @@ let process_file ppf sourcefile = match sourcefile with Odoc_args.Impl_file file -> ( + Location.input_name := file; try let (parsetree_typedtree_opt, input_file) = process_implementation_file ppf file in match parsetree_typedtree_opt with @@ -234,6 +241,7 @@ let process_file ppf sourcefile = ) | Odoc_args.Intf_file file -> ( + Location.input_name := file; try let (ast, signat, input_file) = process_interface_file ppf file in let file_module = Sig_analyser.analyse_signature file @@ -260,6 +268,46 @@ let process_file ppf sourcefile = incr Odoc_global.errors ; None ) + | Odoc_args.Text_file file -> + Location.input_name := file; + try + let mod_name = + String.capitalize (Filename.basename (Filename.chop_extension file)) + in + let txt = + try Odoc_text.Texter.text_of_string (Odoc_misc.input_file_as_string file) + with Odoc_text.Text_syntax (l, c, s) -> + raise (Failure (Odoc_messages.text_parse_error l c s)) + in + let m = + { + Odoc_module.m_name = mod_name ; + Odoc_module.m_type = Types.Tmty_signature [] ; + Odoc_module.m_info = None ; + Odoc_module.m_is_interface = true ; + Odoc_module.m_file = file ; + Odoc_module.m_kind = Odoc_module.Module_struct + [Odoc_module.Element_module_comment txt] ; + Odoc_module.m_loc = + { Odoc_types.loc_impl = None ; + Odoc_types.loc_inter = Some (file, 0) } ; + Odoc_module.m_top_deps = [] ; + Odoc_module.m_code = None ; + Odoc_module.m_code_intf = None ; + Odoc_module.m_text_only = true ; + } + in + Some m + with + | Sys_error s + | Failure s -> + prerr_endline s; + incr Odoc_global.errors ; + None + | e -> + process_error e ; + incr Odoc_global.errors ; + None (** Remove the class elements between the stop special comments. *) let rec remove_class_elements_between_stop keep eles = diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml index 05d9e55c11..f535a018b6 100644 --- a/ocamldoc/odoc_args.ml +++ b/ocamldoc/odoc_args.ml @@ -107,6 +107,8 @@ let keep_code = ref false let inverse_merge_ml_mli = ref false +let filter_with_module_constraints = ref true + let title = ref (None : string option) let intro_file = ref (None : string option) @@ -224,6 +226,9 @@ let options = ref [ "-no-custom-tags", Arg.Set no_custom_tags, M.no_custom_tags ; "-stars", Arg.Set remove_stars, M.remove_stars ; "-inv-merge-ml-mli", Arg.Set inverse_merge_ml_mli, M.inverse_merge_ml_mli ; + "-no-module-constraint-filter", Arg.Clear filter_with_module_constraints, + M.no_filter_with_module_constraints ; + "-keep-code", Arg.Set keep_code, M.keep_code^"\n" ; "-dump", Arg.String (fun s -> dump := Some s), M.dump ; diff --git a/ocamldoc/odoc_args.mli b/ocamldoc/odoc_args.mli index e7f2dda8b1..428a2c823f 100644 --- a/ocamldoc/odoc_args.mli +++ b/ocamldoc/odoc_args.mli @@ -68,6 +68,9 @@ val keep_code : bool ref (** To inverse implementation and interface files when merging. *) val inverse_merge_ml_mli : bool ref +(** To filter module elements according to module type constraints. *) +val filter_with_module_constraints : bool ref + (** The optional title to use in the generated documentation. *) val title : string option ref diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index 16b807c711..e282e32654 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -195,6 +195,20 @@ module Typedtree_search = in iter cls.Typedtree.cl_field + let class_sig_of_cltype_decl = + let rec iter = function + Types.Tcty_constr (_, _, cty) -> iter cty + | Types.Tcty_signature s -> s + | Types.Tcty_fun (_,_, cty) -> iter cty + in + fun ct_decl -> iter ct_decl.Types.clty_type + + let search_virtual_attribute_type table ctname name = + let ct_decl = search_class_type_declaration table ctname in + let cls_sig = class_sig_of_cltype_decl ct_decl in + let (_,_,texp) = Types.Vars.find name cls_sig.cty_vars in + texp + let search_method_expression cls name = let rec iter = function | [] -> @@ -485,7 +499,7 @@ module Analyser = (** Analysis of a [Parsetree.class_struture] and a [Typedtree.class_structure] to get a couple (inherited classes, class elements). *) - let analyse_class_structure env current_class_name tt_class_sig last_pos pos_limit p_cls tt_cls = + let analyse_class_structure env current_class_name tt_class_sig last_pos pos_limit p_cls tt_cls table = let rec iter acc_inher acc_fields last_pos = function | [] -> let s = get_string_of_file last_pos pos_limit in @@ -526,12 +540,20 @@ module Analyser = p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum q - | (Parsetree.Pcf_val (label, mutable_flag, expression, loc)) :: q -> + | ((Parsetree.Pcf_val (label, mutable_flag, _, loc) | + Parsetree.Pcf_valvirt (label, mutable_flag, _, loc) ) 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 = { @@ -544,6 +566,7 @@ module Analyser = val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; } ; att_mutable = mutable_flag = Asttypes.Mutable ; + att_virtual = virt ; } in iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end.Lexing.pos_cnum q @@ -630,7 +653,7 @@ module Analyser = iter [] [] last_pos (snd p_cls) (** Analysis of a [Parsetree.class_expr] and a [Typedtree.class_expr] to get a a couple (class parameters, class kind). *) - let rec analyse_class_kind env current_class_name comment_opt last_pos p_class_expr tt_class_exp = + let rec analyse_class_kind env current_class_name comment_opt last_pos p_class_expr tt_class_exp table = match (p_class_expr.Parsetree.pcl_desc, tt_class_exp.Typedtree.cl_desc) with (Parsetree.Pcl_constr (lid, _), tt_class_exp_desc ) -> let name = @@ -674,6 +697,7 @@ module Analyser = p_class_expr.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum p_class_structure tt_class_structure + table in ([], Class_structure (inherited_classes, class_elements) ) @@ -712,7 +736,10 @@ module Analyser = in (new_param, tt_class_expr2) in - let (params, k) = analyse_class_kind env current_class_name comment_opt last_pos p_class_expr2 next_tt_class_exp in + let (params, k) = analyse_class_kind + env current_class_name comment_opt last_pos p_class_expr2 + next_tt_class_exp table + in (parameter :: params, k) | (Parsetree.Pcl_apply (p_class_expr2, _), Tclass_apply (tt_class_expr2, exp_opt_optional_list)) -> @@ -756,12 +783,17 @@ module Analyser = | (Parsetree.Pcl_let (_, _, p_class_expr2), Typedtree.Tclass_let (_, _, _, tt_class_expr2)) -> (* we don't care about these lets *) - analyse_class_kind env current_class_name comment_opt last_pos p_class_expr2 tt_class_expr2 + analyse_class_kind + env current_class_name comment_opt last_pos p_class_expr2 + tt_class_expr2 table | (Parsetree.Pcl_constraint (p_class_expr2, p_class_type2), Typedtree.Tclass_constraint (tt_class_expr2, _, _, _)) -> - let (l, class_kind) = analyse_class_kind env current_class_name comment_opt last_pos p_class_expr2 tt_class_expr2 in - (* A VOIR : analyse du class type ? on n'a pas toutes les infos. cf. Odoc_sig.analyse_class_type_kind *) + let (l, class_kind) = analyse_class_kind + env current_class_name comment_opt last_pos p_class_expr2 + tt_class_expr2 table + in + (* A VOIR : analyse du class type ? on n'a pas toutes les infos. cf. Odoc_sig.analyse_class_type_kind *) let class_type_kind = (*Sig.analyse_class_type_kind env @@ -779,7 +811,7 @@ module Analyser = raise (Failure "analyse_class_kind: Parsetree and typedtree don't match.") (** Analysis of a [Parsetree.class_declaration] and a [Typedtree.class_expr] to return a [t_class].*) - let analyse_class env current_module_name comment_opt p_class_decl tt_type_params tt_class_exp = + let analyse_class env current_module_name comment_opt p_class_decl tt_type_params tt_class_exp table = let name = p_class_decl.Parsetree.pci_name in let complete_name = Name.concat current_module_name name in let pos_start = p_class_decl.Parsetree.pci_expr.Parsetree.pcl_loc.Location.loc_start.Lexing.pos_cnum in @@ -793,6 +825,7 @@ module Analyser = pos_start p_class_decl.Parsetree.pci_expr tt_class_exp + table in let cl = { @@ -1043,6 +1076,7 @@ module Analyser = tt_type_decl.Types.type_params tt_type_decl.Types.type_variance ; ty_kind = kind ; + ty_private = tt_type_decl.Types.type_private; ty_manifest = (match tt_type_decl.Types.type_manifest with None -> None @@ -1304,6 +1338,7 @@ module Analyser = class_decl tt_type_params tt_class_exp + table in ele_comments @ ((Element_class new_class) :: (f last_pos2 q)) in @@ -1503,6 +1538,9 @@ module Analyser = (Name.concat current_module_name "??") p_modtype tt_modtype in + let tt_modtype = Odoc_env.subst_module_type env tt_modtype in + if !Odoc_args.filter_with_module_constraints then + filter_module_with_module_type_constraint m_base2 tt_modtype; { m_base with m_type = Odoc_env.subst_module_type env tt_modtype ; diff --git a/ocamldoc/odoc_cross.ml b/ocamldoc/odoc_cross.ml index 87ecad8b23..5b7191d043 100644 --- a/ocamldoc/odoc_cross.ml +++ b/ocamldoc/odoc_cross.ml @@ -819,13 +819,13 @@ and assoc_comments_type module_list t = t.ty_info <- ao (assoc_comments_info module_list) t.ty_info ; (match t.ty_kind with Type_abstract -> () - | Type_variant (vl, _) -> - List.iter - (fun vc -> vc.vc_text <- ao (assoc_comments_text module_list) vc.vc_text) - vl - | Type_record (fl, _) -> - List.iter - (fun rf -> rf.rf_text <- ao (assoc_comments_text module_list) rf.rf_text) + | Type_variant vl -> + List.iter + (fun vc -> vc.vc_text <- ao (assoc_comments_text parent module_list) vc.vc_text) + vl + | Type_record fl -> + List.iter + (fun rf -> rf.rf_text <- ao (assoc_comments_text parent module_list) rf.rf_text) fl ); t diff --git a/ocamldoc/odoc_dep.ml b/ocamldoc/odoc_dep.ml index 94cd510248..c7ff69346d 100644 --- a/ocamldoc/odoc_dep.ml +++ b/ocamldoc/odoc_dep.ml @@ -147,7 +147,7 @@ let type_deps t = in (match t.T.ty_kind with T.Type_abstract -> () - | T.Type_variant (cl, _) -> + | T.Type_variant cl -> List.iter (fun c -> List.iter @@ -158,7 +158,7 @@ let type_deps t = c.T.vc_args ) cl - | T.Type_record (rl, _) -> + | T.Type_record rl -> List.iter (fun r -> let s = Odoc_print.string_of_type_expr r.T.rf_type in diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index 3aa73c4a5c..ee617e56bf 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -1331,25 +1331,27 @@ class html = self#html_of_type_expr_param_list b father t; (match t.ty_parameters with [] -> () | _ -> bs b " "); bs b ((Name.simple t.ty_name)^" "); + let priv = t.ty_private = Asttypes.Private in ( match t.ty_manifest with None -> () | Some typ -> - bs b "= "; - self#html_of_type_expr b father typ; - bs b " " + 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" ; - bs b - ( - match t.ty_manifest with - None -> "</code>" - | Some _ -> "</pre>" - ); + if priv then bs b "private "; + bs b + ( + match t.ty_manifest with + None -> "</code>" + | Some _ -> "</pre>" + ); bs b "<table class=\"typetable\">\n"; let print_one constr = bs b "<tr>\n<td align=\"left\" valign=\"top\" >\n"; @@ -1387,7 +1389,7 @@ class html = 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 "{"; @@ -1438,12 +1440,17 @@ class html = (* 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 -> @@ -1452,7 +1459,7 @@ class html = 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 @@ -1773,7 +1780,7 @@ class html = (Naming.type_target { ty_name = c.cl_name ; ty_info = None ; ty_parameters = [] ; - ty_kind = Type_abstract ; ty_manifest = None ; + ty_kind = Type_abstract ; ty_private = Asttypes.Public; ty_manifest = None ; ty_loc = Odoc_info.dummy_loc ; ty_code = None ; } @@ -1820,7 +1827,7 @@ class html = (Naming.type_target { ty_name = ct.clt_name ; ty_info = None ; ty_parameters = [] ; - ty_kind = Type_abstract ; ty_manifest = None ; + ty_kind = Type_abstract ; ty_private = Asttypes.Public; ty_manifest = None ; ty_loc = Odoc_info.dummy_loc ; ty_code = None ; } diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli index b6eb967c50..9c995b75c4 100644 --- a/ocamldoc/odoc_info.mli +++ b/ocamldoc/odoc_info.mli @@ -186,6 +186,9 @@ module Exception : (** Representation and manipulation of types.*) module Type : sig + type private_flag = Odoc_type.private_flag = + Private | Public + (** Description of a variant type constructor. *) type variant_constructor = Odoc_type.variant_constructor = { @@ -206,10 +209,10 @@ module Type : (** The various kinds of a type. *) type type_kind = Odoc_type.type_kind = Type_abstract (** Type is abstract, for example [type t]. *) - | Type_variant of variant_constructor list * bool - (** constructors * bool *) - | Type_record of record_field list * bool - (** fields * bool *) + | Type_variant of variant_constructor list + (** constructors *) + | Type_record of record_field list + (** fields *) (** Representation of a type. *) type t_type = Odoc_type.t_type = @@ -218,7 +221,8 @@ module Type : mutable ty_info : info option ; (** Information found in the optional associated comment. *) ty_parameters : (Types.type_expr * bool * bool) list ; (** type parameters: (type, covariant, contravariant) *) - ty_kind : type_kind ; (** Type kind. *) + ty_kind : type_kind; (** Type kind. *) + ty_private : private_flag; (** Private or public type. *) ty_manifest : Types.type_expr option; (** Type manifest. *) mutable ty_loc : location ; mutable ty_code : string option; @@ -246,6 +250,7 @@ module Value : { att_value : t_value ; (** an attribute has almost all the same information as a value *) att_mutable : bool ; (** [true] if the attribute is mutable. *) + att_virtual : bool ; (** [true] if the attribute is virtual. *) } (** Representation of a class method. *) @@ -933,6 +938,12 @@ module Args : (** The optional title to use in the generated documentation. *) val title : string option ref + (** To inverse [.ml] and [.mli] files while merging comments. *) + val inverse_merge_ml_mli : bool ref + + (** To filter module elements according to module type constraints. *) + val filter_with_module_constraints : bool ref + (** To keep the code while merging, when we have both .ml and .mli files for a module. *) val keep_code : bool ref diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml index 09f73dac2e..b2b22471b1 100644 --- a/ocamldoc/odoc_latex.ml +++ b/ocamldoc/odoc_latex.ml @@ -471,28 +471,29 @@ class latex = self#latex_of_type_params fmt2 mod_name t; (match t.ty_parameters with [] -> () | _ -> ps fmt2 " "); ps fmt2 s_name; - ( + let priv = t.ty_private = Asttypes.Private in + ( match t.ty_manifest with None -> () - | Some typ -> - p fmt2 " = %s" (self#normal_type mod_name typ) - ); - let s_type3 = + | Some typ -> + p fmt2 " = %s%s" (if priv then "private " else "") (self#normal_type mod_name typ) + ); + let s_type3 = p fmt2 " %s" ( 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 -> @@ -524,7 +525,7 @@ class latex = l ) ) - | Type_record (l, _) -> + | Type_record l -> (List.flatten (List.map (fun r -> diff --git a/ocamldoc/odoc_lexer.mll b/ocamldoc/odoc_lexer.mll index 353ddfbe13..44ba7bc3e7 100644 --- a/ocamldoc/odoc_lexer.mll +++ b/ocamldoc/odoc_lexer.mll @@ -33,7 +33,7 @@ let ajout_string = Buffer.add_string string_buffer let lecture_string () = Buffer.contents string_buffer -(** The variable which will contain the description string. +(** The variable which will contain the description string. Is initialized when we encounter the start of a special comment. *) let description = ref "" @@ -52,7 +52,7 @@ let remove_blanks s = let rec iter liste = match liste with h :: q -> - let h2 = Str.global_replace (Str.regexp ("^"^blank^"+")) "" h in + let h2 = Str.global_replace (Str.regexp ("^"^blank^"+")) "" h in if h2 = "" then ( print_DEBUG2 (h^" n'a que des blancs"); @@ -66,11 +66,11 @@ let remove_blanks s = [] in iter l in - let l3 = - let rec iter liste = + let l3 = + let rec iter liste = match liste with h :: q -> - let h2 = Str.global_replace (Str.regexp (blank^"+$")) "" h in + let h2 = Str.global_replace (Str.regexp (blank^"+$")) "" h in if h2 = "" then ( print_DEBUG2 (h^" n'a que des blancs"); @@ -91,16 +91,16 @@ let remove_blanks s = let remove_stars s = let s2 = Str.global_replace (Str.regexp ("^"^blank^"*\\*")) "" s in s2 -} +} let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] -let identchar = +let identchar = ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] rule main = parse [' ' '\013' '\009' '\012'] + - { + { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); main lexbuf } @@ -109,36 +109,36 @@ rule main = parse { incr line_number; incr Odoc_comments_global.nb_chars; - main lexbuf + main lexbuf } | "(**)" { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); Description ("", None) - } + } | "(**"("*"+)")" { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); main lexbuf - } + } | "(***" { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); incr comments_level; main lexbuf - } + } | "(**" - { + { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); incr comments_level; if !comments_level = 1 then ( reset_string_buffer (); description := ""; - special_comment lexbuf + special_comment lexbuf ) else main lexbuf @@ -152,24 +152,24 @@ rule main = parse Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); decr comments_level ; main lexbuf - } + } | "(*" { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); incr comments_level ; main lexbuf - } + } | _ - { + { incr Odoc_comments_global.nb_chars; main lexbuf } and special_comment = parse | "*)" - { + { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); if !comments_level = 1 then @@ -177,7 +177,7 @@ and special_comment = parse (* there is just a description *) let s2 = lecture_string () in let s3 = remove_blanks s2 in - let s4 = + let s4 = if !Odoc_args.remove_stars then remove_stars s3 else @@ -200,16 +200,16 @@ and special_comment = parse incr comments_level ; ajout_string s; special_comment lexbuf - } + } | "\\@" - { + { let s = Lexing.lexeme lexbuf in let c = (Lexing.lexeme_char lexbuf 1) in ajout_char_string c; Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); - special_comment lexbuf - } + special_comment lexbuf + } | "@"lowercase+ { @@ -219,38 +219,38 @@ and special_comment = parse reset_string_buffer (); let len = String.length (Lexing.lexeme lexbuf) in lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - len; - lexbuf.Lexing.lex_curr_p <- + lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - len } ; (* we don't increment the Odoc_comments_global.nb_chars *) special_comment_part2 lexbuf - } + } | _ - { + { let c = (Lexing.lexeme_char lexbuf 0) in ajout_char_string c; if c = '\010' then incr line_number; incr Odoc_comments_global.nb_chars; - special_comment lexbuf - } + special_comment lexbuf + } and special_comment_part2 = parse | "*)" - { + { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); if !comments_level = 1 then (* finally we return the description we kept *) - let desc = + let desc = if !Odoc_args.remove_stars then remove_stars !description else !description in let remain = lecture_string () in - let remain2 = + let remain2 = if !Odoc_args.remove_stars then remove_stars remain else @@ -272,20 +272,20 @@ and special_comment_part2 = parse ajout_string s; incr comments_level ; special_comment_part2 lexbuf - } + } | _ - { + { let c = (Lexing.lexeme_char lexbuf 0) in ajout_char_string c; if c = '\010' then incr line_number; incr Odoc_comments_global.nb_chars; - special_comment_part2 lexbuf - } + special_comment_part2 lexbuf + } and elements = parse | [' ' '\013' '\009' '\012'] + - { + { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); elements lexbuf } @@ -297,14 +297,14 @@ and elements = parse elements lexbuf } | "@"lowercase+ - { + { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); let s2 = String.sub s 1 ((String.length s) - 1) in print_DEBUG2 s2; match s2 with "param" -> - T_PARAM + T_PARAM | "author" -> T_AUTHOR | "version" -> @@ -324,25 +324,26 @@ and elements = parse raise (Failure (Odoc_messages.not_a_valid_tag s)) else T_CUSTOM s - } + } | ("\\@" | [^'@'])+ { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); let s = Lexing.lexeme lexbuf in - let s2 = remove_blanks s in - print_DEBUG2 ("Desc "^s2); - Desc s2 - } + let s = Str.global_replace (Str.regexp_string "\\@") "@" s in + let s = remove_blanks s in + print_DEBUG2 ("Desc "^s); + Desc s + } | eof { EOF - } - + } + and simple = parse [' ' '\013' '\009' '\012'] + - { + { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); simple lexbuf } @@ -350,32 +351,32 @@ and simple = parse | [ '\010' ] { incr line_number; incr Odoc_comments_global.nb_chars; - simple lexbuf + simple lexbuf } - | "(**"("*"+) + | "(**"("*"+) { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); incr comments_level; simple lexbuf - } + } | "(*"("*"+)")" { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); simple lexbuf - } + } | "(**" { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); incr comments_level; simple lexbuf - } + } | "(*" - { + { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); incr comments_level; @@ -383,7 +384,7 @@ and simple = parse ( reset_string_buffer (); description := ""; - special_comment lexbuf + special_comment lexbuf ) else ( @@ -401,7 +402,7 @@ and simple = parse Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); decr comments_level ; simple lexbuf - } + } | _ { diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml index 2acff68a13..dcfbfed2db 100644 --- a/ocamldoc/odoc_man.ml +++ b/ocamldoc/odoc_man.ml @@ -407,17 +407,19 @@ class man = ); bs b (Name.simple t.ty_name); bs b " \n"; + let priv = t.ty_private = Asttypes.Private in ( match t.ty_manifest with None -> () | Some typ -> - bs b "= "; - self#man_of_type_expr b father 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 "; @@ -445,7 +447,7 @@ class man = ) ) l - | Type_record (l, priv) -> + | Type_record l -> bs b "= "; if priv then bs b "private "; bs b "{"; @@ -474,6 +476,7 @@ class man = (** Print groff string for a class attribute. *) method man_of_attribute b a = bs b ".I val "; + if a.att_virtual then bs b ("virtual "); if a.att_mutable then bs b (Odoc_messages.mutab^" "); bs b ((Name.simple a.att_value.val_name)^" : "); self#man_of_type_expr b (Name.father a.att_value.val_name) a.att_value.val_type; diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml index 114a21e76f..2ff28a8b61 100644 --- a/ocamldoc/odoc_merge.ml +++ b/ocamldoc/odoc_merge.ml @@ -196,7 +196,7 @@ let merge_types merge_options mli ml = Type_abstract, _ -> () - | Type_variant (l1, _), Type_variant (l2, _) -> + | Type_variant l1, Type_variant l2 -> let f cons = try let cons2 = List.find @@ -224,7 +224,7 @@ let merge_types merge_options mli ml = in List.iter f l1 - | Type_record (l1, _), Type_record (l2, _) -> + | Type_record l1, Type_record l2 -> let f record = try let record2= List.find diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml index 98f6deff02..4cf1e67f71 100644 --- a/ocamldoc/odoc_messages.ml +++ b/ocamldoc/odoc_messages.ml @@ -162,6 +162,7 @@ let no_custom_tags = "\n\t\tDo not allow custom @-tags" let remove_stars = "\tRemove beginning blanks of comment lines, until the first '*'" let keep_code = "\tAlways keep code when available" let inverse_merge_ml_mli = "\n\t\tInverse implementations and interfaces when merging" +let no_filter_with_module_constraints = "\n\t\tDo not filter module elements using module type constraints" let merge_description = ('d', "merge description") let merge_author = ('a', "merge @author") let merge_version = ('v', "merge @version") diff --git a/ocamldoc/odoc_ocamlhtml.mll b/ocamldoc/odoc_ocamlhtml.mll index d935db9a48..fd8aa6091e 100644 --- a/ocamldoc/odoc_ocamlhtml.mll +++ b/ocamldoc/odoc_ocamlhtml.mll @@ -14,7 +14,7 @@ (* $Id$ *) (** Generation of html code to display OCaml code. *) -open Lexing +open Lexing exception Fatal_error @@ -31,17 +31,17 @@ type error = exception Error of error * int * int -let base_escape_strings = [ - ("&", "&") ; - ("<", "<") ; - (">", ">") ; -] +let base_escape_strings = [ + ("&", "&") ; + ("<", "<") ; + (">", ">") ; +] let pre_escape_strings = [ (" ", " ") ; ("\n", "<br>\n") ; ("\t", " ") ; - ] + ] let pre = ref false @@ -49,7 +49,7 @@ let fmt = ref Format.str_formatter (** Escape the strings which would clash with html syntax, and some other strings if we want to get a PRE style.*) -let escape s = +let escape s = List.fold_left (fun acc -> fun (s, s2) -> Str.global_replace (Str.regexp s) s2 acc) s @@ -64,7 +64,7 @@ let escape_base s = (** The output functions *) -let print ?(esc=true) s = +let print ?(esc=true) s = Format.pp_print_string !fmt (if esc then escape s else s) ;; @@ -81,7 +81,7 @@ let create_hashtable size init = tbl (** The function used to return html code for the given comment body. *) -let html_of_comment = ref +let html_of_comment = ref (fun (s : string) -> "<b>Odoc_ocamlhtml.html_of_comment not initialized</b>") let keyword_table = @@ -160,6 +160,7 @@ let margin = ref 0 let comment_buffer = Buffer.create 32 let reset_comment_buffer () = Buffer.reset comment_buffer let store_comment_char = Buffer.add_char comment_buffer +let add_comment_string = Buffer.add_string comment_buffer let make_margin () = let rec iter n = @@ -171,14 +172,14 @@ let make_margin () = let print_comment () = let s = Buffer.contents comment_buffer in let len = String.length s in - let code = + let code = if len < 1 then "<span class=\""^comment_class^"\">(*"^(escape s)^"*)</span>" else - match s.[0] with - '*' -> + match s.[0] with + '*' -> ( - try + try let html = !html_of_comment (String.sub s 1 (len-1)) in "</code><table><tr><td>"^(make_margin ())^"</td><td>"^ "<span class=\""^comment_class^"\">"^ @@ -199,7 +200,7 @@ let print_comment () = let string_buffer = Buffer.create 32 let reset_string_buffer () = Buffer.reset string_buffer let store_string_char = Buffer.add_char string_buffer -let get_stored_string () = +let get_stored_string () = let s = Buffer.contents string_buffer in String.escaped s @@ -215,7 +216,7 @@ let char_for_backslash = function let char_for_decimal_code lexbuf i = let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + - (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in Char.chr(c land 0xFF) (** To store the position of the beginning of a string and comment *) @@ -245,7 +246,7 @@ let report_error ppf = function let blank = [' ' '\010' '\013' '\009' '\012'] 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'] let symbolchar = ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] @@ -258,17 +259,17 @@ let float_literal = rule token = parse blank - { + { let s = Lexing.lexeme lexbuf in ( match s with - " " -> incr margin + " " -> incr margin | "\t" -> margin := !margin + 8 | "\n" -> margin := 0 | _ -> () ); print s; - token lexbuf + token lexbuf } | "_" { print "_" ; token lexbuf } @@ -320,9 +321,9 @@ rule token = parse { print_class string_class (Lexing.lexeme lexbuf ) ; token lexbuf } | "(*" - { + { reset_comment_buffer (); - comment_start_pos := [Lexing.lexeme_start lexbuf]; + comment_start_pos := [Lexing.lexeme_start lexbuf]; comment lexbuf ; print_comment (); token lexbuf } @@ -335,18 +336,18 @@ rule token = parse } | "*)" { lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; - 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 - 1 } ; print (Lexing.lexeme lexbuf) ; - token lexbuf + token lexbuf } | "#" [' ' '\t']* ['0'-'9']+ [^ '\n' '\r'] * ('\n' | '\r' | "\r\n") (* # linenum ... *) - { + { print (Lexing.lexeme lexbuf); - token lexbuf + token lexbuf } | "#" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } | "&" { print_class kwsign_class (Lexing.lexeme lexbuf) ; token lexbuf } @@ -419,7 +420,7 @@ and comment = parse { match !comment_start_pos with | [] -> assert false | [x] -> comment_start_pos := [] - | _ :: l -> + | _ :: l -> store_comment_char '*'; store_comment_char ')'; comment_start_pos := l; @@ -429,32 +430,33 @@ and comment = parse { reset_string_buffer(); string_start_pos := Lexing.lexeme_start lexbuf; store_comment_char '"'; - begin try string lexbuf - with Error (Unterminated_string, _, _) -> + begin + try string lexbuf; add_comment_string ((get_stored_string()^"\"")) + with Error (Unterminated_string, _, _) -> let st = List.hd !comment_start_pos in raise (Error (Unterminated_string_in_comment, st, st + 2)) end; comment lexbuf } | "''" - { + { store_comment_char '\''; store_comment_char '\''; comment lexbuf } | "'" [^ '\\' '\''] "'" - { + { store_comment_char '\''; store_comment_char (Lexing.lexeme_char lexbuf 1); store_comment_char '\''; comment lexbuf } | "'\\" ['\\' '\'' 'n' 't' 'b' 'r'] "'" - { + { store_comment_char '\''; store_comment_char '\\'; store_comment_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)) ; store_comment_char '\''; comment lexbuf } | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" - { + { store_comment_char '\''; store_comment_char '\\'; store_comment_char(char_for_decimal_code lexbuf 1); @@ -497,10 +499,10 @@ let html_of_code b ?(with_pre=true) code = fmt := Format.formatter_of_buffer buf ; pre := with_pre; margin := 0; - + let start = "<code class=\""^code_class^"\">" in let ending = "</code>" in - let html = + let html = ( try print ~esc: false start ; @@ -510,8 +512,8 @@ let html_of_code b ?(with_pre=true) code = Format.pp_print_flush !fmt () ; Buffer.contents buf with - _ -> - (* flush str_formatter because we already output + _ -> + (* flush str_formatter because we already output something in it *) Format.pp_print_flush !fmt () ; start^code^ending @@ -527,4 +529,4 @@ let html_of_code b ?(with_pre=true) code = Buffer.add_string b html -} +} diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index 0fbc946abd..7a6873b278 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -172,9 +172,9 @@ module Analyser = let name_comment_from_type_kind pos_end pos_limit tk = match tk with - Parsetree.Ptype_abstract | Parsetree.Ptype_private -> + Parsetree.Ptype_abstract -> (0, []) - | Parsetree.Ptype_variant (cons_core_type_list_list, _) -> + | Parsetree.Ptype_variant cons_core_type_list_list -> let rec f acc cons_core_type_list_list = match cons_core_type_list_list with [] -> @@ -197,7 +197,7 @@ module Analyser = in f [] cons_core_type_list_list - | Parsetree.Ptype_record (name_mutable_type_list, _) (* of (string * mutable_flag * core_type) list*) -> + | Parsetree.Ptype_record name_mutable_type_list (* of (string * mutable_flag * core_type) list*) -> let rec f = function [] -> [] @@ -220,7 +220,7 @@ module Analyser = Types.Type_abstract -> Odoc_type.Type_abstract - | Types.Type_variant (l, priv) -> + | Types.Type_variant l -> let f (constructor_name, type_expr_list) = let comment_opt = try @@ -235,9 +235,9 @@ module Analyser = vc_text = comment_opt } in - Odoc_type.Type_variant (List.map f l, priv = Asttypes.Private) + Odoc_type.Type_variant (List.map f l) - | Types.Type_record (l, _, priv) -> + | Types.Type_record (l, _) -> let f (field_name, mutable_flag, type_expr) = let comment_opt = try @@ -253,17 +253,12 @@ module Analyser = rf_text = comment_opt } in - Odoc_type.Type_record (List.map f l, priv = Asttypes.Private) + Odoc_type.Type_record (List.map f l) (** Analysis of the elements of a class, from the information in the parsetree and in the class signature. @return the couple (inherited_class list, elements).*) let analyse_class_elements env current_class_name last_pos pos_limit class_type_field_list class_signature = - print_DEBUG "Types.Tcty_signature class_signature"; - let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in - Types.Vars.iter f_DEBUG class_signature.Types.cty_vars; - print_DEBUG ("Type de la classe "^current_class_name^" : "); - print_DEBUG (Odoc_print.string_of_type_expr class_signature.Types.cty_self); let get_pos_limit2 q = match q with [] -> pos_limit @@ -330,7 +325,7 @@ module Analyser = in ([], ele_comments) - | Parsetree.Pctf_val (name, mutable_flag, _, loc) :: q -> + | Parsetree.Pctf_val (name, mutable_flag, virtual_flag, _, loc) :: q -> (* of (string * mutable_flag * core_type option * Location.t)*) let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in let complete_name = Name.concat current_class_name name in @@ -353,6 +348,7 @@ module Analyser = val_loc = { loc_impl = None ; loc_inter = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum)} ; } ; att_mutable = mutable_flag = Asttypes.Mutable ; + att_virtual = virtual_flag = Asttypes.Virtual ; } in let pos_limit2 = get_pos_limit2 q in @@ -603,13 +599,14 @@ module Analyser = ty_name = Name.concat current_module_name name ; ty_info = assoc_com ; ty_parameters = - List.map2 (fun p (co,cn,_) -> - (Odoc_env.subst_type new_env p, - co, cn) - ) - sig_type_decl.Types.type_params - sig_type_decl.Types.type_variance; - ty_kind = type_kind ; + List.map2 (fun p (co,cn,_) -> + (Odoc_env.subst_type new_env p, + co, cn) + ) + sig_type_decl.Types.type_params + sig_type_decl.Types.type_variance; + ty_kind = type_kind; + ty_private = sig_type_decl.Types.type_private; ty_manifest = (match sig_type_decl.Types.type_manifest with None -> None @@ -1178,11 +1175,6 @@ module Analyser = ([], k) | (Parsetree.Pcty_signature (_, class_type_field_list), Types.Tcty_signature class_signature) -> - print_DEBUG "Types.Tcty_signature class_signature"; - let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in - Types.Vars.iter f_DEBUG class_signature.Types.cty_vars; - print_DEBUG ("Type de la classe "^current_class_name^" : "); - print_DEBUG (Odoc_print.string_of_type_expr class_signature.Types.cty_self); (* we get the elements of the class in class_type_field_list *) let (inher_l, ele) = analyse_class_elements env current_class_name last_pos @@ -1232,11 +1224,6 @@ module Analyser = k | (Parsetree.Pcty_signature (_, class_type_field_list), Types.Tcty_signature class_signature) -> - print_DEBUG "Types.Tcty_signature class_signature"; - let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in - Types.Vars.iter f_DEBUG class_signature.Types.cty_vars; - print_DEBUG ("Type de la classe "^current_class_name^" : "); - print_DEBUG (Odoc_print.string_of_type_expr class_signature.Types.cty_self); (* we get the elements of the class in class_type_field_list *) let (inher_l, ele) = analyse_class_elements env current_class_name last_pos diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml index fc2e1ed6ed..d292065502 100644 --- a/ocamldoc/odoc_str.ml +++ b/ocamldoc/odoc_str.ml @@ -152,6 +152,10 @@ let string_of_class_params c = iter c.Odoc_class.cl_type; Buffer.contents b +let bool_of_private = function + | Asttypes.Private -> true + | _ -> false + let string_of_type t = let module M = Odoc_type in "type "^ @@ -164,15 +168,18 @@ let string_of_type t = t.M.ty_parameters ) )^ + let priv = bool_of_private (t.M.ty_private) in (Name.simple t.M.ty_name)^" "^ (match t.M.ty_manifest with None -> "" - | Some typ -> "= "^(Odoc_print.string_of_type_expr typ)^" " + | Some typ -> + "= " ^ (if priv then "private " else "" ) ^ + (Odoc_print.string_of_type_expr typ)^" " )^ (match t.M.ty_kind with M.Type_abstract -> "" - | M.Type_variant (l, priv) -> + | M.Type_variant l -> "="^(if priv then " private" else "")^"\n"^ (String.concat "" (List.map @@ -194,7 +201,7 @@ let string_of_type t = l ) ) - | M.Type_record (l, priv) -> + | M.Type_record l -> "= "^(if priv then "private " else "")^"{\n"^ (String.concat "" (List.map @@ -251,6 +258,7 @@ let string_of_value v = let string_of_attribute a = let module M = Odoc_value in "val "^ + (if a.M.att_virtual then "virtual " else "")^ (if a.M.att_mutable then Odoc_messages.mutab^" " else "")^ (Name.simple a.M.att_value.M.val_name)^" : "^ (Odoc_print.string_of_type_expr a.M.att_value.M.val_type)^"\n"^ diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml index b2670a85bf..df3eaacf4e 100644 --- a/ocamldoc/odoc_texi.ml +++ b/ocamldoc/odoc_texi.ml @@ -574,6 +574,7 @@ class texi = let t = [ self#fixedblock [ Newline ; minus ; Raw "val " ; + Raw (if a.att_virtual then "virtual " else "") ; Raw (if a.att_mutable then "mutable " else "") ; Raw (Name.simple a.att_value.val_name) ; Raw " :\n" ; @@ -628,15 +629,17 @@ class texi = [ Newline ; minus ; Raw "type " ; Raw (self#string_of_type_parameters ty) ; Raw (Name.simple ty.ty_name) ] @ + let priv = ty.ty_private = Asttypes.Private in ( match ty.ty_manifest with - | None -> [] - | Some typ -> - (Raw " = ") :: (self#text_of_short_type_expr - (Name.father ty.ty_name) typ) ) @ - ( - match ty.ty_kind with + | None -> [] + | Some 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 @@ -649,7 +652,7 @@ class texi = ((Raw (indent 5 "\n(* ")) :: (self#soft_fix_linebreaks 8 t)) @ [ Raw " *)" ; Newline ] ) ) l ) ) - | Type_record (l, priv) -> + | Type_record l -> (Raw (" = "^(if priv then "private " else "")^"{\n")) :: (List.flatten (List.map diff --git a/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml index 1e5717b6be..523d2fa564 100644 --- a/ocamldoc/odoc_to_text.ml +++ b/ocamldoc/odoc_to_text.ml @@ -13,10 +13,10 @@ (** Text generation. - This module contains the class [to_text] with methods used to transform + This module contains the class [to_text] with methods used to transform information about elements to a [text] structure.*) -open Odoc_info +open Odoc_info open Exception open Type open Value @@ -28,7 +28,7 @@ open Parameter class virtual info = object (self) (** The list of pairs [(tag, f)] where [f] is a function taking - the [text] associated to [tag] and returning a [text]. + the [text] associated to [tag] and returning a [text]. Add a pair here to handle a tag.*) val mutable tag_functions = ([] : (string * (Odoc_info.text -> Odoc_info.text)) list) @@ -40,8 +40,8 @@ class virtual info = | _ -> [ Bold [Raw (Odoc_messages.authors^": ")] ; Raw (String.concat ", " l) ; - Newline - ] + Newline + ] (** @return [text] value for the given optional version information.*) method text_of_version_opt v_opt = @@ -58,19 +58,19 @@ class virtual info = None -> [] | Some s -> [ Bold [Raw (Odoc_messages.since^": ")] ; Raw s ; - Newline + Newline ] (** @return [text] value for the given list of raised exceptions.*) method text_of_raised_exceptions l = match l with [] -> [] - | (s, t) :: [] -> + | (s, t) :: [] -> [ Bold [ Raw Odoc_messages.raises ] ; Raw " " ; Code s ; Raw " " - ] + ] @ t @ [ Newline ] | _ -> @@ -82,28 +82,28 @@ class virtual info = l ) ; Newline - ] + ] (** Return [text] value for the given "see also" reference. *) method text_of_see (see_ref, t) = - let t_ref = + let t_ref = match see_ref with Odoc_info.See_url s -> [ Odoc_info.Link (s, t) ] | Odoc_info.See_file s -> (Odoc_info.Code s) :: (Odoc_info.Raw " ") :: t | Odoc_info.See_doc s -> (Odoc_info.Italic [Odoc_info.Raw s]) :: (Odoc_info.Raw " ") :: t in t_ref - + (** Return [text] value for the given list of "see also" references.*) method text_of_sees l = match l with [] -> [] - | see :: [] -> - (Bold [ Raw Odoc_messages.see_also ]) :: - (Raw " ") :: + | see :: [] -> + (Bold [ Raw Odoc_messages.see_also ]) :: + (Raw " ") :: (self#text_of_see see) @ [ Newline ] | _ -> - (Bold [ Raw Odoc_messages.see_also ]) :: + (Bold [ Raw Odoc_messages.see_also ]) :: [ List (List.map (fun see -> self#text_of_see see) @@ -120,7 +120,7 @@ class virtual info = (** Return a [text] for the given list of custom tagged texts. *) method text_of_custom l = - List.fold_left + List.fold_left (fun acc -> fun (tag, text) -> try let f = List.assoc tag tag_functions in @@ -141,7 +141,7 @@ class virtual info = None -> [] | Some info -> - let t = + let t = (match info.i_deprecated with None -> [] | Some t -> ( Italic [Raw (Odoc_messages.deprecated^" ")] ) :: t @@ -160,8 +160,8 @@ class virtual info = (self#text_of_custom info.i_custom) in if block then - [Block t] - else + [Block t] + else t end @@ -172,11 +172,11 @@ class virtual to_text = method virtual label : ?no_: bool -> string -> string - (** Take a string and return the string where fully qualified idents + (** Take a string and return the string where fully qualified idents have been replaced by idents relative to the given module name. Also remove the "hidden modules".*) method relative_idents m_name s = - let f str_t = + let f str_t = let match_s = Str.matched_string str_t in let rel = Name.get_relative m_name match_s in Odoc_info.apply_if_equal Odoc_info.use_hidden_modules match_s rel @@ -188,11 +188,11 @@ class virtual to_text = in s2 - (** Take a string and return the string where fully qualified idents + (** Take a string and return the string where fully qualified idents have been replaced by idents relative to the given module name. Also remove the "hidden modules".*) method relative_module_idents m_name s = - let f str_t = + let f str_t = let match_s = Str.matched_string str_t in let rel = Name.get_relative m_name match_s in Odoc_info.apply_if_equal Odoc_info.use_hidden_modules match_s rel @@ -228,41 +228,41 @@ class virtual to_text = (** Get a string for the parameters of a class (with arrows) where all idents are relative. *) method normal_class_params m_name c = let s = Odoc_info.string_of_class_params c in - self#relative_idents m_name + self#relative_idents m_name (Odoc_info.remove_ending_newline s) (** @return [text] value to represent a [Types.type_expr].*) method text_of_type_expr module_name t = - let t = List.flatten + let t = List.flatten (List.map (fun s -> [Code s ; Newline ]) - (Str.split (Str.regexp "\n") + (Str.split (Str.regexp "\n") (self#normal_type module_name t)) ) in t (** Return [text] value for a given short [Types.type_expr].*) - method text_of_short_type_expr module_name t = + method text_of_short_type_expr module_name t = [ Code (self#normal_type module_name t) ] (** Return [text] value or the given list of [Types.type_expr], with the given separator. *) method text_of_type_expr_list module_name sep l = - [ Code (self#normal_type_list module_name sep l) ] + [ Code (self#normal_type_list module_name sep l) ] - (** Return [text] value or the given list of [Types.type_expr], + (** Return [text] value or the given list of [Types.type_expr], as type parameters of a class of class type. *) method text_of_class_type_param_expr_list module_name l = - [ Code (self#normal_class_type_param_list module_name l) ] + [ Code (self#normal_class_type_param_list module_name l) ] (** @return [text] value to represent parameters of a class (with arraows).*) method text_of_class_params module_name c = - let t = Odoc_info.text_concat + let t = Odoc_info.text_concat [Newline] (List.map (fun s -> [Code s]) - (Str.split (Str.regexp "\n") + (Str.split (Str.regexp "\n") (self#normal_class_params module_name c)) ) in @@ -274,18 +274,18 @@ class virtual to_text = (Str.split (Str.regexp "\n") (Odoc_info.string_of_module_type t)) in [ Code s ] - + (** @return [text] value for a value. *) method text_of_value v = let name = v.val_name in let s_name = Name.simple name in - let s = + let s = Format.fprintf Format.str_formatter "@[<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) @@ -293,14 +293,15 @@ class virtual to_text = method text_of_attribute a = let s_name = Name.simple a.att_value.val_name in let mod_name = Name.father a.att_value.val_name in - let s = - Format.fprintf Format.str_formatter "@[<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) @@ -308,11 +309,11 @@ class virtual to_text = method text_of_method m = let s_name = Name.simple m.met_value.val_name in let mod_name = Name.father m.met_value.val_name in - let s = + let s = Format.fprintf Format.str_formatter "@[<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 @@ -327,18 +328,18 @@ class virtual to_text = 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 @@ -377,7 +378,7 @@ class virtual to_text = ) l2 ) - ] + ] (** Return [text] value for a list of parameters. *) @@ -396,13 +397,13 @@ class virtual to_text = | s -> Code s ) :: [Code " : "] @ - (self#text_of_short_type_expr m_name (Parameter.typ p)) @ + (self#text_of_short_type_expr m_name (Parameter.typ p)) @ [Newline] @ (self#text_of_parameter_description p) ) l ) - ] + ] (** Return [text] value for a list of module parameters. *) method text_of_module_parameter_list l = @@ -410,7 +411,7 @@ class virtual to_text = [] -> [] | _ -> - [ Newline ; + [ Newline ; Bold [Raw Odoc_messages.parameters] ; Raw ":" ; List @@ -424,18 +425,18 @@ class virtual to_text = ) l ) - ] + ] (**/**) (** Return [text] value for the given [class_kind].*) method text_of_class_kind father ckind = match ckind with - Class_structure _ -> + Class_structure _ -> [Code Odoc_messages.object_end] | Class_apply capp -> - [Code + [Code ( ( match capp.capp_class with @@ -448,13 +449,13 @@ class virtual to_text = (fun s -> "("^s^")") capp.capp_params_code)) ) - ] - + ] + | Class_constr cco -> ( match cco.cco_type_parameters with [] -> [] - | l -> + | l -> (Code "["):: (self#text_of_type_expr_list father ", " l)@ [Code "] "] @@ -465,7 +466,7 @@ class virtual to_text = | Some (Cl cl) -> Name.get_relative father cl.cl_name | Some (Cltype (clt,_)) -> Name.get_relative father clt.clt_name ) - ] + ] | Class_constraint (ck, ctk) -> [Code "( "] @ @@ -478,11 +479,11 @@ class virtual to_text = (** Return [text] value for the given [class_type_kind].*) method text_of_class_type_kind father ctkind = match ctkind with - Class_type cta -> + Class_type cta -> ( match cta.cta_type_parameters with [] -> [] - | l -> + | l -> (Code "[") :: (self#text_of_class_type_param_expr_list father l) @ [Code "] "] @@ -490,16 +491,16 @@ class virtual to_text = ( match cta.cta_class with None -> [ Code cta.cta_name ] - | Some (Cltype (clt, _)) -> - let rel = Name.get_relative father clt.clt_name in + | Some (Cltype (clt, _)) -> + let rel = Name.get_relative father clt.clt_name in [Code rel] - | Some (Cl cl) -> + | Some (Cl cl) -> let rel = Name.get_relative father cl.cl_name in [Code rel] ) | Class_signature _ -> [Code Odoc_messages.object_end] - + (** Return [text] value for a [module_kind]. *) method text_of_module_kind ?(with_def_syntax=true) k = match k with @@ -518,12 +519,12 @@ class virtual to_text = [Code " ( "] @ (self#text_of_module_kind ~with_def_syntax: false k2) @ [Code " ) "] - + | Module_with (tk, code) -> (if with_def_syntax then [Code " : "] else []) @ (self#text_of_module_type_kind ~with_def_syntax: false tk) @ [Code code] - + | Module_constraint (k, tk) -> (if with_def_syntax then [Code " : "] else []) @ [Code "( "] @ @@ -531,7 +532,7 @@ class virtual to_text = [Code " : "] @ (self#text_of_module_type_kind ~with_def_syntax: false tk) @ [Code " )"] - + | Module_struct _ -> [Code ((if with_def_syntax then " : " else "")^ Odoc_messages.struct_end^" ")] @@ -550,14 +551,14 @@ class virtual to_text = | Module_type_functor (p, k) -> let t1 = - [Code ("("^p.mp_name^" : ")] @ + [Code ("("^p.mp_name^" : ")] @ (self#text_of_module_type_kind p.mp_kind) @ [Code ") -> "] in let t2 = self#text_of_module_type_kind ~with_def_syntax: false k in (if with_def_syntax then [Code " = "] else []) @ t1 @ t2 - - | Module_type_with (tk2, code) -> + + | Module_type_with (tk2, code) -> let t = self#text_of_module_type_kind ~with_def_syntax: false tk2 in (if with_def_syntax then [Code " = "] else []) @ t @ [Code code] @@ -567,7 +568,7 @@ class virtual to_text = (match mt_alias.mta_module with None -> mt_alias.mta_name | Some mt -> mt.mt_name)) - ] + ] end diff --git a/ocamldoc/odoc_type.ml b/ocamldoc/odoc_type.ml index bcf194d143..220a91a4e4 100644 --- a/ocamldoc/odoc_type.ml +++ b/ocamldoc/odoc_type.ml @@ -15,12 +15,15 @@ module Name = Odoc_name +type private_flag = Asttypes.private_flag = + Private | Public + (** Description of a variant type constructor. *) type variant_constructor = { vc_name : string ; vc_args : Types.type_expr list ; (** arguments of the constructor *) mutable vc_text : Odoc_types.text option ; (** optional user description *) - } + } (** Description of a record type field. *) type record_field = { @@ -28,25 +31,26 @@ type record_field = { rf_mutable : bool ; (** true if mutable *) rf_type : Types.type_expr ; mutable rf_text : Odoc_types.text option ; (** optional user description *) - } + } (** The various kinds of type. *) -type type_kind = +type type_kind = Type_abstract - | Type_variant of variant_constructor list * bool - (** constructors * bool *) - | Type_record of record_field list * bool - (** fields * bool *) + | Type_variant of variant_constructor list + (** constructors *) + | Type_record of record_field list + (** fields *) (** Representation of a type. *) type t_type = { ty_name : Name.t ; mutable ty_info : Odoc_types.info option ; (** optional user information *) - ty_parameters : (Types.type_expr * bool * bool) list ; + ty_parameters : (Types.type_expr * bool * bool) list ; (** type parameters: (type, covariant, contravariant) *) ty_kind : type_kind ; + ty_private : private_flag; ty_manifest : Types.type_expr option; (** type manifest *) mutable ty_loc : Odoc_types.location ; mutable ty_code : string option; - } + } diff --git a/ocamldoc/odoc_value.ml b/ocamldoc/odoc_value.ml index 5a5ee02751..e0bc3ce3f0 100644 --- a/ocamldoc/odoc_value.ml +++ b/ocamldoc/odoc_value.ml @@ -26,22 +26,23 @@ type t_value = { mutable val_parameters : Odoc_parameter.parameter list ; mutable val_code : string option ; mutable val_loc : Odoc_types.location ; - } + } (** Representation of a class attribute. *) type t_attribute = { att_value : t_value ; (** an attribute has almost all the same information as a value *) - att_mutable : bool ; - } + att_mutable : bool ; + att_virtual : bool ; + } (** Representation of a class method. *) type t_method = { met_value : t_value ; (** a method has almost all the same information as a value *) - met_private : bool ; + met_private : bool ; met_virtual : bool ; - } + } (** Functions *) @@ -60,27 +61,27 @@ let value_parameter_text_by_name v name = (** Update the parameters text of a t_value, according to the val_info field. *) let update_value_parameters_text v = - let f p = - Odoc_parameter.update_parameter_text (value_parameter_text_by_name v) p + let f p = + Odoc_parameter.update_parameter_text (value_parameter_text_by_name v) p in List.iter f v.val_parameters -(** Create a list of (parameter name, typ) from a type, according to the arrows. +(** Create a list of (parameter name, typ) from a type, according to the arrows. [parameter_list_from_arrows t = [ a ; b ]] if t = a -> b -> c.*) let parameter_list_from_arrows typ = - let rec iter t = + let rec iter t = match t.Types.desc with Types.Tarrow (l, t1, t2, _) -> (l, t1) :: (iter t2) - | Types.Tlink texp + | Types.Tlink texp | Types.Tsubst texp -> iter texp | Types.Tpoly (texp, _) -> iter texp | Types.Tvar - | Types.Ttuple _ - | Types.Tconstr _ + | Types.Ttuple _ + | Types.Tconstr _ | Types.Tobject _ - | Types.Tfield _ + | Types.Tfield _ | Types.Tnil | Types.Tunivar | Types.Tvariant _ -> @@ -89,16 +90,16 @@ let parameter_list_from_arrows typ = in iter typ -(** Create a list of parameters with dummy names "??" from a type list. +(** Create a list of parameters with dummy names "??" from a type list. Used when we want to merge the parameters of a value, from the .ml and the .mli file. In the .mli file we don't have parameter names so there is nothing to merge. With this dummy list we can merge the parameter names from the .ml and the type from the .mli file. *) let dummy_parameter_list typ = - let normal_name s = - match s with + let normal_name s = + match s with "" -> s - | _ -> + | _ -> match s.[0] with '?' -> String.sub s 1 ((String.length s) - 1) | _ -> s @@ -107,26 +108,26 @@ let dummy_parameter_list typ = let liste_param = parameter_list_from_arrows typ in let rec iter (label, t) = match t.Types.desc with - | Types.Ttuple l -> + | Types.Ttuple l -> if label = "" then - Odoc_parameter.Tuple + Odoc_parameter.Tuple (List.map (fun t2 -> iter ("", t2)) l, t) else (* if there is a label, then we don't want to decompose the tuple *) - Odoc_parameter.Simple_name + Odoc_parameter.Simple_name { Odoc_parameter.sn_name = normal_name label ; Odoc_parameter.sn_type = t ; Odoc_parameter.sn_text = None } - | Types.Tlink t2 + | Types.Tlink t2 | Types.Tsubst t2 -> (iter (label, t2)) | _ -> - Odoc_parameter.Simple_name + Odoc_parameter.Simple_name { Odoc_parameter.sn_name = normal_name label ; Odoc_parameter.sn_type = t ; Odoc_parameter.sn_text = None } - in + in List.map iter liste_param (** Return true if the value is a function, i.e. has a functional type.*) @@ -142,4 +143,4 @@ let is_function v = in f v.val_type - + diff --git a/otherlibs/dynlink/.depend b/otherlibs/dynlink/.depend deleted file mode 100644 index 1aa2131ff9..0000000000 --- a/otherlibs/dynlink/.depend +++ /dev/null @@ -1,8 +0,0 @@ -dynlink.cmo: ../../bytecomp/symtable.cmi ../../bytecomp/opcodes.cmo \ - ../../utils/misc.cmi ../../bytecomp/meta.cmi ../../bytecomp/dll.cmi \ - ../../utils/consistbl.cmi ../../utils/config.cmi dynlink.cmi -dynlink.cmx: ../../bytecomp/symtable.cmx ../../bytecomp/opcodes.cmx \ - ../../utils/misc.cmx ../../bytecomp/meta.cmx ../../bytecomp/dll.cmx \ - ../../utils/consistbl.cmx ../../utils/config.cmx dynlink.cmi -extract_crc.cmo: dynlink.cmi -extract_crc.cmx: dynlink.cmx diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index 6ea88a65b5..c13056d3c8 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -18,6 +18,7 @@ include ../../config/Makefile CAMLC=../../boot/ocamlrun ../../ocamlc +CAMLOPT=../../ocamlcompopt.sh INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp COMPFLAGS=-nojoin -warn-error A -I ../../stdlib $(INCLUDES) @@ -39,30 +40,46 @@ COMPILEROBJS=\ ../../bytecomp/dll.cmo ../../bytecomp/meta.cmo \ ../../bytecomp/symtable.cmo +NATOBJS=dynlink.cmx + all: dynlink.cma extract_crc -allopt: +allopt: dynlink.cmxa dynlink.cma: $(OBJS) - $(CAMLC) $(COMPFLAGS) -a -o dynlink.cma $(OBJS) + $(CAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cma $(OBJS) + +dynlink.cmxa: $(NATOBJS) + $(CAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cmxa $(NATOBJS) -dynlinkaux.cmo dynlinkaux.cmi: $(COMPILEROBJS) +dynlinkaux.cmo: $(COMPILEROBJS) $(CAMLC) $(COMPFLAGS) -pack -o dynlinkaux.cmo $(COMPILEROBJS) +dynlinkaux.cmi: dynlinkaux.cmo + +dynlink.cmx: dynlink.cmi natdynlink.ml + cp natdynlink.ml dynlink.mlopt + $(CAMLOPT) -c $(COMPFLAGS) -impl dynlink.mlopt + rm -f dynlink.mlopt + extract_crc: dynlink.cma extract_crc.cmo $(CAMLC) $(COMPFLAGS) -o extract_crc dynlink.cma extract_crc.cmo install: - cp dynlink.cmi dynlink.cma dynlink.mli extract_crc $(LIBDIR) + cp dynlink.cmi dynlink.cma dynlink.mli $(LIBDIR) + cp extract_crc $(LIBDIR)/extract_crc$(EXE) installopt: + cp $(NATOBJS) dynlink.cmxa dynlink.$(A) $(LIBDIR) + cd $(LIBDIR); $(RANLIB) dynlink.$(A) partialclean: - rm -f extract_crc *.cm[ioa] + rm -f extract_crc *.cm[ioax] *.cmxa clean: partialclean + rm -f *.$(A) *.$(O) *.so *.dll dynlink.mlopt -.SUFFIXES: .ml .mli .cmo .cmi +.SUFFIXES: .ml .mli .cmo .cmi .cmx .mli.cmi: $(CAMLC) -c $(COMPFLAGS) $< @@ -70,6 +87,9 @@ clean: partialclean .ml.cmo: $(CAMLC) -c $(COMPFLAGS) $< +.ml.cmx: + $(CAMLOPT) -c $(COMPFLAGS) $< + depend: dynlink.cmo: dynlinkaux.cmi dynlink.cmi diff --git a/otherlibs/dynlink/Makefile.nt b/otherlibs/dynlink/Makefile.nt index 3ce4fd0b50..3d8b84b77a 100644 --- a/otherlibs/dynlink/Makefile.nt +++ b/otherlibs/dynlink/Makefile.nt @@ -15,63 +15,4 @@ # Makefile for the dynamic link library -include ../../config/Makefile - -CAMLC=../../boot/ocamlrun ../../ocamlc -INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp -COMPFLAGS=-warn-error A -I ../../stdlib $(INCLUDES) - -OBJS=dynlinkaux.cmo dynlink.cmo - -COMPILEROBJS=\ - ../../utils/misc.cmo ../../utils/config.cmo ../../utils/clflags.cmo \ - ../../utils/tbl.cmo ../../utils/consistbl.cmo \ - ../../utils/terminfo.cmo ../../utils/warnings.cmo \ - ../../parsing/asttypes.cmi ../../parsing/linenum.cmo \ - ../../parsing/location.cmo ../../parsing/longident.cmo \ - ../../typing/ident.cmo ../../typing/path.cmo \ - ../../typing/primitive.cmo ../../typing/types.cmo \ - ../../typing/btype.cmo ../../typing/subst.cmo ../../typing/predef.cmo \ - ../../typing/datarepr.cmo ../../typing/env.cmo \ - ../../bytecomp/lambda.cmo ../../bytecomp/instruct.cmo \ - ../../bytecomp/cmo_format.cmi ../../bytecomp/opcodes.cmo \ - ../../bytecomp/runtimedef.cmo ../../bytecomp/bytesections.cmo \ - ../../bytecomp/dll.cmo ../../bytecomp/meta.cmo \ - ../../bytecomp/symtable.cmo - -all: dynlink.cma extract_crc - -allopt: - -dynlink.cma: $(OBJS) - $(CAMLC) $(COMPFLAGS) -a -o dynlink.cma $(OBJS) - -dynlinkaux.cmo dynlinkaux.cmi: $(COMPILEROBJS) - $(CAMLC) $(COMPFLAGS) -pack -o dynlinkaux.cmo $(COMPILEROBJS) - -extract_crc: dynlink.cma extract_crc.cmo - $(CAMLC) $(COMPFLAGS) -o extract_crc dynlink.cma extract_crc.cmo - -install: - cp dynlink.cmi dynlink.cma dynlink.mli $(LIBDIR) - cp extract_crc $(LIBDIR)/extract_crc.exe - -installopt: - -partialclean: - rm -f extract_crc *.cm[ioa] - -clean: partialclean - -.SUFFIXES: .ml .mli .cmo .cmi - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -depend: - -dynlink.cmo: dynlinkaux.cmi dynlink.cmi -extract_crc.cmo: dynlink.cmi +include Makefile diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml index 6fb154bd77..8d8d9a62d0 100644 --- a/otherlibs/dynlink/dynlink.ml +++ b/otherlibs/dynlink/dynlink.ml @@ -32,6 +32,7 @@ type error = | Corrupted_interface of string | File_not_found of string | Cannot_open_dll of string + | Inconsistent_implementation of string exception Error of error @@ -94,9 +95,20 @@ let default_available_units () = (* Initialize the linker tables and everything *) +let inited = ref false + let init () = - default_crcs := Symtable.init_toplevel(); - default_available_units () + if not !inited then begin + default_crcs := Symtable.init_toplevel(); + default_available_units (); + inited := true; + end + +let clear_available_units () = init(); clear_available_units () +let allow_only l = init(); allow_only l +let prohibit l = init(); prohibit l +let add_available_units l = init(); add_available_units l +let default_available_units () = init(); default_available_units () (* Read the CRC of an interface from its .cmi file *) @@ -184,6 +196,7 @@ let load_compunit ic file_name compunit = end let loadfile file_name = + init(); let ic = open_in_bin file_name in try let buffer = String.create (String.length Config.cmo_magic_number) in @@ -211,6 +224,7 @@ let loadfile file_name = close_in ic; raise exc let loadfile_private file_name = + init(); let initial_symtable = Symtable.current_state() and initial_crc = !crc_interfaces in try @@ -248,3 +262,8 @@ let error_message = function "cannot find file " ^ name ^ " in search path" | Cannot_open_dll reason -> "error loading shared library: " ^ reason + | Inconsistent_implementation name -> + "implementation mismatch on " ^ name + +let is_native = false +let adapt_filename f = f diff --git a/otherlibs/dynlink/dynlink.mli b/otherlibs/dynlink/dynlink.mli index ac5c1a2113..caee291710 100644 --- a/otherlibs/dynlink/dynlink.mli +++ b/otherlibs/dynlink/dynlink.mli @@ -13,19 +13,20 @@ (* $Id$ *) -(** Dynamic loading of bytecode object files. *) +(** Dynamic loading of object files. *) -(** {6 Initialization} *) +val is_native: bool +(** [true] if the program is native, + [false] if the program is bytecode. *) -val init : unit -> unit -(** Initialize the [Dynlink] library. - Must be called before any other function in this module. *) - -(** {6 Dynamic loading of compiled bytecode files} *) +(** {6 Dynamic loading of compiled files} *) val loadfile : string -> unit -(** Load the given bytecode object file ([.cmo] file) or - bytecode library file ([.cma] file), and link it with the running program. +(** In bytecode: load the given bytecode object file ([.cmo] file) or + bytecode library file ([.cma] file), and link it with the running + program. In native code: load the given OCaml plugin file (usually + [.cmxs]), and link it with the running + program. All toplevel expressions in the loaded compilation units are evaluated. No facilities are provided to access value names defined by the unit. Therefore, the unit @@ -37,6 +38,10 @@ val loadfile_private : string -> unit are hidden (cannot be referenced) from other modules dynamically loaded afterwards. *) +val adapt_filename : string -> string +(** In bytecode, the identity function. In native code, replace the last + extension with [.cmxs]. *) + (** {6 Access control} *) val allow_only: string list -> unit @@ -68,7 +73,8 @@ val allow_unsafe_modules : bool -> unit dynamically linked. A compilation unit is ``unsafe'' if it contains declarations of external functions, which can break type safety. By default, dynamic linking of unsafe object files is - not allowed. *) + not allowed. In native code, this function does nothing; object files + with external functions are always allowed to be dynamically linked. *) (** {6 Deprecated, low-level API for access control} *) @@ -77,7 +83,8 @@ val allow_unsafe_modules : bool -> unit since the default initialization of allowed units, along with the [allow_only] and [prohibit] function, provides a better, safer mechanism to control access to program units. The three functions - below are provided for backward compatibility only. *) + below are provided for backward compatibility only and are not + available in native code. *) val add_interfaces : string list -> string list -> unit (** [add_interfaces units path] grants dynamically-linked object @@ -97,6 +104,12 @@ val clear_available_units : unit -> unit (** Empty the list of compilation units accessible to dynamically-linked programs. *) +(** {6 Deprecated, initialization} *) + +val init : unit -> unit +(** @deprecated Initialize the [Dynlink] library. This function is called + automatically when needed. *) + (** {6 Error reporting} *) type linking_error = @@ -113,6 +126,7 @@ type error = | Corrupted_interface of string | File_not_found of string | Cannot_open_dll of string + | Inconsistent_implementation of string exception Error of error (** Errors in dynamic linking are reported by raising the [Error] diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend index f34f6c9c4d..d86fdd9fd2 100644 --- a/otherlibs/graph/.depend +++ b/otherlibs/graph/.depend @@ -58,6 +58,8 @@ text.o: text.c libgraph.h ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h +graphics.cmi: +graphicsX11.cmi: graphics.cmo: graphics.cmi graphics.cmx: graphics.cmi graphicsX11.cmo: graphics.cmi graphicsX11.cmi diff --git a/otherlibs/graph/Makefile b/otherlibs/graph/Makefile index 9fe8bb0a06..2be9844656 100644 --- a/otherlibs/graph/Makefile +++ b/otherlibs/graph/Makefile @@ -15,58 +15,17 @@ # Makefile for the portable graphics library -include ../../config/Makefile - -CC=$(BYTECC) -CFLAGS=-I../../byterun $(X11_INCLUDES) -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -CAMLC=../../ocamlcomp.sh $(NOJOIN) -CAMLOPT=../../ocamlcompopt.sh $(NOJOIN) -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A -g - -OBJS=open.o draw.o fill.o color.o text.o \ +LIBNAME=graphics +COBJS=open.o draw.o fill.o color.o text.o \ image.o make_img.o dump_img.o point_col.o sound.o events.o \ subwindow.o - CAMLOBJS=graphics.cmo graphicsX11.cmo +LINKOPTS=-cclib "\"$(X11_LINK)\"" +LDOPTS=-ldopt "$(X11_LINK)" -all: libgraphics.a graphics.cmi graphics.cma - -allopt: libgraphics.a graphics.cmi graphics.cmxa - -libgraphics.a: $(OBJS) - $(MKLIB) -o graphics $(OBJS) $(X11_LINK) - -graphics.cma: $(CAMLOBJS) - $(MKLIB) -ocamlc '$(CAMLC)' -o graphics $(CAMLOBJS) $(X11_LINK) - -graphics.cmxa: $(CAMLOBJS:.cmo=.cmx) - $(MKLIB) -ocamlopt '$(CAMLOPT)' -o graphics $(CAMLOBJS:.cmo=.cmx) $(X11_LINK) - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.a *.so *.o - -install: - if test -f dllgraphics.so; then cp dllgraphics.so $(STUBLIBDIR)/dllgraphics.so; fi - cp libgraphics.a $(LIBDIR)/libgraphics.a - cd $(LIBDIR); $(RANLIB) libgraphics.a - cp graphics.cm[ia] graphicsX11.cmi graphics.mli graphicsX11.mli $(LIBDIR) - -installopt: - cp graphics.cmx graphics.cmxa graphics.a $(LIBDIR) - cd $(LIBDIR); $(RANLIB) graphics.a - -.SUFFIXES: .ml .mli .cmo .cmi .cmx +EXTRACFLAGS=$(X11_INCLUDES) -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< +include ../Makefile depend: gcc -MM $(CFLAGS) *.c | sed -e 's, /usr[^ ]*\.h,,g' > .depend diff --git a/otherlibs/join/.depend b/otherlibs/join/.depend index b8f5b6e06d..87ff055b81 100644 --- a/otherlibs/join/.depend +++ b/otherlibs/join/.depend @@ -1,5 +1,7 @@ joinCount.cmi: join.cmi joinFifo.cmi: join.cmi +join.cmi: +joinProc.cmi: joinCount.cmo: join.cmi joinCount.cmi joinCount.cmx: join.cmx joinCount.cmi joinFifo.cmo: join.cmi joinFifo.cmi @@ -10,3 +12,5 @@ joinProc.cmo: joinProc.cmi joinProc.cmx: joinProc.cmi ns.cmo: site.cmo ns.cmx: site.cmx +site.cmo: +site.cmx: diff --git a/otherlibs/systhreads/.depend b/otherlibs/systhreads/.depend index b2683b10c9..404d032b6c 100644 --- a/otherlibs/systhreads/.depend +++ b/otherlibs/systhreads/.depend @@ -17,15 +17,25 @@ posix.o: posix.c ../../byterun/alloc.h ../../byterun/compatibility.h \ ../../byterun/memory.h ../../byterun/signals.h ../../byterun/stacks.h \ ../../byterun/sys.h condition.cmi: mutex.cmi +event.cmi: +join_debug.cmi: join_extern.cmi: thread.cmi +join_hash.cmi: +join_link.cmi: join_message.cmi: join_types.cmi join_link.cmi +join_misc.cmi: join_port.cmi: join_link.cmi join_prim.cmi: join_types.cmi +join_queue.cmi: join_scheduler.cmi: mutex.cmi join_types.cmi +join_set.cmi: join_space.cmi: join_types.cmi join_test.cmi: join_types.cmi join_types.cmi: mutex.cmi join_set.cmi join_misc.cmi join_link.cmi \ join_hash.cmi condition.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 @@ -72,5 +82,7 @@ mutex.cmo: mutex.cmi mutex.cmx: mutex.cmi thread.cmo: thread.cmi thread.cmx: thread.cmi +thread_posix.cmo: +thread_posix.cmx: threadUnix.cmo: thread.cmi threadUnix.cmi threadUnix.cmx: thread.cmx threadUnix.cmi diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile index 6c55611c47..239e9a348e 100644 --- a/otherlibs/systhreads/Makefile +++ b/otherlibs/systhreads/Makefile @@ -92,7 +92,13 @@ threads.cma: $(THREAD_OBJS) # See remark above: force static linking of libthreadsnat.a threads.cmxa: $(THREAD_OBJS:.cmo=.cmx) $(CAMLOPT) -a -o threads.cmxa $(THREAD_OBJS:.cmo=.cmx) \ - -cclib -lthreadsnat -cclib -lunix $(PTHREAD_LINK) + -cclib -lthreadsnat $(PTHREAD_LINK) + +# Note: I removed "-cclib -lunix" from the line above. +# Indeed, if we link threads.cmxa, then we must also link unix.cmxa, +# which itself will pass -lunix to the C linker. It seems more +# modular to me this way. -- Alain + $(THREAD_OBJS:.cmo=.cmx) $(JOIN_OBJS:.cmo=.cmx): ../../ocamlopt diff --git a/otherlibs/systhreads/Makefile.nt b/otherlibs/systhreads/Makefile.nt index be5ce4addb..a5380134be 100644 --- a/otherlibs/systhreads/Makefile.nt +++ b/otherlibs/systhreads/Makefile.nt @@ -19,46 +19,50 @@ include ../../config/Makefile CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -I ../win32unix CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -I ../win32unix COMPFLAGS=-warn-error A -g +MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib +CFLAGS=-I../../byterun $(EXTRACFLAGS) -THREAD_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo +CAMLOBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo +CMIFILES=$(CAMLOBJS:.cmo=.cmi) +COBJS=win32_b.$(O) +COBJS_NAT=win32_n.$(O) GENFILES=thread.ml -all: dllthreads.dll libthreads.$(A) threads.cma +LIBNAME=threads -allopt: libthreadsnat.$(A) threads.cmxa +all: lib$(LIBNAME).$(A) $(LIBNAME).cma $(CMIFILES) -dllthreads.dll: win32_b.$(DO) - $(call MKDLL,dllthreads.dll,tmp.$(A),win32_b.$(DO) ../../byterun/ocamlrun.$(A)) - rm tmp.* +allopt: lib$(LIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).cmxs $(CMIFILES) -libthreads.$(A): win32_b.$(SO) - $(call MKLIB,libthreads.$(A),win32_b.$(SO)) +$(LIBNAME).cma: $(CAMLOBJS) + $(MKLIB) -o $(LIBNAME) -ocamlc "..\\..\\boot\\ocamlrun ..\\..\\ocamlc" -linkall $(CAMLOBJS) $(LINKOPTS) -win32_b.$(DO): win32.c - $(BYTECC) -I../../byterun $(DLLCCCOMPOPTS) -c win32.c - mv win32.$(O) win32_b.$(DO) +lib$(LIBNAME).$(A): $(COBJS) + $(MKLIB) -o $(LIBNAME) $(COBJS) $(LDOPTS) -win32_b.$(SO): win32.c - $(BYTECC) -I../../byterun $(BYTECCCOMPOPTS) -c win32.c - mv win32.$(O) win32_b.$(SO) +win32_b.$(O): win32.c + $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c win32.c + mv win32.$(O) win32_b.$(O) -libthreadsnat.$(A): win32_n.$(O) - $(call MKLIB,libthreadsnat.$(A),win32_n.$(O)) + + +$(LIBNAME).cmxa: $(CAMLOBJS:.cmo=.cmx) + $(MKLIB) -o $(LIBNAME)nat -ocamlopt "..\\..\\boot\\ocamlrun ..\\..\\ocamlopt" -linkall $(CAMLOBJS:.cmo=.cmx) $(LINKOPTS) + mv $(LIBNAME)nat.cmxa $(LIBNAME).cmxa + mv $(LIBNAME)nat.$(A) $(LIBNAME).$(A) + +$(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(LIBNAME)nat.$(A) + $(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa -linkall + +lib$(LIBNAME)nat.$(A): $(COBJS_NAT) + $(MKLIB) -o $(LIBNAME)nat $(COBJS_NAT) $(LDOPTS) win32_n.$(O): win32.c $(NATIVECC) -DNATIVE_CODE -O -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) -c win32.c mv win32.$(O) win32_n.$(O) -threads.cma: $(THREAD_OBJS) - $(CAMLC) -a -o threads.cma $(THREAD_OBJS) \ - -dllib -lthreads -cclib -lthreads - -threads.cmxa: $(THREAD_OBJS:.cmo=.cmx) - $(CAMLOPT) -a -o threads.cmxa $(THREAD_OBJS:.cmo=.cmx) \ - -cclib -lthreadsnat - -$(THREAD_OBJS:.cmo=.cmx): ../../ocamlopt +$(CAMLOBJS:.cmo=.cmx): ../../ocamlopt thread.ml: thread_win32.ml cp thread_win32.ml thread.ml @@ -74,12 +78,13 @@ install: cp dllthreads.dll $(STUBLIBDIR)/dllthreads.dll cp libthreads.$(A) $(LIBDIR)/libthreads.$(A) mkdir -p $(LIBDIR)/threads - cp $(THREAD_OBJS:.cmo=.cmi) threads.cma $(LIBDIR)/threads + cp $(CMIFILES) threads.cma $(LIBDIR)/threads rm -f $(LIBDIR)/threads/stdlib.cma installopt: cp libthreadsnat.$(A) $(LIBDIR)/libthreadsnat.$(A) cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.$(A) $(LIBDIR)/threads + cp threads.cmxs $(LIBDIR)/threads .SUFFIXES: .ml .mli .cmo .cmi .cmx diff --git a/otherlibs/systhreads/posix.c b/otherlibs/systhreads/posix.c index 679fb09b4c..715741fc5b 100644 --- a/otherlibs/systhreads/posix.c +++ b/otherlibs/systhreads/posix.c @@ -27,7 +27,6 @@ #include <sys/time.h> #ifdef __linux__ #include <unistd.h> -#include <sys/utsname.h> #endif #include "alloc.h" #include "backtrace.h" @@ -122,15 +121,11 @@ static pthread_key_t last_channel_locked_key; /* Identifier for next thread creation */ static intnat thread_next_ident = 0; -/* Whether to use sched_yield() or not */ -static int broken_sched_yield = 0; - /* Forward declarations */ value caml_threadstatus_new (void); void caml_threadstatus_terminate (value); int caml_threadstatus_wait (value); static void caml_pthread_check (int, char *); -static void caml_thread_sysdeps_initialize(void); /* Imports for the native-code compiler */ extern struct longjmp_buffer caml_termination_jmpbuf; @@ -258,6 +253,12 @@ static void caml_io_mutex_lock(struct channel *chan) pthread_mutex_init(mutex, NULL); chan->mutex = (void *) mutex; } + /* PR#4351: first try to acquire mutex without releasing the master lock */ + if (pthread_mutex_trylock(chan->mutex) == 0) { + pthread_setspecific(last_channel_locked_key, (void *) chan); + return; + } + /* If unsuccessful, block on mutex */ enter_blocking_section(); pthread_mutex_lock(chan->mutex); /* Problem: if a signal occurs at this point, @@ -326,6 +327,44 @@ static void * caml_thread_tick(void * arg) return NULL; /* prevents compiler warning */ } +/* Reinitialize the thread machinery after a fork() (PR#4577) */ + +static void caml_thread_reinitialize(void) +{ + caml_thread_t thr, next; + pthread_t tick_pthread; + pthread_attr_t attr; + struct channel * chan; + + /* Remove all other threads (now nonexistent) + from the doubly-linked list of threads */ + thr = curr_thread->next; + while (thr != curr_thread) { + next = thr->next; + stat_free(thr); + thr = next; + } + curr_thread->next = curr_thread; + curr_thread->prev = curr_thread; + /* Reinitialize the master lock machinery, + just in case the fork happened while other threads were doing + leave_blocking_section */ + pthread_mutex_init(&caml_runtime_mutex, NULL); + pthread_cond_init(&caml_runtime_is_free, NULL); + caml_runtime_waiters = 0; /* no other thread is waiting for the RTS */ + caml_runtime_busy = 1; /* normally useless */ + /* Reinitialize all IO mutexes */ + for (chan = caml_all_opened_channels; + chan != NULL; + chan = chan->next) { + if (chan->mutex != NULL) pthread_mutex_init(chan->mutex, NULL); + } + /* Fork a new tick thread */ + pthread_attr_init(&attr); + pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); + pthread_create(&tick_pthread, &attr, caml_thread_tick, NULL); +} + /* Initialize the thread machinery */ value caml_thread_initialize(value unit) /* ML */ @@ -338,8 +377,6 @@ value caml_thread_initialize(value unit) /* ML */ /* Protect against repeated initialization (PR#1325) */ if (curr_thread != NULL) return Val_unit; Begin_root (mu); - /* OS-specific initialization */ - caml_thread_sysdeps_initialize(); /* Initialize the keys */ pthread_key_create(&thread_descriptor_key, NULL); pthread_key_create(&last_channel_locked_key, NULL); @@ -384,6 +421,9 @@ value caml_thread_initialize(value unit) /* ML */ caml_pthread_check( pthread_create(&tick_pthread, &attr, caml_thread_tick, NULL), "Thread.init"); + /* Set up fork() to reinitialize the thread machinery in the child + (PR#4577) */ + pthread_atfork(NULL, NULL, caml_thread_reinitialize); End_roots(); return Val_unit; } @@ -562,7 +602,10 @@ value caml_thread_yield(value unit) /* ML */ { if (caml_runtime_waiters == 0) return Val_unit; enter_blocking_section(); - if (! broken_sched_yield) sched_yield(); +#ifndef __linux__ + /* sched_yield() doesn't do what we want in Linux 2.6 and up (PR#2663) */ + sched_yield(); +#endif leave_blocking_section(); return Val_unit; } @@ -620,6 +663,10 @@ value caml_mutex_lock(value wrapper) /* ML */ { int retcode; pthread_mutex_t * mut = Mutex_val(wrapper); + /* PR#4351: first try to acquire mutex without releasing the master lock */ + retcode = pthread_mutex_trylock(mut); + if (retcode == 0) return Val_unit; + /* If unsuccessful, block on mutex */ Begin_root(wrapper) /* prevent the deallocation of mutex */ enter_blocking_section(); retcode = pthread_mutex_lock(mut); @@ -633,11 +680,8 @@ value caml_mutex_unlock(value wrapper) /* ML */ { int retcode; pthread_mutex_t * mut = Mutex_val(wrapper); - Begin_root(wrapper) /* prevent the deallocation of mutex */ - enter_blocking_section(); - retcode = pthread_mutex_unlock(mut); - leave_blocking_section(); - End_roots(); + /* PR#4351: no need to release and reacquire master lock */ + retcode = pthread_mutex_unlock(mut); caml_pthread_check(retcode, "Mutex.unlock"); return Val_unit; } @@ -703,11 +747,7 @@ value caml_condition_signal(value wrapper) /* ML */ { int retcode; pthread_cond_t * cond = Condition_val(wrapper); - Begin_root(wrapper) /* prevent deallocation of condition */ - enter_blocking_section(); - retcode = pthread_cond_signal(cond); - leave_blocking_section(); - End_roots(); + retcode = pthread_cond_signal(cond); caml_pthread_check(retcode, "Condition.signal"); return Val_unit; } @@ -716,11 +756,7 @@ value caml_condition_broadcast(value wrapper) /* ML */ { int retcode; pthread_cond_t * cond = Condition_val(wrapper); - Begin_root(wrapper) /* prevent deallocation of condition */ - enter_blocking_section(); - retcode = pthread_cond_broadcast(cond); - leave_blocking_section(); - End_roots(); + retcode = pthread_cond_broadcast(cond); caml_pthread_check(retcode, "Condition.broadcast"); return Val_unit; } @@ -805,7 +841,7 @@ static void decode_sigset(value vset, sigset_t * set) { sigemptyset(set); while (vset != Val_int(0)) { - int sig = convert_signal_number(Int_val(Field(vset, 0))); + int sig = caml_convert_signal_number(Int_val(Field(vset, 0))); sigaddset(set, sig); vset = Field(vset, 1); } @@ -822,9 +858,9 @@ static value encode_sigset(sigset_t * set) Begin_root(res) for (i = 1; i < NSIG; i++) - if (sigismember(set, i)) { + if (sigismember(set, i) > 0) { value newcons = alloc_small(2, 0); - Field(newcons, 0) = Val_int(i); + Field(newcons, 0) = Val_int(caml_rev_convert_signal_number(i)); Field(newcons, 1) = res; res = newcons; } @@ -888,20 +924,3 @@ static void caml_pthread_check(int retcode, char *msg) raise_sys_error(str); } -/* OS-specific initialization */ - -static void caml_thread_sysdeps_initialize(void) -{ -#ifdef __linux__ - /* sched_yield() doesn't do what we want in kernel 2.6 and up (PR#2663) */ - struct utsname un; - if (uname(&un) == -1) return; - broken_sched_yield = - un.release[1] != '.' || un.release[0] >= '3' /* version 3 and up */ - || (un.release[0] == '2' && - (un.release[3] != '.' || un.release[2] >= '6')); /* 2.6 and up */ - caml_gc_message(0x100, "POSIX threads. Avoid sched_yield: %d\n", - broken_sched_yield); -#endif -} - diff --git a/otherlibs/systhreads/thread.mli b/otherlibs/systhreads/thread.mli index af274bfc8b..8394a47bc6 100644 --- a/otherlibs/systhreads/thread.mli +++ b/otherlibs/systhreads/thread.mli @@ -33,10 +33,10 @@ val create : ('a -> 'b) -> 'a -> t result of the application [funct arg] is discarded and not directly accessible to the parent thread. *) -external self : unit -> t = "caml_thread_self" +val self : unit -> t (** Return the thread currently executing. *) -external id : t -> int = "caml_thread_id" +val id : t -> int (** Return the identifier of the given thread. A thread identifier is an integer that identifies uniquely the thread. It can be used to build data structures indexed by threads. *) @@ -54,7 +54,7 @@ val delay: float -> unit [d] seconds. The other program threads continue to run during this time. *) -external join : t -> unit = "caml_thread_join" +val join : t -> unit (** [join th] suspends the execution of the calling thread until the thread [th] has terminated. *) diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend index 036e59211c..8d262a6a1f 100644 --- a/otherlibs/threads/.depend +++ b/otherlibs/threads/.depend @@ -18,19 +18,28 @@ scheduler.o: scheduler.c ../../byterun/alloc.h \ ../../byterun/memory.h ../../byterun/signals.h ../../byterun/stacks.h \ ../../byterun/sys.h condition.cmi: mutex.cmi +event.cmi: +join_debug.cmi: join_extern.cmi: thread.cmi -join_link.cmi: unix.cmo +join_hash.cmi: +join_link.cmi: unix.cmi join_message.cmi: join_types.cmi join_link.cmi -join_misc.cmi: unix.cmo -join_port.cmi: unix.cmo join_link.cmi -join_prim.cmi: unix.cmo join_types.cmi +join_misc.cmi: unix.cmi marshal.cmi +join_port.cmi: unix.cmi join_link.cmi +join_prim.cmi: join_types.cmi +join_queue.cmi: join_scheduler.cmi: mutex.cmi join_types.cmi -join_space.cmi: unix.cmo marshal.cmo join_types.cmi -join_test.cmi: marshal.cmo join_types.cmi -join_types.cmi: unix.cmo mutex.cmi join_set.cmi join_misc.cmi join_link.cmi \ +join_set.cmi: +join_space.cmi: unix.cmi marshal.cmi join_types.cmi +join_test.cmi: marshal.cmi join_types.cmi +join_types.cmi: unix.cmi mutex.cmi join_set.cmi join_misc.cmi join_link.cmi \ join_hash.cmi condition.cmi -thread.cmi: unix.cmo -threadUnix.cmi: unix.cmo +marshal.cmi: +mutex.cmi: +pervasives.cmi: +thread.cmi: unix.cmi +threadUnix.cmi: unix.cmi +unix.cmi: condition.cmo: thread.cmi mutex.cmi condition.cmi condition.cmx: thread.cmx mutex.cmx condition.cmi event.cmo: mutex.cmi condition.cmi event.cmi @@ -41,15 +50,15 @@ join_extern.cmo: thread.cmi join_extern.cmi join_extern.cmx: thread.cmx join_extern.cmi join_hash.cmo: join_misc.cmi join_hash.cmi join_hash.cmx: join_misc.cmx join_hash.cmi -join_link.cmo: unix.cmo join_misc.cmi join_debug.cmi join_link.cmi +join_link.cmo: unix.cmi join_misc.cmi join_debug.cmi join_link.cmi join_link.cmx: unix.cmx join_misc.cmx join_debug.cmx join_link.cmi -join_message.cmo: marshal.cmo join_types.cmi join_link.cmi join_hash.cmi \ +join_message.cmo: marshal.cmi join_types.cmi join_link.cmi join_hash.cmi \ join_debug.cmi join_message.cmi join_message.cmx: marshal.cmx join_types.cmi join_link.cmx join_hash.cmx \ join_debug.cmx join_message.cmi -join_misc.cmo: unix.cmo mutex.cmi join_debug.cmi condition.cmi join_misc.cmi +join_misc.cmo: unix.cmi mutex.cmi join_debug.cmi condition.cmi join_misc.cmi join_misc.cmx: unix.cmx mutex.cmx join_debug.cmx condition.cmx join_misc.cmi -join_port.cmo: unix.cmo join_scheduler.cmi join_misc.cmi join_link.cmi \ +join_port.cmo: unix.cmi join_scheduler.cmi join_misc.cmi join_link.cmi \ join_debug.cmi join_port.cmi join_port.cmx: unix.cmx join_scheduler.cmx join_misc.cmx join_link.cmx \ join_debug.cmx join_port.cmi @@ -65,7 +74,7 @@ join_scheduler.cmx: thread.cmx mutex.cmx join_types.cmi join_misc.cmx \ join_extern.cmx join_debug.cmx condition.cmx join_scheduler.cmi join_set.cmo: mutex.cmi join_misc.cmi join_set.cmi join_set.cmx: mutex.cmx join_misc.cmx join_set.cmi -join_space.cmo: unix.cmo thread.cmi pervasives.cmo mutex.cmi marshal.cmo \ +join_space.cmo: unix.cmi thread.cmi pervasives.cmi mutex.cmi marshal.cmi \ join_types.cmi join_set.cmi join_scheduler.cmi join_port.cmi \ join_misc.cmi join_message.cmi join_link.cmi join_hash.cmi join_debug.cmi \ condition.cmi join_space.cmi @@ -75,13 +84,15 @@ join_space.cmx: unix.cmx thread.cmx pervasives.cmx mutex.cmx marshal.cmx \ condition.cmx join_space.cmi join_test.cmo: join_space.cmi join_test.cmi join_test.cmx: join_space.cmx join_test.cmi -marshal.cmo: pervasives.cmo -marshal.cmx: pervasives.cmx +marshal.cmo: pervasives.cmi marshal.cmi +marshal.cmx: pervasives.cmx marshal.cmi mutex.cmo: thread.cmi mutex.cmi mutex.cmx: thread.cmx mutex.cmi -pervasives.cmo: unix.cmo -pervasives.cmx: unix.cmx -thread.cmo: unix.cmo thread.cmi +pervasives.cmo: unix.cmi pervasives.cmi +pervasives.cmx: unix.cmx pervasives.cmi +thread.cmo: unix.cmi thread.cmi thread.cmx: unix.cmx thread.cmi -threadUnix.cmo: unix.cmo thread.cmi threadUnix.cmi +threadUnix.cmo: unix.cmi thread.cmi threadUnix.cmi threadUnix.cmx: unix.cmx thread.cmx threadUnix.cmi +unix.cmo: unix.cmi +unix.cmx: unix.cmi diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index c978bd3e40..af89857497 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -44,13 +44,14 @@ LIB_OBJS=pervasives.cmo \ $(LIB)/nativeint.cmo \ $(LIB)/lexing.cmo $(LIB)/parsing.cmo \ $(LIB)/set.cmo $(LIB)/map.cmo $(LIB)/stack.cmo $(LIB)/queue.cmo \ + $(LIB)/camlinternalLazy.cmo $(LIB)/lazy.cmo \ $(LIB)/stream.cmo $(LIB)/buffer.cmo \ $(LIB)/printf.cmo $(LIB)/format.cmo \ $(LIB)/scanf.cmo $(LIB)/arg.cmo \ $(LIB)/printexc.cmo $(LIB)/gc.cmo $(LIB)/digest.cmo $(LIB)/random.cmo \ $(LIB)/camlinternalOO.cmo $(LIB)/oo.cmo $(LIB)/camlinternalMod.cmo \ $(LIB)/genlex.cmo $(LIB)/callback.cmo $(LIB)/weak.cmo \ - $(LIB)/lazy.cmo $(LIB)/filename.cmo $(LIB)/complex.cmo \ + $(LIB)/filename.cmo $(LIB)/complex.cmo \ $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo $(LIB)/stringLabels.cmo \ $(LIB)/stdLabels.cmo $(LIB)/moreLabels.cmo @@ -98,7 +99,7 @@ unix.mli: $(UNIXLIB)/unix.mli unix.cmi: $(UNIXLIB)/unix.cmi ln -sf $(UNIXLIB)/unix.cmi unix.cmi -unix.cmo: unix.mli unix.cmi $(UNIXLIB)/unixLabels.cmo +unix.cmo: unix.mli unix.cmi $(UNIXLIB)/unixLabels.cmo $(CAMLC) ${COMPFLAGS} -c unix.ml partialclean: diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml index 6d6fa91bf7..6223e11195 100644 --- a/otherlibs/threads/unix.ml +++ b/otherlibs/threads/unix.ml @@ -541,29 +541,6 @@ type msg_flag = | MSG_DONTROUTE | MSG_PEEK -type socket_bool_option = - SO_DEBUG - | SO_BROADCAST - | SO_REUSEADDR - | SO_KEEPALIVE - | SO_DONTROUTE - | SO_OOBINLINE - | SO_ACCEPTCONN - -type socket_int_option = - SO_SNDBUF - | SO_RCVBUF - | SO_ERROR - | SO_TYPE - | SO_RCVLOWAT - | SO_SNDLOWAT - -type socket_optint_option = SO_LINGER - -type socket_float_option = - SO_RCVTIMEO - | SO_SNDTIMEO - external _socket : socket_domain -> socket_type -> int -> file_descr = "unix_socket" external _socketpair : @@ -595,23 +572,6 @@ external listen : file_descr -> int -> unit = "unix_listen" external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" external getsockname : file_descr -> sockaddr = "unix_getsockname" external getpeername : file_descr -> sockaddr = "unix_getpeername" -external getsockopt : file_descr -> socket_bool_option -> bool - = "unix_getsockopt_bool" -external setsockopt : file_descr -> socket_bool_option -> bool -> unit - = "unix_setsockopt_bool" -external getsockopt_int : file_descr -> socket_int_option -> int - = "unix_getsockopt_int" -external setsockopt_int : file_descr -> socket_int_option -> int -> unit - = "unix_setsockopt_int" -external getsockopt_optint : file_descr -> socket_optint_option -> int option - = "unix_getsockopt_optint" -external setsockopt_optint - : file_descr -> socket_optint_option -> int option -> unit - = "unix_setsockopt_optint" -external getsockopt_float : file_descr -> socket_float_option -> float - = "unix_getsockopt_float" -external setsockopt_float : file_descr -> socket_float_option -> float -> unit - = "unix_setsockopt_float" external _connect : file_descr -> sockaddr -> unit = "unix_connect" @@ -671,6 +631,70 @@ let rec sendto fd buf ofs len flags addr = wait_write fd; sendto fd buf ofs len flags addr +type socket_bool_option = + SO_DEBUG + | SO_BROADCAST + | SO_REUSEADDR + | SO_KEEPALIVE + | SO_DONTROUTE + | SO_OOBINLINE + | SO_ACCEPTCONN + | TCP_NODELAY + | IPV6_ONLY + + +type socket_int_option = + SO_SNDBUF + | SO_RCVBUF + | SO_ERROR + | SO_TYPE + | SO_RCVLOWAT + | SO_SNDLOWAT + +type socket_optint_option = SO_LINGER + +type socket_float_option = + SO_RCVTIMEO + | SO_SNDTIMEO + +type socket_error_option = SO_ERROR + +module SO: sig + type ('opt, 'v) t + val bool: (socket_bool_option, bool) t + val int: (socket_int_option, int) t + val optint: (socket_optint_option, int option) t + val float: (socket_float_option, float) t + val error: (socket_error_option, error option) t + val get: ('opt, 'v) t -> file_descr -> 'opt -> 'v + val set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit +end = struct + type ('opt, 'v) t = int + let bool = 0 + let int = 1 + let optint = 2 + let float = 3 + let error = 4 + external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v + = "unix_getsockopt" + external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit + = "unix_setsockopt" +end + +let getsockopt fd opt = SO.get SO.bool fd opt +let setsockopt fd opt v = SO.set SO.bool fd opt v + +let getsockopt_int fd opt = SO.get SO.int fd opt +let setsockopt_int fd opt v = SO.set SO.int fd opt v + +let getsockopt_optint fd opt = SO.get SO.optint fd opt +let setsockopt_optint fd opt v = SO.set SO.optint fd opt v + +let getsockopt_float fd opt = SO.get SO.float fd opt +let setsockopt_float fd opt v = SO.set SO.float fd opt v + +let getsockopt_error fd = SO.get SO.error fd SO_ERROR + type host_entry = { h_name : string; h_aliases : string array; diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend index 643350bb35..2cf122312e 100644 --- a/otherlibs/unix/.depend +++ b/otherlibs/unix/.depend @@ -1,772 +1,442 @@ accept.o: accept.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h socketaddr.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ + socketaddr.h ../../byterun/misc.h access.o: access.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h unixsupport.h addrofstr.o: addrofstr.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/fail.h ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h socketaddr.h + ../../byterun/misc.h ../../byterun/fail.h ../../byterun/mlvalues.h \ + unixsupport.h socketaddr.h ../../byterun/misc.h alarm.o: alarm.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h bind.o: bind.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/misc.h unixsupport.h socketaddr.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h socketaddr.h \ + ../../byterun/misc.h chdir.o: chdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h chmod.o: chmod.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h chown.o: chown.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h chroot.o: chroot.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h close.o: close.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h closedir.o: closedir.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h unixsupport.h + ../../byterun/misc.h unixsupport.h connect.o: connect.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/misc.h ../../byterun/signals.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h socketaddr.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h ../../byterun/signals.h unixsupport.h \ + socketaddr.h ../../byterun/misc.h cst2constr.o: cst2constr.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/fail.h ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h cst2constr.h + ../../byterun/misc.h ../../byterun/fail.h ../../byterun/mlvalues.h \ + cst2constr.h cstringv.o: cstringv.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h dup2.o: dup2.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h dup.o: dup.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h envir.o: envir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h errmsg.o: errmsg.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h execv.o: execv.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h execve.o: execve.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h execvp.o: execvp.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h exit.o: exit.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h fchmod.o: fchmod.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/misc.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h fchown.o: fchown.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/misc.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h fcntl.o: fcntl.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/misc.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h fork.o: fork.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h ftruncate.o: ftruncate.c ../../byterun/fail.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/misc.h ../../byterun/io.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h ../../byterun/io.h unixsupport.h getaddrinfo.o: getaddrinfo.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h cst2constr.h socketaddr.h + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ + cst2constr.h socketaddr.h ../../byterun/misc.h getcwd.o: getcwd.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h unixsupport.h getegid.o: getegid.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h unixsupport.h + ../../byterun/misc.h unixsupport.h geteuid.o: geteuid.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h unixsupport.h + ../../byterun/misc.h unixsupport.h getgid.o: getgid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h getgr.o: getgr.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/fail.h \ + ../../byterun/mlvalues.h ../../byterun/alloc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h unixsupport.h getgroups.o: getgroups.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h unixsupport.h gethost.o: gethost.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h socketaddr.h + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ + socketaddr.h ../../byterun/misc.h gethostname.o: gethostname.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h unixsupport.h getlogin.o: getlogin.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + unixsupport.h getnameinfo.o: getnameinfo.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h socketaddr.h + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ + socketaddr.h ../../byterun/misc.h getpeername.o: getpeername.c ../../byterun/fail.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/misc.h unixsupport.h socketaddr.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h socketaddr.h \ + ../../byterun/misc.h getpid.o: getpid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h getppid.o: getppid.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h unixsupport.h + ../../byterun/misc.h unixsupport.h getproto.o: getproto.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h unixsupport.h getpw.o: getpw.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h getserv.o: getserv.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h unixsupport.h getsockname.o: getsockname.c ../../byterun/fail.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/misc.h unixsupport.h socketaddr.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h socketaddr.h \ + ../../byterun/misc.h gettimeofday.o: gettimeofday.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h unixsupport.h getuid.o: getuid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h gmtime.o: gmtime.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h unixsupport.h isatty.o: isatty.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h itimer.o: itimer.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h unixsupport.h kill.o: kill.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h ../../byterun/signals.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/fail.h \ + ../../byterun/mlvalues.h unixsupport.h ../../byterun/signals.h link.o: link.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h listen.o: listen.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/misc.h unixsupport.h -lockf.o: lockf.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/misc.h ../../byterun/signals.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h unixsupport.h +lockf.o: lockf.c ../../byterun/fail.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h ../../byterun/signals.h unixsupport.h lseek.o: lseek.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/io.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/io.h unixsupport.h mkdir.o: mkdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h mkfifo.o: mkfifo.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/misc.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h nice.o: nice.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h open.o: open.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h opendir.o: opendir.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + unixsupport.h pipe.o: pipe.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h unixsupport.h putenv.o: putenv.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/mlvalues.h unixsupport.h read.o: read.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/signals.h unixsupport.h readdir.o: readdir.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/fail.h ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/fail.h ../../byterun/mlvalues.h \ + ../../byterun/alloc.h unixsupport.h readlink.o: readlink.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h unixsupport.h rename.o: rename.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h rewinddir.o: rewinddir.c ../../byterun/fail.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h rmdir.o: rmdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h select.o: select.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h sendrecv.o: sendrecv.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h socketaddr.h + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ + socketaddr.h ../../byterun/misc.h setgid.o: setgid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h setsid.o: setsid.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/misc.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h setuid.o: setuid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h shutdown.o: shutdown.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/misc.h unixsupport.h -signals.o: signals.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 ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/mlvalues.h unixsupport.h +signals.o: signals.c ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/mlvalues.h \ + ../../byterun/signals.h unixsupport.h sleep.o: sleep.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/misc.h \ + ../../byterun/signals.h ../../byterun/mlvalues.h unixsupport.h socketaddr.o: socketaddr.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h \ - socketaddr.h + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h \ + socketaddr.h ../../byterun/misc.h socket.o: socket.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h socketpair.o: socketpair.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h unixsupport.h sockopt.o: sockopt.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h socketaddr.h + ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/alloc.h \ + ../../byterun/fail.h unixsupport.h socketaddr.h ../../byterun/misc.h stat.o: stat.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h cst2constr.h ../../byterun/io.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/alloc.h \ + unixsupport.h cst2constr.h ../../byterun/io.h strofaddr.o: strofaddr.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h socketaddr.h + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h unixsupport.h socketaddr.h ../../byterun/misc.h symlink.o: symlink.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/misc.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h termios.o: termios.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h unixsupport.h time.o: time.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h unixsupport.h times.o: times.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h unixsupport.h truncate.o: truncate.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/fail.h ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/io.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/fail.h ../../byterun/mlvalues.h \ + ../../byterun/io.h unixsupport.h umask.o: umask.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h unixsupport.o: unixsupport.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/compatibility.h ../../byterun/config.h \ - ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/callback.h \ - ../../byterun/compatibility.h ../../byterun/mlvalues.h \ - ../../byterun/memory.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/gc.h ../../byterun/mlvalues.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/misc.h ../../byterun/minor_gc.h \ - ../../byterun/misc.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/fail.h ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h cst2constr.h + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ + ../../byterun/callback.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h \ + cst2constr.h unlink.o: unlink.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h utimes.o: utimes.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/misc.h unixsupport.h + ../../byterun/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/mlvalues.h unixsupport.h wait.o: wait.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/alloc.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h write.o: write.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ - ../../byterun/../config/s.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../byterun/memory.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ - ../../byterun/mlvalues.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ - ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ - ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/mlvalues.h unixsupport.h + ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/signals.h unixsupport.h unixLabels.cmi: unix.cmi +unix.cmi: unixLabels.cmo: unix.cmi unixLabels.cmi unixLabels.cmx: unix.cmx unixLabels.cmi unix.cmo: unix.cmi diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile index ab6a5601f7..878a3b316e 100644 --- a/otherlibs/unix/Makefile +++ b/otherlibs/unix/Makefile @@ -15,18 +15,11 @@ # 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 -nojoin -g +EXTRACAMLFLAGS=-nolabels -nojoin - -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 \ @@ -43,50 +36,11 @@ OBJS=accept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o \ time.o times.o truncate.o umask.o unixsupport.o unlink.o \ utimes.o wait.o write.o -MLOBJS=unix.cmo unixLabels.cmo - -all: libunix.a unix.cma - -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) $< +CAMLOBJS=unix.cmo unixLabels.cmo -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) -nolabels $< +HEADERS=unixsupport.h -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) -nolabels $< +include ../Makefile depend: gcc -MM $(CFLAGS) *.c > .depend diff --git a/otherlibs/unix/access.c b/otherlibs/unix/access.c index d7065c68ee..0c0c5fc1a3 100644 --- a/otherlibs/unix/access.c +++ b/otherlibs/unix/access.c @@ -31,7 +31,7 @@ # else # define R_OK 4/* test for read permission */ # define W_OK 2/* test for write permission */ -# define X_OK 1/* test for execute (search) permission */ +# define X_OK 4/* test for execute permission - not implemented in Win32 */ # define F_OK 0/* test for presence of file */ # endif #endif diff --git a/otherlibs/unix/nice.c b/otherlibs/unix/nice.c index 6018af0c2b..77def267c1 100644 --- a/otherlibs/unix/nice.c +++ b/otherlibs/unix/nice.c @@ -16,27 +16,9 @@ #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) { @@ -46,5 +28,3 @@ CAMLprim value unix_nice(value incr) if (ret == -1 && errno != 0) uerror("nice", Nothing); return Val_int(ret); } - -#endif diff --git a/otherlibs/unix/signals.c b/otherlibs/unix/signals.c index b244f8af64..c388b13936 100644 --- a/otherlibs/unix/signals.c +++ b/otherlibs/unix/signals.c @@ -24,7 +24,7 @@ #include "unixsupport.h" #ifndef NSIG -#define NSIG 32 +#define NSIG 64 #endif #ifdef POSIX_SIGNALS @@ -33,7 +33,7 @@ static void decode_sigset(value vset, sigset_t * set) { sigemptyset(set); while (vset != Val_int(0)) { - int sig = convert_signal_number(Int_val(Field(vset, 0))); + int sig = caml_convert_signal_number(Int_val(Field(vset, 0))); sigaddset(set, sig); vset = Field(vset, 1); } @@ -46,9 +46,9 @@ static value encode_sigset(sigset_t * set) Begin_root(res) for (i = 1; i < NSIG; i++) - if (sigismember(set, i)) { + if (sigismember(set, i) > 0) { value newcons = alloc_small(2, 0); - Field(newcons, 0) = Val_int(i); + Field(newcons, 0) = Val_int(caml_rev_convert_signal_number(i)); Field(newcons, 1) = res; res = newcons; } diff --git a/otherlibs/unix/sockopt.c b/otherlibs/unix/sockopt.c index ad6fe3367c..3e2645040a 100644 --- a/otherlibs/unix/sockopt.c +++ b/otherlibs/unix/sockopt.c @@ -14,15 +14,18 @@ /* $Id$ */ #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" @@ -74,164 +77,224 @@ #ifndef SO_SNDTIMEO #define SO_SNDTIMEO (-1) #endif +#ifndef TCP_NODELAY +#define TCP_NODELAY (-1) +#endif +#ifndef SO_ERROR +#define SO_ERROR (-1) +#endif +#ifndef IPPROTO_IPV6 +#define IPPROTO_IPV6 (-1) +#endif +#ifndef IPV6_V6ONLY +#define IPV6_V6ONLY (-1) +#endif -static int sockopt_bool[] = { - SO_DEBUG, SO_BROADCAST, SO_REUSEADDR, SO_KEEPALIVE, - SO_DONTROUTE, SO_OOBINLINE, SO_ACCEPTCONN }; - -static int sockopt_int[] = { - SO_SNDBUF, SO_RCVBUF, SO_ERROR, SO_TYPE, SO_RCVLOWAT, SO_SNDLOWAT }; - -static int sockopt_optint[] = { SO_LINGER }; - -static int sockopt_float[] = { SO_RCVTIMEO, SO_SNDTIMEO }; +enum option_type { + TYPE_BOOL = 0, + TYPE_INT = 1, + TYPE_LINGER = 2, + TYPE_TIMEVAL = 3, + TYPE_UNIX_ERROR = 4 +}; + +struct socket_option { + int level; + int option; +}; + +/* Table of options, indexed by type */ + +static struct socket_option sockopt_bool[] = { + { SOL_SOCKET, SO_DEBUG }, + { SOL_SOCKET, SO_BROADCAST }, + { SOL_SOCKET, SO_REUSEADDR }, + { SOL_SOCKET, SO_KEEPALIVE }, + { SOL_SOCKET, SO_DONTROUTE }, + { SOL_SOCKET, SO_OOBINLINE }, + { SOL_SOCKET, SO_ACCEPTCONN }, + { IPPROTO_TCP, TCP_NODELAY }, + { IPPROTO_IPV6, IPV6_V6ONLY} +}; + +static struct socket_option sockopt_int[] = { + { SOL_SOCKET, SO_SNDBUF }, + { SOL_SOCKET, SO_RCVBUF }, + { SOL_SOCKET, SO_ERROR }, + { SOL_SOCKET, SO_TYPE }, + { SOL_SOCKET, SO_RCVLOWAT }, + { SOL_SOCKET, SO_SNDLOWAT } }; + +static struct socket_option sockopt_linger[] = { + { SOL_SOCKET, SO_LINGER } +}; + +static struct socket_option sockopt_timeval[] = { + { SOL_SOCKET, SO_RCVTIMEO }, + { SOL_SOCKET, SO_SNDTIMEO } +}; + +static struct socket_option sockopt_unix_error[] = { + { SOL_SOCKET, SO_ERROR } +}; + +static struct socket_option * sockopt_table[] = { + sockopt_bool, + sockopt_int, + sockopt_linger, + sockopt_timeval, + sockopt_unix_error +}; + +static char * getsockopt_fun_name[] = { + "getsockopt", + "getsockopt_int", + "getsockopt_optint", + "getsockopt_float", + "getsockopt_error" +}; + +static char * setsockopt_fun_name[] = { + "setsockopt", + "setsockopt_int", + "setsockopt_optint", + "setsockopt_float", + "setsockopt_error" +}; + +union option_value { + int i; + struct linger lg; + struct timeval tv; +}; -CAMLexport value getsockopt_int(int *sockopt, value socket, - int level, value option) +CAMLexport value +unix_getsockopt_aux(char * name, + enum option_type ty, int level, int option, + value socket) { - int optval; + union option_value optval; socklen_param_type optsize; - optsize = sizeof(optval); - if (getsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, &optsize) == -1) - uerror("getsockopt", Nothing); - return Val_int(optval); -} - -CAMLexport value setsockopt_int(int *sockopt, value socket, int level, - value option, value status) -{ - int optval = Int_val(status); - if (setsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, sizeof(optval)) == -1) - uerror("setsockopt", Nothing); - return Val_unit; -} - -CAMLprim value unix_getsockopt_bool(value socket, value option) { - value res = getsockopt_int(sockopt_bool, socket, SOL_SOCKET, option); - return Val_bool(Int_val(res)); -} - -CAMLprim value unix_setsockopt_bool(value socket, value option, value status) -{ - return setsockopt_int(sockopt_bool, socket, SOL_SOCKET, option, status); -} - -CAMLprim value unix_getsockopt_int(value socket, value option) { - return getsockopt_int(sockopt_int, socket, SOL_SOCKET, option); -} - -CAMLprim value unix_setsockopt_int(value socket, value option, value status) -{ - return setsockopt_int(sockopt_int, socket, SOL_SOCKET, option, status); -} -CAMLexport value getsockopt_optint(int *sockopt, value socket, - int level, value option) -{ - struct linger optval; - socklen_param_type optsize; - value res = Val_int(0); /* None */ + switch (ty) { + case TYPE_BOOL: + case TYPE_INT: + case TYPE_UNIX_ERROR: + optsize = sizeof(optval.i); break; + case TYPE_LINGER: + optsize = sizeof(optval.lg); break; + case TYPE_TIMEVAL: + optsize = sizeof(optval.tv); break; + default: + unix_error(EINVAL, name, Nothing); + } - optsize = sizeof(optval); - if (getsockopt(Int_val(socket), level, sockopt[Int_val(option)], + if (getsockopt(Int_val(socket), level, option, (void *) &optval, &optsize) == -1) - uerror("getsockopt_optint", Nothing); - if (optval.l_onoff != 0) { - res = alloc_small(1, 0); - Field(res, 0) = Val_int(optval.l_linger); + uerror(name, Nothing); + + switch (ty) { + case TYPE_BOOL: + case TYPE_INT: + return Val_int(optval.i); + case TYPE_LINGER: + if (optval.lg.l_onoff == 0) { + return Val_int(0); /* None */ + } else { + value res = alloc_small(1, 0); /* Some */ + Field(res, 0) = Val_int(optval.lg.l_linger); + return res; + } + case TYPE_TIMEVAL: + return copy_double((double) optval.tv.tv_sec + + (double) optval.tv.tv_usec / 1e6); + case TYPE_UNIX_ERROR: + if (optval.i == 0) { + return Val_int(0); /* None */ + } else { + value err, res; + err = unix_error_of_code(optval.i); + Begin_root(err); + res = alloc_small(1, 0); /* Some */ + Field(res, 0) = err; + End_roots(); + return res; + } + default: + unix_error(EINVAL, name, Nothing); } - return res; } -CAMLexport value setsockopt_optint(int *sockopt, value socket, int level, - value option, value status) +CAMLexport value +unix_setsockopt_aux(char * name, + enum option_type ty, int level, int option, + value socket, value val) { - struct linger optval; - - optval.l_onoff = Is_block (status); - if (optval.l_onoff) - optval.l_linger = Int_val (Field (status, 0)); - if (setsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, sizeof(optval)) == -1) - uerror("setsockopt_optint", Nothing); - return Val_unit; -} - -CAMLprim value unix_getsockopt_optint(value socket, value option) -{ - return getsockopt_optint(sockopt_optint, socket, SOL_SOCKET, option); -} - -CAMLprim value unix_setsockopt_optint(value socket, value option, value status) -{ - return setsockopt_optint(sockopt_optint, socket, SOL_SOCKET, option, status); -} - -CAMLexport value getsockopt_float(int *sockopt, value socket, - int level, value option) -{ - struct timeval tv; + union option_value optval; socklen_param_type optsize; + double f; + + switch (ty) { + case TYPE_BOOL: + case TYPE_INT: + optsize = sizeof(optval.i); + optval.i = Int_val(val); + break; + case TYPE_LINGER: + optsize = sizeof(optval.lg); + optval.lg.l_onoff = Is_block (val); + if (optval.lg.l_onoff) + optval.lg.l_linger = Int_val (Field (val, 0)); + break; + case TYPE_TIMEVAL: + f = Double_val(val); + optsize = sizeof(optval.tv); + optval.tv.tv_sec = (int) f; + optval.tv.tv_usec = (int) (1e6 * (f - optval.tv.tv_sec)); + break; + case TYPE_UNIX_ERROR: + default: + unix_error(EINVAL, name, Nothing); + } - optsize = sizeof(tv); - if (getsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &tv, &optsize) == -1) - uerror("getsockopt_float", Nothing); - return copy_double((double) tv.tv_sec + (double) tv.tv_usec / 1e6); -} + if (setsockopt(Int_val(socket), level, option, + (void *) &optval, optsize) == -1) + uerror(name, Nothing); -CAMLexport value setsockopt_float(int *sockopt, value socket, int level, - value option, value status) -{ - struct timeval tv; - double tv_f; - - tv_f = Double_val(status); - tv.tv_sec = (int)tv_f; - tv.tv_usec = (int) (1e6 * (tv_f - tv.tv_sec)); - if (setsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &tv, sizeof(tv)) == -1) - uerror("setsockopt_float", Nothing); return Val_unit; } -CAMLprim value unix_getsockopt_float(value socket, value option) +CAMLprim value unix_getsockopt(value vty, value vsocket, value voption) { - return getsockopt_float(sockopt_float, socket, SOL_SOCKET, option); + enum option_type ty = Int_val(vty); + struct socket_option * opt = &(sockopt_table[ty][Int_val(voption)]); + return unix_getsockopt_aux(getsockopt_fun_name[ty], + ty, + opt->level, + opt->option, + vsocket); } -CAMLprim value unix_setsockopt_float(value socket, value option, value status) +CAMLprim value unix_setsockopt(value vty, value vsocket, value voption, + value val) { - return setsockopt_float(sockopt_float, socket, SOL_SOCKET, option, status); + enum option_type ty = Int_val(vty); + struct socket_option * opt = &(sockopt_table[ty][Int_val(voption)]); + return unix_setsockopt_aux(setsockopt_fun_name[ty], + ty, + opt->level, + opt->option, + vsocket, + val); } #else -CAMLprim value unix_getsockopt_bool(value socket, value option) +CAMLprim value unix_getsockopt(value vty, value socket, value option) { invalid_argument("getsockopt not implemented"); } -CAMLprim value unix_setsockopt_bool(value socket, value option, value status) +CAMLprim value unix_setsockopt(value vty, value socket, value option, value val) { invalid_argument("setsockopt not implemented"); } -CAMLprim value unix_getsockopt_int(value socket, value option) -{ invalid_argument("getsockopt_int not implemented"); } - -CAMLprim value unix_setsockopt_int(value socket, value option, value status) -{ invalid_argument("setsockopt_int not implemented"); } - -CAMLprim value unix_getsockopt_optint(value socket, value option) -{ invalid_argument("getsockopt_optint not implemented"); } - -CAMLprim value unix_setsockopt_optint(value socket, value option, value status) -{ invalid_argument("setsockopt_optint not implemented"); } - -CAMLprim value unix_getsockopt_float(value socket, value option) -{ invalid_argument("getsockopt_float not implemented"); } - -CAMLprim value unix_setsockopt_float(value socket, value option, value status) -{ invalid_argument("setsockopt_float not implemented"); } - #endif diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml index 8f5b3fc550..193071c4ac 100644 --- a/otherlibs/unix/unix.ml +++ b/otherlibs/unix/unix.ml @@ -433,29 +433,6 @@ type msg_flag = | MSG_DONTROUTE | MSG_PEEK -type socket_bool_option = - SO_DEBUG - | SO_BROADCAST - | SO_REUSEADDR - | SO_KEEPALIVE - | SO_DONTROUTE - | SO_OOBINLINE - | SO_ACCEPTCONN - -type socket_int_option = - SO_SNDBUF - | SO_RCVBUF - | SO_ERROR - | SO_TYPE - | SO_RCVLOWAT - | SO_SNDLOWAT - -type socket_optint_option = SO_LINGER - -type socket_float_option = - SO_RCVTIMEO - | SO_SNDTIMEO - external socket : socket_domain -> socket_type -> int -> file_descr = "unix_socket" external socketpair : @@ -499,22 +476,68 @@ let sendto fd buf ofs len flags addr = then invalid_arg "Unix.sendto" else unsafe_sendto fd buf ofs len flags addr -external getsockopt : file_descr -> socket_bool_option -> bool - = "unix_getsockopt_bool" -external setsockopt : file_descr -> socket_bool_option -> bool -> unit - = "unix_setsockopt_bool" -external getsockopt_int : file_descr -> socket_int_option -> int - = "unix_getsockopt_int" -external setsockopt_int : file_descr -> socket_int_option -> int -> unit - = "unix_setsockopt_int" -external getsockopt_optint : file_descr -> socket_optint_option -> int option - = "unix_getsockopt_optint" -external setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit - = "unix_setsockopt_optint" -external getsockopt_float : file_descr -> socket_float_option -> float - = "unix_getsockopt_float" -external setsockopt_float : file_descr -> socket_float_option -> float -> unit - = "unix_setsockopt_float" +type socket_bool_option = + SO_DEBUG + | SO_BROADCAST + | SO_REUSEADDR + | SO_KEEPALIVE + | SO_DONTROUTE + | SO_OOBINLINE + | SO_ACCEPTCONN + | TCP_NODELAY + | IPV6_ONLY + +type socket_int_option = + SO_SNDBUF + | SO_RCVBUF + | SO_ERROR + | SO_TYPE + | SO_RCVLOWAT + | SO_SNDLOWAT + +type socket_optint_option = SO_LINGER + +type socket_float_option = + SO_RCVTIMEO + | SO_SNDTIMEO + +type socket_error_option = SO_ERROR + +module SO: sig + type ('opt, 'v) t + val bool: (socket_bool_option, bool) t + val int: (socket_int_option, int) t + val optint: (socket_optint_option, int option) t + val float: (socket_float_option, float) t + val error: (socket_error_option, error option) t + val get: ('opt, 'v) t -> file_descr -> 'opt -> 'v + val set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit +end = struct + type ('opt, 'v) t = int + let bool = 0 + let int = 1 + let optint = 2 + let float = 3 + let error = 4 + external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v + = "unix_getsockopt" + external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit + = "unix_setsockopt" +end + +let getsockopt fd opt = SO.get SO.bool fd opt +let setsockopt fd opt v = SO.set SO.bool fd opt v + +let getsockopt_int fd opt = SO.get SO.int fd opt +let setsockopt_int fd opt v = SO.set SO.int fd opt v + +let getsockopt_optint fd opt = SO.get SO.optint fd opt +let setsockopt_optint fd opt v = SO.set SO.optint fd opt v + +let getsockopt_float fd opt = SO.get SO.float fd opt +let setsockopt_float fd opt v = SO.set SO.float fd opt v + +let getsockopt_error fd = SO.get SO.error fd SO_ERROR type host_entry = { h_name : string; diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index cf73b48350..5ac6913206 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -144,7 +144,9 @@ type process_status = | WSTOPPED of int (** The process was stopped by a signal; the argument is the signal number. *) -(** The termination status of a process. *) +(** The termination status of a process. See module {!Sys} for the + definitions of the standard signal numbers. Note that they are + not the numbers used by the OS. *) type wait_flag = @@ -758,7 +760,8 @@ val times : unit -> process_times val utimes : string -> float -> float -> unit (** Set the last access time (second arg) and last modification time (third arg) for a file. Times are expressed in seconds from - 00:00:00 GMT, Jan. 1, 1970. *) + 00:00:00 GMT, Jan. 1, 1970. A time of [0.0] is interpreted as the + current time. *) type interval_timer = ITIMER_REAL @@ -995,6 +998,8 @@ type socket_bool_option = | SO_DONTROUTE (** Bypass the standard routing algorithms *) | SO_OOBINLINE (** Leave out-of-band data in line *) | SO_ACCEPTCONN (** Report whether socket listening is enabled *) + | TCP_NODELAY (** Control the Nagle algorithm for TCP sockets *) + | IPV6_ONLY (** Forbid binding an IPv6 socket to an IPv4 address *) (** The socket options that can be consulted with {!Unix.getsockopt} and modified with {!Unix.setsockopt}. These options have a boolean ([true]/[false]) value. *) @@ -1002,7 +1007,7 @@ type socket_bool_option = type socket_int_option = SO_SNDBUF (** Size of send buffer *) | SO_RCVBUF (** Size of received buffer *) - | SO_ERROR (** Report the error status and clear it *) + | SO_ERROR (** Deprecated. Use {!Unix.getsockopt_error} instead. *) | SO_TYPE (** Report the socket type *) | SO_RCVLOWAT (** Minimum number of bytes to process for input operations *) | SO_SNDLOWAT (** Minimum number of bytes to process for output operations *) @@ -1033,31 +1038,29 @@ val getsockopt : file_descr -> socket_bool_option -> bool val setsockopt : file_descr -> socket_bool_option -> bool -> unit (** Set or clear a boolean-valued option in the given socket. *) -external getsockopt_int : - file_descr -> socket_int_option -> int = "unix_getsockopt_int" +val getsockopt_int : file_descr -> socket_int_option -> int (** Same as {!Unix.getsockopt} for an integer-valued socket option. *) -external setsockopt_int : - file_descr -> socket_int_option -> int -> unit = "unix_setsockopt_int" +val setsockopt_int : file_descr -> socket_int_option -> int -> unit (** Same as {!Unix.setsockopt} for an integer-valued socket option. *) -external getsockopt_optint : - file_descr -> socket_optint_option -> int option = "unix_getsockopt_optint" +val getsockopt_optint : file_descr -> socket_optint_option -> int option (** Same as {!Unix.getsockopt} for a socket option whose value is an [int option]. *) -external setsockopt_optint : - file_descr -> socket_optint_option -> int option -> - unit = "unix_setsockopt_optint" +val setsockopt_optint : + file_descr -> socket_optint_option -> int option -> unit (** Same as {!Unix.setsockopt} for a socket option whose value is an [int option]. *) -external getsockopt_float : - file_descr -> socket_float_option -> float = "unix_getsockopt_float" +val getsockopt_float : file_descr -> socket_float_option -> float (** Same as {!Unix.getsockopt} for a socket option whose value is a floating-point number. *) -external setsockopt_float : - file_descr -> socket_float_option -> float -> unit = "unix_setsockopt_float" +val setsockopt_float : file_descr -> socket_float_option -> float -> unit (** Same as {!Unix.setsockopt} for a socket option whose value is a floating-point number. *) +val getsockopt_error : file_descr -> error option +(** Return the error condition associated with the given socket, + and clear it. *) + (** {6 High-level network connection functions} *) diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli index 2298c9dab0..c2295e353e 100644 --- a/otherlibs/unix/unixLabels.mli +++ b/otherlibs/unix/unixLabels.mli @@ -153,7 +153,7 @@ type wait_flag = Unix.wait_flag = WNOHANG (** do not block if no child has died yet, but immediately return with a pid equal to 0.*) | WUNTRACED (** report also the children that receive stop signals. *) -(** Flags for {!Unix.waitpid}. *) +(** Flags for {!UnixLabels.waitpid}. *) val execv : prog:string -> args:string array -> 'a (** [execv prog args] execute the program in file [prog], with @@ -383,7 +383,7 @@ module LargeFile : (** File operations on large files. This sub-module provides 64-bit variants of the functions {!UnixLabels.lseek} (for positioning a file descriptor), - {!UnixLabels.truncate} and {!UnixLabels.ftruncate} + {!UnixLabels.truncate} and {!UnixLabels.ftruncate} (for changing the size of a file), and {!UnixLabels.stat}, {!UnixLabels.lstat} and {!UnixLabels.fstat} (for obtaining information on files). These alternate functions represent @@ -577,23 +577,23 @@ val open_process_full : and standard error of the command. *) val close_process_in : in_channel -> process_status -(** Close channels opened by {!UnixLabels.open_process_in}, +(** Close channels opened by {!UnixLabels.open_process_in}, wait for the associated command to terminate, and return its termination status. *) val close_process_out : out_channel -> process_status -(** Close channels opened by {!UnixLabels.open_process_out}, +(** Close channels opened by {!UnixLabels.open_process_out}, wait for the associated command to terminate, and return its termination status. *) val close_process : in_channel * out_channel -> process_status -(** Close channels opened by {!UnixLabels.open_process}, +(** Close channels opened by {!UnixLabels.open_process}, wait for the associated command to terminate, and return its termination status. *) val close_process_full : in_channel * out_channel * in_channel -> process_status -(** Close channels opened by {!UnixLabels.open_process_full}, +(** Close channels opened by {!UnixLabels.open_process_full}, wait for the associated command to terminate, and return its termination status. *) @@ -675,7 +675,7 @@ val kill : pid:int -> signal:int -> unit (** [kill pid sig] sends signal number [sig] to the process with id [pid]. *) -type sigprocmask_command = Unix.sigprocmask_command = +type sigprocmask_command = Unix.sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK @@ -913,7 +913,7 @@ type socket_type = Unix.socket_type = (** The type of socket kinds, specifying the semantics of communications. *) -type sockaddr = Unix.sockaddr = +type sockaddr = Unix.sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int (** The type of socket addresses. [ADDR_UNIX name] is a socket @@ -971,11 +971,11 @@ val getsockname : file_descr -> sockaddr val getpeername : file_descr -> sockaddr (** Return the address of the host connected to the given socket. *) -type msg_flag = Unix.msg_flag = +type msg_flag = Unix.msg_flag = MSG_OOB | MSG_DONTROUTE | MSG_PEEK -(** The flags for {!UnixLabels.recv}, {!UnixLabels.recvfrom}, +(** The flags for {!UnixLabels.recv}, {!UnixLabels.recvfrom}, {!UnixLabels.send} and {!UnixLabels.sendto}. *) val recv : @@ -1009,6 +1009,8 @@ type socket_bool_option = | SO_DONTROUTE (** Bypass the standard routing algorithms *) | SO_OOBINLINE (** Leave out-of-band data in line *) | SO_ACCEPTCONN (** Report whether socket listening is enabled *) + | TCP_NODELAY (** Control the Nagle algorithm for TCP sockets *) + | IPV6_ONLY (** Forbid binding an IPv6 socket to an IPv4 address *) (** The socket options that can be consulted with {!UnixLabels.getsockopt} and modified with {!UnixLabels.setsockopt}. These options have a boolean ([true]/[false]) value. *) @@ -1016,7 +1018,7 @@ type socket_bool_option = type socket_int_option = SO_SNDBUF (** Size of send buffer *) | SO_RCVBUF (** Size of received buffer *) - | SO_ERROR (** Report the error status and clear it *) + | SO_ERROR (** Deprecated. Use {!Unix.getsockopt_error} instead. *) | SO_TYPE (** Report the socket type *) | SO_RCVLOWAT (** Minimum number of bytes to process for input operations *) | SO_SNDLOWAT (** Minimum number of bytes to process for output operations *) @@ -1047,31 +1049,28 @@ val getsockopt : file_descr -> socket_bool_option -> bool val setsockopt : file_descr -> socket_bool_option -> bool -> unit (** Set or clear a boolean-valued option in the given socket. *) -external getsockopt_int : - file_descr -> socket_int_option -> int = "unix_getsockopt_int" -(** Same as {!UnixLabels.getsockopt} for an integer-valued socket option. *) +val getsockopt_int : file_descr -> socket_int_option -> int +(** Same as {!Unix.getsockopt} for an integer-valued socket option. *) -external setsockopt_int : - file_descr -> socket_int_option -> int -> unit = "unix_setsockopt_int" -(** Same as {!UnixLabels.setsockopt} for an integer-valued socket option. *) +val setsockopt_int : file_descr -> socket_int_option -> int -> unit +(** Same as {!Unix.setsockopt} for an integer-valued socket option. *) -external getsockopt_optint : - file_descr -> socket_optint_option -> int option = "unix_getsockopt_optint" -(** Same as {!UnixLabels.getsockopt} for a socket option whose value is an [int option]. *) +val getsockopt_optint : file_descr -> socket_optint_option -> int option +(** Same as {!Unix.getsockopt} for a socket option whose value is an [int option]. *) -external setsockopt_optint : - file_descr -> socket_optint_option -> int option -> - unit = "unix_setsockopt_optint" -(** Same as {!UnixLabels.setsockopt} for a socket option whose value is an [int option]. *) +val setsockopt_optint : + file_descr -> socket_optint_option -> int option -> unit +(** Same as {!Unix.setsockopt} for a socket option whose value is an [int option]. *) -external getsockopt_float : - file_descr -> socket_float_option -> float = "unix_getsockopt_float" -(** Same as {!UnixLabels.getsockopt} for a socket option whose value is a floating-point number. *) +val getsockopt_float : file_descr -> socket_float_option -> float +(** Same as {!Unix.getsockopt} for a socket option whose value is a floating-point number. *) -external setsockopt_float : - file_descr -> socket_float_option -> float -> unit = "unix_setsockopt_float" -(** Same as {!UnixLabels.setsockopt} for a socket option whose value is a floating-point number. *) +val setsockopt_float : file_descr -> socket_float_option -> float -> unit +(** Same as {!Unix.setsockopt} for a socket option whose value is a floating-point number. *) +val getsockopt_error : file_descr -> error option +(** Return the error condition associated with the given socket, + and clear it. *) (** {6 High-level network connection functions} *) @@ -1271,7 +1270,7 @@ val tcgetattr : file_descr -> terminal_io (** Return the status of the terminal referred to by the given file descriptor. *) -type setattr_when = Unix.setattr_when = +type setattr_when = Unix.setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH @@ -1295,7 +1294,7 @@ val tcdrain : file_descr -> unit (** Waits until all output written on the given file descriptor has been transmitted. *) -type flush_queue = Unix.flush_queue = +type flush_queue = Unix.flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH @@ -1307,7 +1306,7 @@ val tcflush : file_descr -> mode:flush_queue -> unit [TCOFLUSH] flushes data written but not transmitted, and [TCIOFLUSH] flushes both. *) -type flow_action = Unix.flow_action = +type flow_action = Unix.flow_action = TCOOFF | TCOON | TCIOFF diff --git a/parsing/location.ml b/parsing/location.ml index b1ec04e006..15b074acd4 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -61,7 +61,7 @@ let rhs_loc n = { loc_ghost = false; };; -let input_name = ref "" +let input_name = ref "_none_" let input_lexbuf = ref (None : lexbuf option) (* Terminal info *) @@ -70,9 +70,10 @@ let status = ref Terminfo.Uninitialised let num_loc_lines = ref 0 (* number of lines already printed after input *) -(* Highlight the location using standout mode. *) +(* Highlight the locations using standout mode. *) let highlight_terminfo ppf num_lines lb loc1 loc2 = + Format.pp_print_flush ppf (); (* avoid mixing Format and normal output *) (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *) let pos0 = -lb.lex_abs_pos in (* Do nothing if the buffer does not contain the whole phrase. *) @@ -125,7 +126,7 @@ let highlight_dumb ppf lb loc = Format.fprintf ppf "Characters %i-%i:@." loc.loc_start.pos_cnum loc.loc_end.pos_cnum; (* Print the input, underlining the location *) - print_string " "; + Format.pp_print_string ppf " "; let line = ref 0 in let pos_at_bol = ref 0 in for pos = 0 to end_pos do @@ -133,34 +134,34 @@ let highlight_dumb ppf lb loc = if c <> '\n' then begin if !line = !line_start && !line = !line_end then (* loc is on one line: print whole line *) - print_char c + Format.pp_print_char ppf c else if !line = !line_start then (* first line of multiline loc: print ... before loc_start *) if pos < loc.loc_start.pos_cnum - then print_char '.' - else print_char c + then Format.pp_print_char ppf '.' + else Format.pp_print_char ppf c else if !line = !line_end then (* last line of multiline loc: print ... after loc_end *) if pos < loc.loc_end.pos_cnum - then print_char c - else print_char '.' + then Format.pp_print_char ppf c + else Format.pp_print_char ppf '.' else if !line > !line_start && !line < !line_end then (* intermediate line of multiline loc: print whole line *) - print_char c + Format.pp_print_char ppf c end else begin if !line = !line_start && !line = !line_end then begin (* loc is on one line: underline location *) - print_string "\n "; + Format.fprintf ppf "@. "; for i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do - print_char ' ' + Format.pp_print_char ppf ' ' done; for i = loc.loc_start.pos_cnum to loc.loc_end.pos_cnum - 1 do - print_char '^' + Format.pp_print_char ppf '^' done end; if !line >= !line_start && !line <= !line_end then begin - print_char '\n'; - if pos < loc.loc_end.pos_cnum then print_string " " + Format.fprintf ppf "@."; + if pos < loc.loc_end.pos_cnum then Format.pp_print_string ppf " " end; incr line; pos_at_bol := pos + 1; @@ -229,6 +230,14 @@ let print ppf loc = fprintf ppf "%s%i" msg_chars startchar; fprintf ppf "%s%i%s@.%s" msg_to endchar msg_colon msg_head; end +;; + +let print_error ppf loc = + print ppf loc; + fprintf ppf "Error: "; +;; + +let print_error_cur_file ppf = print_error ppf (in_file !input_name);; let print_warning loc ppf w = if Warnings.is_active w then begin diff --git a/parsing/location.mli b/parsing/location.mli index 4cc92f6ede..a496a35506 100644 --- a/parsing/location.mli +++ b/parsing/location.mli @@ -47,7 +47,8 @@ val input_name: string ref val input_lexbuf: Lexing.lexbuf option ref val get_pos_info : Lexing.position -> string * int * int (* file, line, char *) -val print: formatter -> t -> unit +val print_error: formatter -> t -> unit +val print_error_cur_file: formatter -> unit val print_warning: t -> formatter -> Warnings.t -> unit val prerr_warning: t -> Warnings.t -> unit val echo_eof: unit -> unit diff --git a/parsing/parser.mly b/parsing/parser.mly index f53a43ac96..8f0d69a0d9 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -153,30 +153,32 @@ let bigarray_untuplify = function | exp -> [exp] let bigarray_get arr arg = + let get = if !Clflags.fast then "unsafe_get" else "get" in match bigarray_untuplify arg with [c1] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" "get")), + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" get)), ["", arr; "", c1])) | [c1;c2] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" "get")), + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" get)), ["", arr; "", c1; "", c2])) | [c1;c2;c3] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" "get")), + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" get)), ["", arr; "", c1; "", c2; "", c3])) | coords -> mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "get")), ["", arr; "", ghexp(Pexp_array coords)])) let bigarray_set arr arg newval = + let set = if !Clflags.fast then "unsafe_set" else "set" in match bigarray_untuplify arg with [c1] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" "set")), + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" set)), ["", arr; "", c1; "", newval])) | [c1;c2] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" "set")), + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" set)), ["", arr; "", c1; "", c2; "", newval])) | [c1;c2;c3] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" "set")), + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" set)), ["", arr; "", c1; "", c2; "", c3; "", newval])) | coords -> mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")), @@ -450,8 +452,8 @@ structure_item: { match $3 with [{ppat_desc = Ppat_any}, exp] -> mkstr(Pstr_eval exp) | _ -> mkstr(Pstr_value($2, List.rev $3)) } - | EXTERNAL val_ident_colon core_type EQUAL primitive_declaration - { mkstr(Pstr_primitive($2, {pval_type = $3; pval_prim = $5})) } + | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration + { mkstr(Pstr_primitive($2, {pval_type = $4; pval_prim = $6})) } | TYPE type_declarations { mkstr(Pstr_type(List.rev $2)) } | EXCEPTION UIDENT constructor_arguments @@ -520,10 +522,10 @@ signature: | signature signature_item SEMISEMI { $2 :: $1 } ; signature_item: - VAL val_ident_colon core_type - { mksig(Psig_value($2, {pval_type = $3; pval_prim = []})) } - | EXTERNAL val_ident_colon core_type EQUAL primitive_declaration - { mksig(Psig_value($2, {pval_type = $3; pval_prim = $5})) } + VAL val_ident COLON core_type + { mksig(Psig_value($2, {pval_type = $4; pval_prim = []})) } + | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration + { mksig(Psig_value($2, {pval_type = $4; pval_prim = $6})) } | TYPE type_declarations { mksig(Psig_type(List.rev $2)) } | EXCEPTION UIDENT constructor_arguments @@ -679,8 +681,6 @@ concrete_method : { $3, $2, ghexp(Pexp_poly ($4, None)), symbol_rloc () } | METHOD private_flag label COLON poly_type EQUAL seq_expr { $3, $2, ghexp(Pexp_poly($7,Some $5)), symbol_rloc () } - | METHOD private_flag LABEL poly_type EQUAL seq_expr - { $3, $2, ghexp(Pexp_poly($6,Some $4)), symbol_rloc () } ; /* Class types */ @@ -690,12 +690,12 @@ class_type: { $1 } | QUESTION LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type { mkcty(Pcty_fun("?" ^ $2 , - {ptyp_desc = Ptyp_constr(Lident "option", [$4]); + {ptyp_desc = Ptyp_constr(Ldot (Lident "*predef*", "option"), [$4]); ptyp_loc = $4.ptyp_loc}, $6)) } | OPTLABEL simple_core_type_or_tuple MINUSGREATER class_type { mkcty(Pcty_fun("?" ^ $1 , - {ptyp_desc = Ptyp_constr(Lident "option", [$2]); + {ptyp_desc = Ptyp_constr(Ldot (Lident "*predef*", "option"), [$2]); ptyp_loc = $2.ptyp_loc}, $4)) } | LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type @@ -1099,6 +1099,8 @@ pattern: false)) } | pattern BAR pattern { mkpat(Ppat_or($1, $3)) } + | LAZY simple_pattern + { mkpat(Ppat_lazy $2) } ; simple_pattern: val_ident %prec below_EQUAL @@ -1169,10 +1171,11 @@ type_declarations: type_declaration: type_parameters LIDENT type_kind constraints { let (params, variance) = List.split $1 in - let (kind, manifest) = $3 in + let (kind, private_flag, manifest) = $3 in ($2, {ptype_params = params; ptype_cstrs = List.rev $4; ptype_kind = kind; + ptype_private = private_flag; ptype_manifest = manifest; ptype_variance = variance; ptype_loc = symbol_rloc()}) } @@ -1183,23 +1186,23 @@ constraints: ; type_kind: /*empty*/ - { (Ptype_abstract, None) } + { (Ptype_abstract, Public, None) } | EQUAL core_type - { (Ptype_abstract, Some $2) } + { (Ptype_abstract, Public, Some $2) } | EQUAL constructor_declarations - { (Ptype_variant(List.rev $2, Public), None) } + { (Ptype_variant(List.rev $2), Public, None) } | EQUAL PRIVATE constructor_declarations - { (Ptype_variant(List.rev $3, Private), None) } + { (Ptype_variant(List.rev $3), Private, None) } | EQUAL private_flag BAR constructor_declarations - { (Ptype_variant(List.rev $4, $2), None) } + { (Ptype_variant(List.rev $4), $2, None) } | EQUAL private_flag LBRACE label_declarations opt_semi RBRACE - { (Ptype_record(List.rev $4, $2), None) } + { (Ptype_record(List.rev $4), $2, None) } | EQUAL core_type EQUAL private_flag opt_bar constructor_declarations - { (Ptype_variant(List.rev $6, $4), Some $2) } + { (Ptype_variant(List.rev $6), $4, Some $2) } | EQUAL core_type EQUAL private_flag LBRACE label_declarations opt_semi RBRACE - { (Ptype_record(List.rev $6, $4), Some $2) } + { (Ptype_record(List.rev $6), $4, Some $2) } | EQUAL PRIVATE core_type - { (Ptype_private, Some $3) } + { (Ptype_abstract, Private, Some $3) } ; type_parameters: /*empty*/ { [] } @@ -1248,8 +1251,9 @@ with_constraint: { let params, variance = List.split $2 in ($3, Pwith_type {ptype_params = params; ptype_cstrs = List.rev $6; - ptype_kind = $4; + ptype_kind = Ptype_abstract; ptype_manifest = Some $5; + ptype_private = $4; ptype_variance = variance; ptype_loc = symbol_rloc()}) } /* used label_longident instead of type_longident to disallow @@ -1258,8 +1262,8 @@ with_constraint: { ($2, Pwith_module $4) } ; with_type_binder: - EQUAL { Ptype_abstract } - | EQUAL PRIVATE { Ptype_private } + EQUAL { Public } + | EQUAL PRIVATE { Private } ; /* Polymorphic types */ @@ -1288,11 +1292,11 @@ core_type2: { $1 } | QUESTION LIDENT COLON core_type2 MINUSGREATER core_type2 { mktyp(Ptyp_arrow("?" ^ $2 , - {ptyp_desc = Ptyp_constr(Lident "option", [$4]); + {ptyp_desc = Ptyp_constr(Ldot (Lident "*predef*", "option"), [$4]); ptyp_loc = $4.ptyp_loc}, $6)) } | OPTLABEL core_type2 MINUSGREATER core_type2 { mktyp(Ptyp_arrow("?" ^ $1 , - {ptyp_desc = Ptyp_constr(Lident "option", [$2]); + {ptyp_desc = Ptyp_constr(Ldot (Lident "*predef*", "option"), [$2]); ptyp_loc = $2.ptyp_loc}, $4)) } | LIDENT COLON core_type2 MINUSGREATER core_type2 { mktyp(Ptyp_arrow($1, $3, $5)) } @@ -1430,11 +1434,6 @@ val_ident: LIDENT { $1 } | LPAREN operator RPAREN { $2 } ; -val_ident_colon: - LIDENT COLON { $1 } - | LPAREN operator RPAREN COLON { $2 } - | LABEL { $1 } -; operator: PREFIXOP { $1 } | INFIXOP0 { $1 } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index dd2c8a0534..9f7fbb661c 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -75,6 +75,7 @@ and pattern_desc = | Ppat_or of pattern * pattern | Ppat_constraint of pattern * core_type | Ppat_type of Longident.t + | Ppat_lazy of pattern type expression = { pexp_desc: expression_desc; @@ -147,16 +148,16 @@ and type_declaration = { ptype_params: string list; ptype_cstrs: (core_type * core_type * Location.t) list; ptype_kind: type_kind; + ptype_private: private_flag; ptype_manifest: core_type option; ptype_variance: (bool * bool) list; ptype_loc: Location.t } and type_kind = Ptype_abstract - | Ptype_variant of (string * core_type list * Location.t) list * private_flag + | Ptype_variant of (string * core_type list * Location.t) list | Ptype_record of - (string * mutable_flag * core_type * Location.t) list * private_flag - | Ptype_private + (string * mutable_flag * core_type * Location.t) list and exception_declaration = core_type list diff --git a/parsing/printast.ml b/parsing/printast.ml index de0042496c..bfe0d53a49 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -202,12 +202,15 @@ and pattern i ppf x = line i ppf "Ppat_or\n"; pattern i ppf p1; pattern i ppf p2; + | Ppat_lazy p -> + line i ppf "Ppat_lazy\n"; + pattern i ppf p; | Ppat_constraint (p, ct) -> line i ppf "Ppat_constraint"; pattern i ppf p; core_type i ppf ct; | Ppat_type li -> - line i ppf "PPat_type"; + line i ppf "Ppat_type"; longident i ppf li and expression i ppf x = @@ -371,6 +374,7 @@ and type_declaration i ppf x = list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs; line i ppf "ptype_kind =\n"; type_kind (i+1) ppf x.ptype_kind; + line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private; line i ppf "ptype_manifest =\n"; option (i+1) core_type ppf x.ptype_manifest; @@ -378,14 +382,12 @@ and type_kind i ppf x = match x with | Ptype_abstract -> line i ppf "Ptype_abstract\n" - | Ptype_variant (l, priv) -> - line i ppf "Ptype_variant %a\n" fmt_private_flag priv; + | Ptype_variant l -> + line i ppf "Ptype_variant\n"; list (i+1) string_x_core_type_list_x_location ppf l; - | Ptype_record (l, priv) -> - line i ppf "Ptype_record %a\n" fmt_private_flag priv; + | Ptype_record l -> + line i ppf "Ptype_record\n"; list (i+1) string_x_mutable_flag_x_core_type_x_location ppf l; - | Ptype_private -> - line i ppf "Ptype_private\n" and exception_declaration i ppf x = list i core_type ppf x diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml index 182863f132..d96b946a87 100644 --- a/parsing/syntaxerr.ml +++ b/parsing/syntaxerr.ml @@ -31,11 +31,9 @@ let report_error ppf = function the highlighted '%s' might be unmatched" closing opening else begin fprintf ppf "%aSyntax error: '%s' expected@." - Location.print closing_loc closing; + Location.print_error closing_loc closing; fprintf ppf "%aThis '%s' might be unmatched" - Location.print opening_loc opening + Location.print_error opening_loc opening end | Other loc -> - fprintf ppf "%aSyntax error" Location.print loc - - + fprintf ppf "%aSyntax error" Location.print_error loc diff --git a/stdlib/.depend b/stdlib/.depend index fe9f5ad1f7..a45db17dee 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -1,3 +1,4 @@ +camlinternalLazy.cmi: obj.cmi camlinternalMod.cmi: obj.cmi camlinternalOO.cmi: obj.cmi format.cmi: buffer.cmi @@ -18,6 +19,7 @@ buffer.cmo: sys.cmi string.cmi buffer.cmi buffer.cmx: sys.cmx string.cmx buffer.cmi callback.cmo: obj.cmi callback.cmi callback.cmx: obj.cmx callback.cmi +camlinternalLazy.cmo: camlinternalLazy.cmi camlinternalMod.cmo: obj.cmi camlinternalOO.cmi array.cmi camlinternalMod.cmi camlinternalMod.cmx: obj.cmx camlinternalOO.cmx array.cmx camlinternalMod.cmi camlinternalOO.cmo: sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \ @@ -46,8 +48,8 @@ int32.cmo: pervasives.cmi int32.cmi int32.cmx: pervasives.cmx int32.cmi int64.cmo: pervasives.cmi int64.cmi int64.cmx: pervasives.cmx int64.cmi -lazy.cmo: obj.cmi lazy.cmi -lazy.cmx: obj.cmx lazy.cmi +lazy.cmo: obj.cmi camlinternalLazy.cmi lazy.cmi +lazy.cmx: obj.cmx camlinternalLazy.cmx lazy.cmi lexing.cmo: sys.cmi string.cmi array.cmi lexing.cmi lexing.cmx: sys.cmx string.cmx array.cmx lexing.cmi list.cmo: list.cmi @@ -94,7 +96,7 @@ stack.cmo: list.cmi stack.cmi stack.cmx: list.cmx stack.cmi stdLabels.cmo: stringLabels.cmi listLabels.cmi arrayLabels.cmi stdLabels.cmi stdLabels.cmx: stringLabels.cmx listLabels.cmx arrayLabels.cmx stdLabels.cmi -stream.cmo: string.cmi obj.cmi list.cmi stream.cmi +stream.cmo: string.cmi obj.cmi list.cmi lazy.cmi stream.cmi stream.cmx: string.cmx obj.cmx list.cmx stream.cmi string.cmo: pervasives.cmi list.cmi char.cmi string.cmi string.cmx: pervasives.cmx list.cmx char.cmx string.cmi diff --git a/stdlib/Makefile b/stdlib/Makefile index 0637ebca67..07144d511d 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -13,32 +13,7 @@ # $Id$ -include ../config/Makefile - -RUNTIME=../boot/ocamlrun -COMPILER=../ocamlc -CAMLC=$(RUNTIME) $(COMPILER) -COMPFLAGS=-g -warn-error A -nostdlib $(NOJOIN) -OPTCOMPILER=../ocamlopt -CAMLOPT=$(RUNTIME) $(OPTCOMPILER) -OPTCOMPFLAGS=-warn-error A -nostdlib $(NOJOIN) -g -CAMLDEP=../boot/ocamlrun ../tools/ocamldep $(NOJOIN) - -OBJS=pervasives.cmo $(OTHERS) -OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \ - hashtbl.cmo sort.cmo marshal.cmo obj.cmo \ - int32.cmo int64.cmo nativeint.cmo \ - lexing.cmo parsing.cmo \ - set.cmo map.cmo stack.cmo queue.cmo stream.cmo buffer.cmo \ - printf.cmo format.cmo scanf.cmo \ - arg.cmo printexc.cmo gc.cmo \ - digest.cmo random.cmo callback.cmo \ - camlinternalOO.cmo oo.cmo camlinternalMod.cmo \ - genlex.cmo weak.cmo \ - lazy.cmo filename.cmo complex.cmo \ - arrayLabels.cmo listLabels.cmo stringLabels.cmo moreLabels.cmo stdLabels.cmo - -all: stdlib.cma std_exit.cmo camlheader camlheader_ur +include Makefile.shared allopt: stdlib.cmxa std_exit.cmx allopt-$(PROFILING) @@ -47,10 +22,6 @@ allopt-noprof: allopt-prof: stdlib.p.cmxa std_exit.p.cmx rm -f std_exit.p.cmi -install: - cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur \ - $(LIBDIR) - installopt: installopt-default installopt-$(PROFILING) installopt-default: @@ -68,12 +39,6 @@ installopt-prof: cp stdlib.p.cmxa stdlib.p.a std_exit.p.cmx std_exit.p.o $(LIBDIR) cd $(LIBDIR); $(RANLIB) stdlib.p.a -stdlib.cma: $(OBJS) - $(CAMLC) $(NOJOIN) -a -o stdlib.cma $(OBJS) - -stdlib.cmxa: $(OBJS:.cmo=.cmx) - $(CAMLOPT) $(NOJOIN) -a -o stdlib.cmxa $(OBJS:.cmo=.cmx) - stdlib.p.cmxa: $(OBJS:.cmo=.p.cmx) $(CAMLOPT) $(NOJOIN) -a -o stdlib.p.cmxa $(OBJS:.cmo=.p.cmx) @@ -90,48 +55,5 @@ camlheader camlheader_ur: header.c ../config/Makefile cp camlheader camlheader_ur; \ fi -sys.ml: sys.mlp ../VERSION - sed -e "s|%%VERSION%%|`head -1 ../VERSION`|" sys.mlp >sys.ml - -clean:: - rm -f sys.ml - -clean:: - rm -f camlheader camlheader_ur - -.SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx - -.mli.cmi: - $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $< - -.ml.cmo: - $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $< - -.ml.cmx: - $(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -c $< - -.ml.p.cmx: - $(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -p -c -o $*.p.cmx $< - -# Dependencies on the compiler -$(OBJS) std_exit.cmo: $(COMPILER) -$(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER) -$(OBJS:.cmo=.cmx) std_exit.cmx: $(OPTCOMPILER) -$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: $(OPTCOMPILER) - -# Dependencies on Pervasives (not tracked by ocamldep) -$(OBJS) std_exit.cmo: pervasives.cmi -$(OTHERS:.cmo=.cmi) std_exit.cmi: pervasives.cmi -$(OBJS:.cmo=.cmx) std_exit.cmx: pervasives.cmi -$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmi -$(OTHERS:.cmo=.cmx) std_exit.cmx: pervasives.cmx -$(OTHERS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmx - -clean:: - rm -f *.cm* *.o *.a - rm -f *~ - -include .depend - -depend: - $(CAMLDEP) *.mli *.ml > .depend +.PHONY: all allopt allopt-noprof allopt-prof install installopt +.PHONY: installopt-default installopt-noprof installopt-prof clean depend diff --git a/stdlib/Makefile.nt b/stdlib/Makefile.nt index 4551c89153..aae1de40ae 100644 --- a/stdlib/Makefile.nt +++ b/stdlib/Makefile.nt @@ -13,92 +13,20 @@ # $Id$ -include ../config/Makefile - -RUNTIME=../boot/ocamlrun -COMPILER=../ocamlc -CAMLC=$(RUNTIME) $(COMPILER) -COMPFLAGS=-warn-error A -nostdlib -OPTCOMPILER=../ocamlopt -CAMLOPT=$(RUNTIME) $(OPTCOMPILER) -OPTCOMPFLAGS=-warn-error A -nostdlib -g -CAMLDEP=../boot/ocamlrun ../tools/ocamldep - -OBJS=pervasives.cmo $(OTHERS) -OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \ - hashtbl.cmo sort.cmo marshal.cmo obj.cmo \ - int32.cmo int64.cmo nativeint.cmo \ - lexing.cmo parsing.cmo \ - set.cmo map.cmo stack.cmo queue.cmo stream.cmo buffer.cmo \ - printf.cmo format.cmo scanf.cmo \ - arg.cmo printexc.cmo gc.cmo \ - digest.cmo random.cmo callback.cmo \ - camlinternalOO.cmo oo.cmo camlinternalMod.cmo \ - genlex.cmo weak.cmo \ - lazy.cmo filename.cmo complex.cmo \ - arrayLabels.cmo listLabels.cmo stringLabels.cmo moreLabels.cmo stdLabels.cmo - -all: stdlib.cma std_exit.cmo camlheader camlheader_ur +include Makefile.shared allopt: stdlib.cmxa std_exit.cmx -install: - cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur $(LIBDIR) - installopt: cp stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx $(LIBDIR) -stdlib.cma: $(OBJS) - $(CAMLC) -a -o stdlib.cma $(OBJS) - -stdlib.cmxa: $(OBJS:.cmo=.cmx) - $(CAMLOPT) -a -o stdlib.cmxa $(OBJS:.cmo=.cmx) - camlheader camlheader_ur: headernt.c ../config/Makefile - $(call MKEXE,tmpheader.exe,-I../byterun $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) headernt.c $(EXTRALIBS)) + $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun headernt.c + $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS) rm -f camlheader.exe mv tmpheader.exe camlheader cp camlheader camlheader_ur -sys.ml: sys.mlp ../VERSION - sed -e "s|%%VERSION%%|`head -1 ../VERSION`|" sys.mlp >sys.ml - -clean:: - rm -f sys.ml - -clean:: - rm -f camlheader camlheader_ur - -.SUFFIXES: .mli .ml .cmi .cmo .cmx - -.mli.cmi: - $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $< - -.ml.cmo: - $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $< - -.ml.cmx: - $(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -c $< - -# Dependencies on the compiler -$(OBJS) std_exit.cmo: $(COMPILER) -$(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER) -$(OBJS:.cmo=.cmx) std_exit.cmx: $(OPTCOMPILER) -$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: $(OPTCOMPILER) - -# Dependencies on Pervasives (not tracked by ocamldep) -$(OBJS) std_exit.cmo: pervasives.cmi -$(OTHERS:.cmo=.cmi) std_exit.cmi: pervasives.cmi -$(OBJS:.cmo=.cmx) std_exit.cmx: pervasives.cmi -$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmi -$(OTHERS:.cmo=.cmx) std_exit.cmx: pervasives.cmx -$(OTHERS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmx - -clean:: - rm -f *.cm* *.$(O) *.$(A) - rm -f *~ - -include .depend +# TODO: do not call flexlink to build tmpheader.exe (we don't need +# the export table) -depend: beforedepend - $(CAMLDEP) *.mli *.ml > .depend diff --git a/stdlib/Makefile.shared b/stdlib/Makefile.shared index 2440f1b9ad..36ea6ba252 100755 --- a/stdlib/Makefile.shared +++ b/stdlib/Makefile.shared @@ -17,10 +17,10 @@ include ../config/Makefile RUNTIME=../boot/ocamlrun COMPILER=../ocamlc CAMLC=$(RUNTIME) $(COMPILER) -COMPFLAGS=-g -warn-error A -nostdlib +COMPFLAGS=-g -warn-error A -nostdlib $(NOJOIN) OPTCOMPILER=../ocamlopt CAMLOPT=$(RUNTIME) $(OPTCOMPILER) -OPTCOMPFLAGS=-warn-error A -nostdlib -g +OPTCOMPFLAGS=-warn-error A -nostdlib -g $(NOJOIN) CAMLDEP=../boot/ocamlrun ../tools/ocamldep OBJS=pervasives.cmo $(OTHERS) diff --git a/stdlib/StdlibModules b/stdlib/StdlibModules index f9fec2d962..4f689f8c4a 100644 --- a/stdlib/StdlibModules +++ b/stdlib/StdlibModules @@ -8,6 +8,7 @@ STDLIB_MODULES=\ arrayLabels \ buffer \ callback \ + camlinternalLazy \ camlinternalMod \ camlinternalOO \ char \ diff --git a/stdlib/arg.ml b/stdlib/arg.ml index dd6c517532..009e203753 100644 --- a/stdlib/arg.ml +++ b/stdlib/arg.ml @@ -65,7 +65,7 @@ let make_symlist prefix sep suffix l = let print_spec buf (key, spec, doc) = match spec with - | Symbol (l, _) -> bprintf buf " %s %s %s\n" key (make_symlist "{" "|" "}" l) + | Symbol (l, _) -> bprintf buf " %s %s%s\n" key (make_symlist "{" "|" "}" l) doc | _ -> bprintf buf " %s %s\n" key doc ;; @@ -225,13 +225,18 @@ let rec second_word s = with Not_found -> len ;; -let max_arg_len cur (kwd, _, doc) = - max cur (String.length kwd + second_word doc) +let max_arg_len cur (kwd, spec, doc) = + match spec with + | Symbol _ -> max cur (String.length kwd) + | _ -> max cur (String.length kwd + second_word doc) ;; let add_padding len ksd = match ksd with - | (_, Symbol _, _) -> ksd + | (kwd, (Symbol (l, _) as spec), msg) -> + let cutcol = second_word msg in + let spaces = String.make (len - cutcol + 3) ' ' in + (kwd, spec, "\n" ^ spaces ^ msg) | (kwd, spec, msg) -> let cutcol = second_word msg in let spaces = String.make (len - String.length kwd - cutcol) ' ' in diff --git a/stdlib/arg.mli b/stdlib/arg.mli index bc33d239fd..4e5ed08d1c 100644 --- a/stdlib/arg.mli +++ b/stdlib/arg.mli @@ -125,7 +125,7 @@ val align: (key * spec * doc) list -> (key * spec * doc) list;; space, according to the length of the keyword. Use a space as the first character in a doc string if you want to align the whole string. The doc strings corresponding to - [Symbol] arguments are not aligned. *) + [Symbol] arguments are aligned on the next line. *) val current : int ref (** Position (in {!Sys.argv}) of the argument being processed. You can diff --git a/stdlib/buffer.ml b/stdlib/buffer.ml index 2e8dd8c5e3..8dfe875993 100644 --- a/stdlib/buffer.ml +++ b/stdlib/buffer.ml @@ -126,12 +126,13 @@ let advance_to_non_alpha s start = 'î'|'ô'|'û'|'ë'|'ï'|'ü'|'ç'| 'É'|'À'|'Á'|'È'|'Ù'|'Â'|'Ê'| 'Î'|'Ô'|'Û'|'Ë'|'Ï'|'Ü'|'Ç' -> - advance (i + 1) lim + advance (i + 1) lim | _ -> i in advance start (String.length s);; (* We are just at the beginning of an ident in s, starting at start. *) -let find_ident s start = +let find_ident s start lim = + if start >= lim then raise Not_found else match s.[start] with (* Parenthesized ident ? *) | '(' | '{' as c -> @@ -152,19 +153,21 @@ let add_substitute b f s = match s.[i] with | '$' as current when previous = '\\' -> add_char b current; - subst current (i + 1) + subst ' ' (i + 1) | '$' -> - let ident, next_i = find_ident s (i + 1) in + let j = i + 1 in + let ident, next_i = find_ident s j lim in add_string b (f ident); subst ' ' next_i | current when previous == '\\' -> add_char b '\\'; add_char b current; - subst current (i + 1) + subst ' ' (i + 1) | '\\' as current -> subst current (i + 1) | current -> add_char b current; subst current (i + 1) - end in + end else + if previous = '\\' then add_char b previous in subst ' ' 0;; diff --git a/stdlib/camlinternalMod.ml b/stdlib/camlinternalMod.ml index 17419aef5f..12a77cc8fb 100644 --- a/stdlib/camlinternalMod.ml +++ b/stdlib/camlinternalMod.ml @@ -48,8 +48,16 @@ let rec update_mod shape o n = then begin overwrite o n; Obj.truncate o (Obj.size n) (* PR #4008 *) end else overwrite o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x)) | Lazy -> - assert (Obj.tag n = Obj.lazy_tag); - overwrite o n + if Obj.tag n = Obj.lazy_tag then + Obj.set_field o 0 (Obj.field n 0) + else if Obj.tag n = Obj.forward_tag then begin (* PR#4316 *) + Obj.set_tag o Obj.forward_tag; + Obj.set_field o 0 (Obj.field n 0) + end else begin + (* forwarding pointer was shortcut by GC *) + Obj.set_tag o Obj.forward_tag; + Obj.set_field o 0 n + end | Class -> assert (Obj.tag n = 0 && Obj.size n = 4); overwrite o n diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml index 2205a37fec..2ffa71c0a2 100644 --- a/stdlib/camlinternalOO.ml +++ b/stdlib/camlinternalOO.ml @@ -262,7 +262,7 @@ let new_variable table name = try Vars.find name table.vars with Not_found -> let index = new_slot table in - table.vars <- Vars.add name index table.vars; + if name <> "" then table.vars <- Vars.add name index table.vars; index let to_array arr = diff --git a/stdlib/char.ml b/stdlib/char.ml index 4fbc82583a..28a1bcc46c 100644 --- a/stdlib/char.ml +++ b/stdlib/char.ml @@ -29,23 +29,26 @@ external string_unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" let escaped = function - '\'' -> "\\'" + | '\'' -> "\\'" | '\\' -> "\\\\" | '\n' -> "\\n" | '\t' -> "\\t" - | c -> if is_printable c then begin - let s = string_create 1 in - string_unsafe_set s 0 c; - s - end else begin - let n = code c in - let s = string_create 4 in - string_unsafe_set s 0 '\\'; - string_unsafe_set s 1 (unsafe_chr (48 + n / 100)); - string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10)); - string_unsafe_set s 3 (unsafe_chr (48 + n mod 10)); - s - end + | '\r' -> "\\r" + | '\b' -> "\\b" + | c -> + if is_printable c then begin + let s = string_create 1 in + string_unsafe_set s 0 c; + s + end else begin + let n = code c in + let s = string_create 4 in + string_unsafe_set s 0 '\\'; + string_unsafe_set s 1 (unsafe_chr (48 + n / 100)); + string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10)); + string_unsafe_set s 3 (unsafe_chr (48 + n mod 10)); + s + end let lowercase c = if (c >= 'A' && c <= 'Z') diff --git a/stdlib/format.ml b/stdlib/format.ml index ca31832e89..2083602b99 100644 --- a/stdlib/format.ml +++ b/stdlib/format.ml @@ -13,6 +13,9 @@ (* $Id$ *) +(* A pretty-printing facility and definition of formatters for ``parallel'' + (i.e. unrelated or independent) pretty-printing on multiple out channels. *) + (************************************************************** Data structures definitions. @@ -21,8 +24,10 @@ type size;; -external size_of_int : int -> size = "%identity";; -external int_of_size : size -> int = "%identity";; +external size_of_int : int -> size = "%identity" +;; +external int_of_size : size -> int = "%identity" +;; (* Tokens are one of the following : *) @@ -64,8 +69,11 @@ and tblock = Pp_tbox of int list ref (* Tabulation box *) size is set when the size of the block is known len is the declared length of the token. *) type pp_queue_elem = { - mutable elem_size : size; token : pp_token; length : int -};; + mutable elem_size : size; + token : pp_token; + length : int; +} +;; (* Scan stack: each element is (left_total, queue element) where left_total @@ -79,76 +87,85 @@ type pp_scan_elem = Scan_elem of int * pp_queue_elem;; type pp_format_elem = Format_elem of block_type * int;; (* General purpose queues, used in the formatter. *) -type 'a queue_elem = | Nil | Cons of 'a queue_cell -and 'a queue_cell = {mutable head : 'a; mutable tail : 'a queue_elem};; +type 'a queue_elem = + | Nil + | Cons of 'a queue_cell + +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 -};; + mutable insert : 'a queue_elem; + mutable body : 'a queue_elem; +} +;; (* The formatter specific tag handling functions. *) type formatter_tag_functions = { - mark_open_tag : tag -> string; - mark_close_tag : tag -> string; - print_open_tag : tag -> unit; - print_close_tag : tag -> unit; - -};; + mark_open_tag : tag -> string; + 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_scan_stack : pp_scan_elem list; - mutable pp_format_stack : pp_format_elem list; - mutable pp_tbox_stack : tblock list; - mutable pp_tag_stack : tag list; - mutable pp_mark_stack : tag list; - (* Global variables: default initialization is - set_margin 78 - set_min_space_left 0. *) - (* Value of right margin. *) - mutable pp_margin : int; - (* Minimal space left before margin, when opening a block. *) - mutable pp_min_space_left : int; - (* Maximum value of indentation: - no blocks can be opened further. *) - mutable pp_max_indent : int; - (* Space remaining on the current line. *) - mutable pp_space_left : int; - (* Current value of indentation. *) - mutable pp_current_indent : int; - (* True when the line has been broken by the pretty-printer. *) - mutable pp_is_new_line : bool; - (* Total width of tokens already printed. *) - mutable pp_left_total : int; - (* Total width of tokens ever put in queue. *) - mutable pp_right_total : int; - (* Current number of opened blocks. *) - mutable pp_curr_depth : int; - (* Maximum number of blocks which can be simultaneously opened. *) - mutable pp_max_boxes : int; - (* Ellipsis string. *) - mutable pp_ellipsis : string; - (* Output function. *) - mutable pp_output_function : string -> int -> int -> unit; - (* Flushing function. *) - mutable pp_flush_function : unit -> unit; - (* Output of new lines. *) - mutable pp_output_newline : unit -> unit; - (* Output of indentation spaces. *) - mutable pp_output_spaces : int -> unit; - (* Are tags printed ? *) - mutable pp_print_tags : bool; - (* Are tags marked ? *) - mutable pp_mark_tags : bool; - (* Find opening and closing markers of tags. *) - mutable pp_mark_open_tag : tag -> string; - mutable pp_mark_close_tag : tag -> string; - mutable pp_print_open_tag : tag -> unit; - mutable pp_print_close_tag : tag -> unit; - (* The pretty-printer queue. *) - mutable pp_queue : pp_queue_elem queue -};; + mutable pp_scan_stack : pp_scan_elem list; + mutable pp_format_stack : pp_format_elem list; + mutable pp_tbox_stack : tblock list; + mutable pp_tag_stack : tag list; + mutable pp_mark_stack : tag list; + (* Global variables: default initialization is + set_margin 78 + set_min_space_left 0. *) + (* Value of right margin. *) + mutable pp_margin : int; + (* Minimal space left before margin, when opening a block. *) + mutable pp_min_space_left : int; + (* Maximum value of indentation: + no blocks can be opened further. *) + mutable pp_max_indent : int; + (* Space remaining on the current line. *) + mutable pp_space_left : int; + (* Current value of indentation. *) + mutable pp_current_indent : int; + (* True when the line has been broken by the pretty-printer. *) + mutable pp_is_new_line : bool; + (* Total width of tokens already printed. *) + mutable pp_left_total : int; + (* Total width of tokens ever put in queue. *) + mutable pp_right_total : int; + (* Current number of opened blocks. *) + mutable pp_curr_depth : int; + (* Maximum number of blocks which can be simultaneously opened. *) + mutable pp_max_boxes : int; + (* Ellipsis string. *) + mutable pp_ellipsis : string; + (* Output function. *) + mutable pp_output_function : string -> int -> int -> unit; + (* Flushing function. *) + mutable pp_flush_function : unit -> unit; + (* Output of new lines. *) + mutable pp_output_newline : unit -> unit; + (* Output of indentation spaces. *) + mutable pp_output_spaces : int -> unit; + (* Are tags printed ? *) + mutable pp_print_tags : bool; + (* Are tags marked ? *) + mutable pp_mark_tags : bool; + (* Find opening and closing markers of tags. *) + mutable pp_mark_open_tag : tag -> string; + mutable pp_mark_close_tag : tag -> string; + mutable pp_print_open_tag : tag -> unit; + mutable pp_print_close_tag : tag -> unit; + (* The pretty-printer queue. *) + mutable pp_queue : pp_queue_elem queue; +} +;; (************************************************************** @@ -158,38 +175,43 @@ type formatter = { (* Queues auxilliaries. *) -let make_queue () = {insert = Nil; body = Nil};; +let make_queue () = { insert = Nil; body = Nil; };; let clear_queue q = q.insert <- Nil; q.body <- Nil;; let add_queue x q = - let c = Cons {head = x; tail = Nil} in - match q with - | {insert = Cons cell} -> q.insert <- c; cell.tail <- c - (* Invariant: when insert is Nil body should be Nil. *) - | _ -> q.insert <- c; q.body <- c;; + let c = Cons { head = x; tail = Nil; } in + match q with + | { insert = Cons cell } -> + q.insert <- c; cell.tail <- c + (* Invariant: when insert is Nil body should be Nil. *) + | _ -> q.insert <- c; q.body <- c;; exception Empty_queue;; let peek_queue = function - | {body = Cons {head = x}} -> x - | _ -> raise Empty_queue;; + | { body = Cons { head = x; }; } -> x + | _ -> raise Empty_queue +;; let take_queue = function - | {body = Cons {head = x; tail = tl}} as q -> + | { 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;; + state.pp_right_total <- state.pp_right_total + len; + 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;; + state.pp_left_total <- 1; state.pp_right_total <- 1; + clear_queue state.pp_queue +;; (* Pp_infinity: large value for default tokens size. @@ -209,58 +231,63 @@ let pp_clear_queue state = pretty-printing algorithm's invariants. Given that this arithmetic correctness check is difficult and error prone and given that 1e10 + 1 is in practice large enough, there is no need to attempt to set - pp_infinity to the theoretically maximum limit. Is it not worth the + pp_infinity to the theoretically maximum limit. It is not worth the burden ! *) let pp_infinity = 1000000010;; (* Output functions for the formatter. *) let pp_output_string state s = state.pp_output_function s 0 (String.length s) -and pp_output_newline state = state.pp_output_newline ();; - -let pp_display_blanks state n = state.pp_output_spaces n;; +and pp_output_newline state = state.pp_output_newline () +and pp_display_blanks state n = state.pp_output_spaces n +;; (* To format a break, indenting a new line. *) let break_new_line state offset width = - pp_output_newline state; - state.pp_is_new_line <- true; - let indent = state.pp_margin - width + offset in - (* Don't indent more than pp_max_indent. *) - 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_output_newline state; + state.pp_is_new_line <- true; + let indent = state.pp_margin - width + offset in + (* Don't indent more than pp_max_indent. *) + 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 +;; (* 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;; + state.pp_space_left <- state.pp_space_left - 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 by simulating a break. *) let pp_force_break_line state = - match state.pp_format_stack with - | Format_elem (bl_ty, width) :: _ -> - if width > state.pp_space_left then - (match bl_ty with - | Pp_fits -> () | Pp_hbox -> () | _ -> break_line state width) - | _ -> pp_output_newline state;; + match state.pp_format_stack with + | Format_elem (bl_ty, width) :: _ -> + if width > state.pp_space_left then + (match bl_ty with + | Pp_fits -> () | Pp_hbox -> () + | _ -> break_line state width) + | _ -> pp_output_newline state +;; (* To skip a token, if the previous line has been broken. *) let pp_skip_token state = - (* When calling pp_skip_token the queue cannot be empty. *) - 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;; + (* When calling pp_skip_token the queue cannot be empty. *) + 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 +;; (************************************************************** - The main pretting printing functions. + The main pretty printing functions. **************************************************************) @@ -268,149 +295,162 @@ let pp_skip_token state = let format_pp_token state size = function | Pp_text s -> - state.pp_space_left <- state.pp_space_left - size; - pp_output_string state s; - state.pp_is_new_line <- false + state.pp_space_left <- state.pp_space_left - size; + pp_output_string state s; + state.pp_is_new_line <- false | Pp_begin (off, ty) -> - let insertion_point = state.pp_margin - state.pp_space_left in - if insertion_point > state.pp_max_indent then - (* can't open a block right there. *) - begin pp_force_break_line state end; - let offset = state.pp_space_left - off in - let bl_type = - begin match ty with - | Pp_vbox -> Pp_vbox - | _ -> if size > state.pp_space_left then ty else Pp_fits - end in - state.pp_format_stack <- - Format_elem (bl_type, offset) :: state.pp_format_stack + let insertion_point = state.pp_margin - state.pp_space_left in + if insertion_point > state.pp_max_indent then + (* can't open a block right there. *) + begin pp_force_break_line state end; + let offset = state.pp_space_left - off in + let bl_type = + begin match ty with + | Pp_vbox -> Pp_vbox + | _ -> if size > state.pp_space_left then ty else Pp_fits + end in + state.pp_format_stack <- + Format_elem (bl_type, offset) :: state.pp_format_stack | Pp_end -> - begin match state.pp_format_stack with - | x :: (y :: l as ls) -> state.pp_format_stack <- ls - | _ -> () (* No more block to close. *) - end + begin match state.pp_format_stack with + | x :: (y :: l as ls) -> state.pp_format_stack <- ls + | _ -> () (* No more block to close. *) + end | Pp_tbegin (Pp_tbox _ as tbox) -> - state.pp_tbox_stack <- tbox :: state.pp_tbox_stack + state.pp_tbox_stack <- tbox :: state.pp_tbox_stack | Pp_tend -> - begin match state.pp_tbox_stack with - | x :: ls -> state.pp_tbox_stack <- ls - | _ -> () (* No more tabulation block to close. *) - end + begin match state.pp_tbox_stack with + | x :: ls -> state.pp_tbox_stack <- ls + | _ -> () (* No more tabulation block to close. *) + end | Pp_stab -> - begin match state.pp_tbox_stack with - | Pp_tbox tabs :: _ -> - let rec add_tab n = function - | [] -> [n] - | x :: l as ls -> if n < x then n :: ls else x :: add_tab n l in - tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs - | _ -> () (* No opened tabulation block. *) - end + begin match state.pp_tbox_stack with + | Pp_tbox tabs :: _ -> + let rec add_tab n = function + | [] -> [n] + | x :: l as ls -> if n < x then n :: ls else x :: add_tab n l in + tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs + | _ -> () (* No opened tabulation block. *) + end | Pp_tbreak (n, off) -> - let insertion_point = state.pp_margin - state.pp_space_left in - begin match state.pp_tbox_stack with - | Pp_tbox tabs :: _ -> - let rec find n = function - | x :: l -> if x >= n then x else find n l - | [] -> raise Not_found in - let tab = - match !tabs with - | x :: l -> - begin try find insertion_point !tabs with Not_found -> x end - | _ -> insertion_point in - let offset = tab - insertion_point in - if offset >= 0 then break_same_line state (offset + n) else - break_new_line state (tab + off) state.pp_margin - | _ -> () (* No opened tabulation block. *) - end + let insertion_point = state.pp_margin - state.pp_space_left in + begin match state.pp_tbox_stack with + | Pp_tbox tabs :: _ -> + let rec find n = function + | x :: l -> if x >= n then x else find n l + | [] -> raise Not_found in + let tab = + match !tabs with + | x :: l -> + begin + try find insertion_point !tabs with + | Not_found -> x + end + | _ -> insertion_point in + let offset = tab - insertion_point in + if offset >= 0 + then break_same_line state (offset + n) + else break_new_line state (tab + off) state.pp_margin + | _ -> () (* No opened tabulation block. *) + end | Pp_newline -> - begin match state.pp_format_stack with - | Format_elem (_, width) :: _ -> break_line state width - | _ -> pp_output_newline state - end + begin match state.pp_format_stack with + | Format_elem (_, width) :: _ -> break_line state width + | _ -> pp_output_newline state + end | Pp_if_newline -> - if state.pp_current_indent != state.pp_margin - state.pp_space_left - then pp_skip_token state + if state.pp_current_indent != state.pp_margin - state.pp_space_left + then pp_skip_token state | Pp_break (n, off) -> - begin match state.pp_format_stack with - | Format_elem (ty, width) :: _ -> - begin match ty with - | Pp_hovbox -> - if size > state.pp_space_left - then break_new_line state off width - else break_same_line state n - | Pp_box -> - (* Have the line just been broken here ? *) - if state.pp_is_new_line then break_same_line state n else - if size > state.pp_space_left - then break_new_line state off width else - (* break the line here leads to new indentation ? *) - if state.pp_current_indent > state.pp_margin - width + off - then break_new_line state off width - else break_same_line state n - | Pp_hvbox -> break_new_line state off width - | Pp_fits -> break_same_line state n - | Pp_vbox -> break_new_line state off width - | Pp_hbox -> break_same_line state n - end - | _ -> () (* No opened block. *) - end + begin match state.pp_format_stack with + | Format_elem (ty, width) :: _ -> + begin match ty with + | Pp_hovbox -> + if size > state.pp_space_left + then break_new_line state off width + else break_same_line state n + | Pp_box -> + (* Have the line just been broken here ? *) + if state.pp_is_new_line then break_same_line state n else + if size > state.pp_space_left + then break_new_line state off width else + (* break the line here leads to new indentation ? *) + if state.pp_current_indent > state.pp_margin - width + off + then break_new_line state off width + else break_same_line state n + | Pp_hvbox -> break_new_line state off width + | Pp_fits -> break_same_line state n + | Pp_vbox -> break_new_line state off width + | Pp_hbox -> break_same_line state n + end + | _ -> () (* No opened block. *) + end | Pp_open_tag tag_name -> - let marker = state.pp_mark_open_tag tag_name in - pp_output_string state marker; - state.pp_mark_stack <- tag_name :: state.pp_mark_stack + let marker = state.pp_mark_open_tag tag_name in + pp_output_string state marker; + state.pp_mark_stack <- tag_name :: state.pp_mark_stack | Pp_close_tag -> - begin match state.pp_mark_stack with - | tag_name :: tags -> - let marker = state.pp_mark_close_tag tag_name in - pp_output_string state marker; - state.pp_mark_stack <- tags - | _ -> () (* No more tag to close. *) - end;; + begin match state.pp_mark_stack with + | tag_name :: tags -> + let marker = state.pp_mark_close_tag tag_name in + pp_output_string state marker; + state.pp_mark_stack <- tags + | _ -> () (* No more tag to close. *) + end +;; (* 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;; (* To enqueue a string : try to advance. *) let make_queue_elem size tok len = - {elem_size = size; token = tok; length = len};; + { elem_size = size; token = tok; length = len; };; let enqueue_string_as state size s = let len = int_of_size size in - enqueue_advance state (make_queue_elem size (Pp_text s) len);; + enqueue_advance state (make_queue_elem size (Pp_text s) len) +;; let enqueue_string state s = let len = String.length s in - enqueue_string_as state (size_of_int len) s;; + enqueue_string_as state (size_of_int len) s +;; (* Routines for scan stack determine sizes of blocks. *) @@ -418,7 +458,8 @@ let enqueue_string state s = (* The scan_stack is never empty. *) let scan_stack_bottom = let q_elem = make_queue_elem (size_of_int (-1)) (Pp_text "") 0 in - [Scan_elem (-1, q_elem)];; + [Scan_elem (-1, q_elem)] +;; (* Set size of blocks on scan stack: if ty = true then size of break is set else size of block is set; @@ -430,89 +471,104 @@ let clear_scan_stack state = state.pp_scan_stack <- scan_stack_bottom;; Pattern matching on token in scan stack is also exhaustive, since scan_push is used on breaks and opening of boxes. *) let set_size state ty = - match state.pp_scan_stack with - | Scan_elem - (left_tot, - ({elem_size = size; token = tok} as queue_elem)) :: t -> - let size = int_of_size size in - (* test if scan stack contains any data that is not obsolete. *) - if left_tot < state.pp_left_total then clear_scan_stack state else - begin match tok with - | Pp_break (_, _) | Pp_tbreak (_, _) -> - if ty then - begin - queue_elem.elem_size <- size_of_int (state.pp_right_total + size); - state.pp_scan_stack <- t - end - | Pp_begin (_, _) -> - if not ty then - begin - queue_elem.elem_size <- size_of_int (state.pp_right_total + size); - state.pp_scan_stack <- t - end - | _ -> () (* scan_push is only used for breaks and boxes. *) + match state.pp_scan_stack with + | Scan_elem + (left_tot, + ({elem_size = size; token = tok} as queue_elem)) :: t -> + let size = int_of_size size in + (* test if scan stack contains any data that is not obsolete. *) + if left_tot < state.pp_left_total then clear_scan_stack state else + begin match tok with + | Pp_break (_, _) | Pp_tbreak (_, _) -> + if ty then + begin + queue_elem.elem_size <- size_of_int (state.pp_right_total + size); + state.pp_scan_stack <- t + end + | Pp_begin (_, _) -> + if not ty then + begin + queue_elem.elem_size <- size_of_int (state.pp_right_total + size); + state.pp_scan_stack <- t end - | _ -> () (* scan_stack is never empty. *);; + | _ -> () (* scan_push is only used for breaks and boxes. *) + end + | _ -> () (* 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;; + 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 +;; (* To open a new block : the user may set the depth bound pp_max_boxes any text nested deeper is printed as the ellipsis string. *) let pp_open_box_gen state indent br_ty = - state.pp_curr_depth <- state.pp_curr_depth + 1; - if state.pp_curr_depth < state.pp_max_boxes then - let elem = - make_queue_elem - (size_of_int (- state.pp_right_total)) - (Pp_begin (indent, br_ty)) - 0 in - scan_push state false elem else - if state.pp_curr_depth = state.pp_max_boxes - then enqueue_string state state.pp_ellipsis;; + state.pp_curr_depth <- state.pp_curr_depth + 1; + if state.pp_curr_depth < state.pp_max_boxes then + let elem = + make_queue_elem + (size_of_int (- state.pp_right_total)) + (Pp_begin (indent, br_ty)) + 0 in + scan_push state false elem else + if state.pp_curr_depth = state.pp_max_boxes + then enqueue_string state state.pp_ellipsis +;; (* 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 - if state.pp_curr_depth < state.pp_max_boxes then - begin - pp_enqueue state - {elem_size = size_of_int 0; token = Pp_end; length = 0}; - set_size state true; set_size state false - end; - state.pp_curr_depth <- state.pp_curr_depth - 1; - end;; + if state.pp_curr_depth > 1 then + begin + if state.pp_curr_depth < state.pp_max_boxes then + begin + pp_enqueue state + { elem_size = size_of_int 0; token = Pp_end; length = 0; }; + set_size state true; set_size state false + end; + state.pp_curr_depth <- state.pp_curr_depth - 1; + end +;; (* Open a tag, pushing it on the tag stack. *) let pp_open_tag state tag_name = - if state.pp_print_tags then begin - state.pp_tag_stack <- tag_name :: state.pp_tag_stack; - state.pp_print_open_tag tag_name end; - if state.pp_mark_tags then - pp_enqueue state - {elem_size = size_of_int 0; token = Pp_open_tag tag_name; length = 0};; + if state.pp_print_tags then + begin + state.pp_tag_stack <- tag_name :: state.pp_tag_stack; + state.pp_print_open_tag tag_name + end; + if state.pp_mark_tags then + pp_enqueue state { + elem_size = size_of_int 0; + token = Pp_open_tag tag_name; + length = 0; + } +;; (* Close a tag, popping it from the tag stack. *) let pp_close_tag state () = - if state.pp_mark_tags then - pp_enqueue state - {elem_size = size_of_int 0; token = Pp_close_tag; length = 0}; - if state.pp_print_tags then - begin match state.pp_tag_stack with - | tag_name :: tags -> - state.pp_print_close_tag tag_name; - state.pp_tag_stack <- tags - | _ -> () (* No more tag to close. *) - end;; + if state.pp_mark_tags then + pp_enqueue state { + elem_size = size_of_int 0; + token = Pp_close_tag; + length = 0; + }; + if state.pp_print_tags then + begin + match state.pp_tag_stack with + | tag_name :: tags -> + state.pp_print_close_tag tag_name; + state.pp_tag_stack <- tags + | _ -> () (* No more tag to close. *) + 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;; @@ -521,11 +577,12 @@ let pp_get_mark_tags state () = state.pp_mark_tags;; let pp_set_tags state b = pp_set_print_tags state b; pp_set_mark_tags state b;; let pp_get_formatter_tag_functions state () = { - mark_open_tag = state.pp_mark_open_tag; - mark_close_tag = state.pp_mark_close_tag; - print_open_tag = state.pp_print_open_tag; - print_close_tag = state.pp_print_close_tag; -};; + mark_open_tag = state.pp_mark_open_tag; + 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; @@ -536,30 +593,32 @@ let pp_set_formatter_tag_functions state { state.pp_mark_open_tag <- mot; state.pp_mark_close_tag <- mct; state.pp_print_open_tag <- pot; - state.pp_print_close_tag <- pct;; + state.pp_print_close_tag <- pct +;; (* Initialize pretty-printer. *) let pp_rinit state = - pp_clear_queue state; - clear_scan_stack state; - state.pp_format_stack <- []; - state.pp_tbox_stack <- []; - state.pp_tag_stack <- []; - state.pp_mark_stack <- []; - state.pp_current_indent <- 0; - state.pp_curr_depth <- 0; - state.pp_space_left <- state.pp_margin; - pp_open_sys_box state;; + pp_clear_queue state; + clear_scan_stack state; + state.pp_format_stack <- []; + state.pp_tbox_stack <- []; + state.pp_tag_stack <- []; + state.pp_mark_stack <- []; + state.pp_current_indent <- 0; + state.pp_curr_depth <- 0; + state.pp_space_left <- state.pp_margin; + pp_open_sys_box state;; (* Flushing pretty-printer queue. *) let pp_flush_queue state b = - while state.pp_curr_depth > 1 do - pp_close_box state () - done; - state.pp_right_total <- pp_infinity; - advance_left state; - if b then pp_output_newline state; - pp_rinit state;; + while state.pp_curr_depth > 1 do + pp_close_box state () + done; + state.pp_right_total <- pp_infinity; + advance_left state; + if b then pp_output_newline state; + pp_rinit state +;; (************************************************************** @@ -570,13 +629,16 @@ let pp_flush_queue state b = (* To format a string. *) let pp_print_as_size state size s = if state.pp_curr_depth < state.pp_max_boxes - then enqueue_string_as state size s;; + then enqueue_string_as state size s +;; let pp_print_as state isize s = - pp_print_as_size state (size_of_int isize) s;; + pp_print_as_size state (size_of_int isize) s +;; let pp_print_string state s = - pp_print_as state (String.length s) s;; + pp_print_as state (String.length s) s +;; (* To format an integer. *) let pp_print_int state i = pp_print_string state (string_of_int i);; @@ -591,7 +653,8 @@ let pp_print_bool state b = pp_print_string state (string_of_bool b);; let pp_print_char state c = let s = String.create 1 in s.[0] <- c; - pp_print_as state 1 s;; + pp_print_as state 1 s +;; (* Opening boxes. *) let pp_open_hbox state () = pp_open_box_gen state 0 Pp_hbox @@ -604,19 +667,21 @@ and pp_open_box state indent = pp_open_box_gen state indent Pp_box;; (* Print a new line after printing all queued text (same for print_flush but without a newline). *) let pp_print_newline state () = - pp_flush_queue state true; state.pp_flush_function () + pp_flush_queue state true; state.pp_flush_function () and pp_print_flush state () = - pp_flush_queue state false; state.pp_flush_function ();; + pp_flush_queue state false; state.pp_flush_function ();; (* 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 @@ -629,10 +694,12 @@ let pp_print_break state width offset = (size_of_int (- state.pp_right_total)) (Pp_break (width, offset)) width in - scan_push state true elem;; + scan_push state true elem +;; let pp_print_space state () = pp_print_break state 1 0 -and pp_print_cut state () = pp_print_break state 0 0;; +and pp_print_cut state () = pp_print_break state 0 0 +;; (* Tabulation boxes. *) let pp_open_tbox state () = @@ -640,15 +707,19 @@ 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 () = - if state.pp_curr_depth > 1 then begin + if state.pp_curr_depth > 1 then + begin if state.pp_curr_depth < state.pp_max_boxes then 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;; + state.pp_curr_depth <- state.pp_curr_depth - 1 + end +;; (* Print a tabulation break. *) let pp_print_tbreak state width offset = @@ -658,7 +729,8 @@ let pp_print_tbreak state width offset = (size_of_int (- state.pp_right_total)) (Pp_tbreak (width, offset)) width in - scan_push state true elem;; + scan_push state true elem +;; let pp_print_tab state () = pp_print_tbreak state 0 0;; @@ -666,7 +738,8 @@ let pp_set_tab state () = if state.pp_curr_depth < state.pp_max_boxes then let elem = make_queue_elem (size_of_int 0) Pp_stab 0 in - enqueue_advance state elem;; + enqueue_advance state elem +;; (************************************************************** @@ -684,24 +757,28 @@ let pp_over_max_boxes state () = state.pp_curr_depth = state.pp_max_boxes;; (* Ellipsis. *) let pp_set_ellipsis_text state s = state.pp_ellipsis <- s -and pp_get_ellipsis_text state () = state.pp_ellipsis;; +and pp_get_ellipsis_text state () = state.pp_ellipsis +;; (* To set the margin of pretty-printer. *) let pp_limit n = - if n < pp_infinity then n else pred pp_infinity;; + if n < pp_infinity then n else pred pp_infinity +;; let pp_set_min_space_left state n = if n >= 1 then let n = pp_limit n in state.pp_min_space_left <- n; state.pp_max_indent <- state.pp_margin - state.pp_min_space_left; - pp_rinit state;; + pp_rinit state +;; (* Initially, we have : pp_max_indent = pp_margin - pp_min_space_left, and pp_space_left = pp_margin. *) let pp_set_max_indent state n = - pp_set_min_space_left state (state.pp_margin - n);; + pp_set_min_space_left state (state.pp_margin - n) +;; let pp_get_max_indent state () = state.pp_max_indent;; let pp_set_margin state n = @@ -709,36 +786,41 @@ let pp_set_margin state n = let n = pp_limit n in state.pp_margin <- n; let new_max_indent = - (* Try to maintain max_indent to its actual value. *) - if state.pp_max_indent <= state.pp_margin - then state.pp_max_indent else - (* If possible maintain pp_min_space_left to its actual value, - if this leads to a too small max_indent, take half of the - new margin, if it is greater than 1. *) - 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;; + (* Try to maintain max_indent to its actual value. *) + if state.pp_max_indent <= state.pp_margin + then state.pp_max_indent else + (* If possible maintain pp_min_space_left to its actual value, + if this leads to a too small max_indent, take half of the + new margin, if it is greater than 1. *) + 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 +;; 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) +;; (************************************************************** @@ -753,78 +835,87 @@ let default_pp_print_open_tag s = ();; let default_pp_print_close_tag = default_pp_print_open_tag;; let pp_make_formatter f g h i = - (* The initial state of the formatter contains a dummy box. *) - let pp_q = make_queue () in - let sys_tok = - make_queue_elem (size_of_int (-1)) (Pp_begin (0, Pp_hovbox)) 0 in - add_queue sys_tok pp_q; - let sys_scan_stack = - (Scan_elem (1, sys_tok)) :: scan_stack_bottom in - {pp_scan_stack = sys_scan_stack; - pp_format_stack = []; - pp_tbox_stack = []; - pp_tag_stack = []; - pp_mark_stack = []; - pp_margin = 78; - pp_min_space_left = 10; - pp_max_indent = 78 - 10; - pp_space_left = 78; - pp_current_indent = 0; - pp_is_new_line = true; - pp_left_total = 1; - pp_right_total = 1; - pp_curr_depth = 1; - pp_max_boxes = max_int; - pp_ellipsis = "."; - pp_output_function = f; - pp_flush_function = g; - pp_output_newline = h; - pp_output_spaces = i; - pp_print_tags = false; - pp_mark_tags = false; - pp_mark_open_tag = default_pp_mark_open_tag; - pp_mark_close_tag = default_pp_mark_close_tag; - pp_print_open_tag = default_pp_print_open_tag; - pp_print_close_tag = default_pp_print_close_tag; - pp_queue = pp_q - };; + (* The initial state of the formatter contains a dummy box. *) + let pp_q = make_queue () in + let sys_tok = + make_queue_elem (size_of_int (-1)) (Pp_begin (0, Pp_hovbox)) 0 in + add_queue sys_tok pp_q; + let sys_scan_stack = + (Scan_elem (1, sys_tok)) :: scan_stack_bottom in + {pp_scan_stack = sys_scan_stack; + pp_format_stack = []; + pp_tbox_stack = []; + pp_tag_stack = []; + pp_mark_stack = []; + pp_margin = 78; + pp_min_space_left = 10; + pp_max_indent = 78 - 10; + pp_space_left = 78; + pp_current_indent = 0; + pp_is_new_line = true; + pp_left_total = 1; + pp_right_total = 1; + pp_curr_depth = 1; + pp_max_boxes = max_int; + pp_ellipsis = "."; + pp_output_function = f; + pp_flush_function = g; + pp_output_newline = h; + pp_output_spaces = i; + pp_print_tags = false; + pp_mark_tags = false; + pp_mark_open_tag = default_pp_mark_open_tag; + pp_mark_close_tag = default_pp_mark_close_tag; + 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 ' ';; let rec display_blanks state n = - if n > 0 then - if n <= 80 then state.pp_output_function blank_line 0 n else - begin - state.pp_output_function blank_line 0 80; - display_blanks state (n - 80) - end;; + if n > 0 then + if n <= 80 then state.pp_output_function blank_line 0 n else + begin + state.pp_output_function blank_line 0 80; + display_blanks state (n - 80) + 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;; -let str_formatter = formatter_of_buffer stdbuf;; -let std_formatter = formatter_of_out_channel stdout;; -let err_formatter = formatter_of_out_channel stderr;; +(* 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 +;; let flush_str_formatter () = pp_flush_queue str_formatter false; let s = Buffer.contents stdbuf in Buffer.reset stdbuf; - s;; + s +;; (************************************************************** @@ -875,32 +966,32 @@ and set_ellipsis_text = pp_set_ellipsis_text std_formatter and get_ellipsis_text = pp_get_ellipsis_text std_formatter and set_formatter_out_channel = - pp_set_formatter_out_channel std_formatter + pp_set_formatter_out_channel std_formatter and set_formatter_output_functions = - pp_set_formatter_output_functions std_formatter + pp_set_formatter_output_functions std_formatter and get_formatter_output_functions = - pp_get_formatter_output_functions std_formatter + pp_get_formatter_output_functions std_formatter and set_all_formatter_output_functions = - pp_set_all_formatter_output_functions std_formatter + pp_set_all_formatter_output_functions std_formatter and get_all_formatter_output_functions = - pp_get_all_formatter_output_functions std_formatter + pp_get_all_formatter_output_functions std_formatter and set_formatter_tag_functions = - pp_set_formatter_tag_functions std_formatter + pp_set_formatter_tag_functions std_formatter and get_formatter_tag_functions = - pp_get_formatter_tag_functions std_formatter + pp_get_formatter_tag_functions std_formatter and set_print_tags = - pp_set_print_tags std_formatter + pp_set_print_tags std_formatter and get_print_tags = - pp_get_print_tags std_formatter + pp_get_print_tags std_formatter and set_mark_tags = - pp_set_mark_tags std_formatter + pp_set_mark_tags std_formatter and get_mark_tags = - pp_get_mark_tags std_formatter + pp_get_mark_tags std_formatter and set_tags = - pp_set_tags std_formatter + pp_set_tags std_formatter ;; @@ -921,7 +1012,8 @@ let giving_up mess fmt i = giving up at character number " ^ string_of_int i ^ (if i < Sformat.length fmt then " (" ^ String.make 1 (Sformat.get fmt i) ^ ")." - else String.make 1 '.');; + else String.make 1 '.') +;; (* When an invalid format deserves a special error explanation. *) let format_invalid_arg mess fmt i = invalid_arg (giving_up mess fmt i);; @@ -938,33 +1030,38 @@ let format_int_of_string fmt i s = let sz = try int_of_string s with | Failure s -> invalid_integer fmt i in - size_of_int sz;; + size_of_int sz +;; (* Getting strings out of buffers. *) let get_buffer_out b = - let s = Buffer.contents b in - Buffer.reset b; - s;; + let s = Buffer.contents b in + Buffer.reset b; + 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;; + pp_flush_queue ppf false; + get_buffer_out b +;; (* Applies [printer] to a formatter that outputs on a fresh buffer, then returns the resulting material. *) let exstring printer arg = - let b = Buffer.create 512 in - let ppf = formatter_of_buffer b in - printer ppf arg; - string_out b ppf;; + let b = Buffer.create 512 in + let ppf = formatter_of_buffer b in + printer ppf arg; + 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, @@ -979,73 +1076,74 @@ let implode_rev s0 = function let mkprintf to_s get_out = let rec kprintf k fmt = + let len = Sformat.length fmt in let kpr fmt v = let ppf = get_out fmt in let print_as = ref None in let pp_print_as_char c = - match !print_as with - | None -> pp_print_char ppf c - | Some size -> - pp_print_as_size ppf size (String.make 1 c); - print_as := None + match !print_as with + | None -> pp_print_char ppf c + | Some size -> + pp_print_as_size ppf size (String.make 1 c); + print_as := None and pp_print_as_string s = - match !print_as with - | None -> pp_print_string ppf s - | Some size -> - pp_print_as_size ppf size s; - print_as := None in + match !print_as with + | None -> pp_print_string ppf s + | Some size -> + pp_print_as_size ppf size s; + print_as := None in let rec doprn n i = if i >= len then Obj.magic (k ppf) else match Sformat.get fmt i with | '%' -> - Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m + Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m | '@' -> - let i = succ i in - if i >= len then invalid_format fmt i else - begin match Sformat.get fmt i with - | '[' -> - do_pp_open_box ppf n (succ i) - | ']' -> - pp_close_box ppf (); - doprn n (succ i) - | '{' -> - do_pp_open_tag ppf n (succ i) - | '}' -> - pp_close_tag ppf (); - doprn n (succ i) - | ' ' -> - pp_print_space ppf (); - doprn n (succ i) - | ',' -> - pp_print_cut ppf (); - doprn n (succ i) - | '?' -> - pp_print_flush ppf (); - doprn n (succ i) - | '.' -> - pp_print_newline ppf (); - doprn n (succ i) - | '\n' -> - pp_force_newline ppf (); - doprn n (succ i) - | ';' -> - do_pp_break ppf n (succ i) - | '<' -> - let got_size size n i = - print_as := Some size; - doprn n (skip_gt i) in - get_int n (succ i) got_size - | '@' as c -> - pp_print_as_char c; - doprn n (succ i) - | c -> invalid_format fmt i - end + let i = succ i in + if i >= len then invalid_format fmt i else + begin match Sformat.get fmt i with + | '[' -> + do_pp_open_box ppf n (succ i) + | ']' -> + pp_close_box ppf (); + doprn n (succ i) + | '{' -> + do_pp_open_tag ppf n (succ i) + | '}' -> + pp_close_tag ppf (); + doprn n (succ i) + | ' ' -> + pp_print_space ppf (); + doprn n (succ i) + | ',' -> + pp_print_cut ppf (); + doprn n (succ i) + | '?' -> + pp_print_flush ppf (); + doprn n (succ i) + | '.' -> + pp_print_newline ppf (); + doprn n (succ i) + | '\n' -> + pp_force_newline ppf (); + doprn n (succ i) + | ';' -> + do_pp_break ppf n (succ i) + | '<' -> + let got_size size n i = + print_as := Some size; + doprn n (skip_gt i) in + get_int n (succ i) got_size + | '@' as c -> + pp_print_as_char c; + doprn n (succ i) + | c -> invalid_format fmt i + end | c -> - pp_print_as_char c; - doprn n (succ i) + pp_print_as_char c; + doprn n (succ i) and cont_s n s i = pp_print_as_string s; doprn n i @@ -1067,125 +1165,134 @@ let mkprintf to_s get_out = kprintf (Obj.magic (fun _ -> doprn n i)) sfmt and get_int n i c = - if i >= len then invalid_integer fmt i else - match Sformat.get fmt i with - | ' ' -> get_int n (succ i) c - | '%' -> + if i >= len then invalid_integer fmt i else + match Sformat.get fmt i with + | ' ' -> get_int n (succ i) c + | '%' -> let cont_s n s i = c (format_int_of_string fmt i s) n i and cont_a n printer arg i = invalid_integer fmt i and cont_t n printer i = invalid_integer fmt i and cont_f n i = invalid_integer fmt i and cont_m n sfmt i = invalid_integer fmt i in Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m - | _ -> + | _ -> let rec get j = - if j >= len then invalid_integer fmt j else - match Sformat.get fmt j with - | '0' .. '9' | '-' -> get (succ j) - | _ -> - let size = - if j = i then size_of_int 0 else + if j >= len then invalid_integer fmt j else + match Sformat.get fmt j with + | '0' .. '9' | '-' -> get (succ j) + | _ -> + let size = + if j = i then size_of_int 0 else let s = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in format_int_of_string fmt j s in - c size n j in + c size n j in get i and skip_gt i = - if i >= len then invalid_format fmt i else - match Sformat.get fmt i with - | ' ' -> skip_gt (succ i) - | '>' -> succ i - | _ -> invalid_format fmt i + if i >= len then invalid_format fmt i else + match Sformat.get fmt i with + | ' ' -> skip_gt (succ i) + | '>' -> succ i + | _ -> invalid_format fmt i and get_box_kind i = - if i >= len then Pp_box, i else - match Sformat.get fmt i with - | 'h' -> - let i = succ i in - if i >= len then Pp_hbox, i else - begin match Sformat.get fmt i with - | 'o' -> + if i >= len then Pp_box, i else + match Sformat.get fmt i with + | 'h' -> + let i = succ i in + if i >= len then Pp_hbox, i else + begin match Sformat.get fmt i with + | 'o' -> let i = succ i in if i >= len then format_invalid_arg "bad box format" fmt i else begin match Sformat.get fmt i with | 'v' -> Pp_hovbox, succ i | c -> - format_invalid_arg - ("bad box name ho" ^ String.make 1 c) fmt i end - | 'v' -> Pp_hvbox, succ i - | c -> Pp_hbox, i - end - | 'b' -> Pp_box, succ i - | 'v' -> Pp_vbox, succ i - | _ -> Pp_box, i + format_invalid_arg + ("bad box name ho" ^ String.make 1 c) fmt i + end + | 'v' -> Pp_hvbox, succ i + | c -> Pp_hbox, i + end + | 'b' -> Pp_box, succ i + | 'v' -> Pp_vbox, succ i + | _ -> Pp_box, i and get_tag_name n i c = - let rec get accu n i j = - if j >= len - then c (implode_rev (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) accu) n j else - match Sformat.get fmt j with - | '>' -> c (implode_rev (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) accu) n j - | '%' -> - let s0 = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in - let cont_s n s i = get (s :: s0 :: accu) n i i - and cont_a n printer arg i = - let s = - if to_s - then (Obj.magic printer : unit -> _ -> string) () arg - else exstring printer arg in - get (s :: s0 :: accu) n i i - and cont_t n printer i = - let s = - if to_s - then (Obj.magic printer : unit -> string) () - else exstring (fun ppf () -> printer ppf) () in - get (s :: s0 :: accu) n i i - and cont_f n i = - format_invalid_arg "bad tag name specification" fmt i - and cont_m n sfmt i = - format_invalid_arg "bad tag name specification" fmt i in - Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m - | c -> get accu n i (succ j) in - get [] n i i + let rec get accu n i j = + if j >= len then + c (implode_rev + (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) + accu) + n j else + match Sformat.get fmt j with + | '>' -> + c (implode_rev + (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) + accu) + n j + | '%' -> + let s0 = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in + let cont_s n s i = get (s :: s0 :: accu) n i i + and cont_a n printer arg i = + let s = + if to_s + then (Obj.magic printer : unit -> _ -> string) () arg + else exstring printer arg in + get (s :: s0 :: accu) n i i + and cont_t n printer i = + let s = + if to_s + then (Obj.magic printer : unit -> string) () + else exstring (fun ppf () -> printer ppf) () in + get (s :: s0 :: accu) n i i + and cont_f n i = + format_invalid_arg "bad tag name specification" fmt i + and cont_m n sfmt i = + format_invalid_arg "bad tag name specification" fmt i in + Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m + | c -> get accu n i (succ j) in + get [] n i i and do_pp_break ppf n i = - if i >= len then begin pp_print_space ppf (); doprn n i end else - match Sformat.get fmt i with - | '<' -> + if i >= len then begin pp_print_space ppf (); doprn n i end else + match Sformat.get fmt i with + | '<' -> let rec got_nspaces nspaces n i = get_int n i (got_offset nspaces) and got_offset nspaces offset n i = pp_print_break ppf (int_of_size nspaces) (int_of_size offset); doprn n (skip_gt i) in get_int n (succ i) got_nspaces - | c -> pp_print_space ppf (); doprn n i + | c -> pp_print_space ppf (); doprn n i and do_pp_open_box ppf n i = - if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else - match Sformat.get fmt i with - | '<' -> + if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else + match Sformat.get fmt i with + | '<' -> let kind, i = get_box_kind (succ i) in let got_size size n i = pp_open_box_gen ppf (int_of_size size) kind; doprn n (skip_gt i) in get_int n i got_size - | c -> pp_open_box_gen ppf 0 Pp_box; doprn n i + | c -> pp_open_box_gen ppf 0 Pp_box; doprn n i and do_pp_open_tag ppf n i = - if i >= len then begin pp_open_tag ppf ""; doprn n i end else - match Sformat.get fmt i with - | '<' -> + if i >= len then begin pp_open_tag ppf ""; doprn n i end else + match Sformat.get fmt i with + | '<' -> let got_name tag_name n i = pp_open_tag ppf tag_name; doprn n (skip_gt i) in get_tag_name n (succ i) got_name - | c -> pp_open_tag ppf ""; doprn n i in + | c -> pp_open_tag ppf ""; doprn n i in doprn (Sformat.index_of_int 0) 0 in - Tformat.kapr kpr fmt in + Tformat.kapr kpr fmt in - kprintf;; + kprintf +;; (************************************************************** @@ -1201,17 +1308,20 @@ let printf fmt = fprintf std_formatter fmt;; let eprintf fmt = fprintf err_formatter fmt;; let kbprintf k b = - mkprintf false (fun _ -> formatter_of_buffer b) k;; + mkprintf false (fun _ -> formatter_of_buffer b) k +;; let bprintf b = kbprintf ignore b;; let ksprintf k = let b = Buffer.create 512 in let k ppf = k (string_out b ppf) in - mkprintf true (fun _ -> formatter_of_buffer b) k;; + mkprintf true (fun _ -> formatter_of_buffer b) k +;; let kprintf = ksprintf;; let sprintf fmt = ksprintf (fun s -> s) fmt;; -at_exit print_flush;; +at_exit print_flush +;; diff --git a/stdlib/gc.mli b/stdlib/gc.mli index 4d36a29f2e..be476d21e9 100644 --- a/stdlib/gc.mli +++ b/stdlib/gc.mli @@ -86,7 +86,7 @@ type control = mutable major_heap_increment : int; (** The minimum number of words to add to the - major heap when increasing it. Default: 62k. *) + major heap when increasing it. Default: 124k. *) mutable space_overhead : int; (** The major GC speed is computed from this parameter. @@ -125,7 +125,7 @@ type control = mutable stack_limit : int; (** The maximum size of the stack (in words). This is only relevant to the byte-code runtime, as the native code runtime - uses the operating system's stack. Default: 256k. *) + uses the operating system's stack. Default: 256k. *) } (** The GC parameters are given as a [control] record. Note that these parameters can also be initialised by setting the diff --git a/stdlib/int32.mli b/stdlib/int32.mli index dc733ec9fc..eeafb1a2fc 100644 --- a/stdlib/int32.mli +++ b/stdlib/int32.mli @@ -160,9 +160,5 @@ val compare: t -> t -> int (** {6 Deprecated functions} *) external format : string -> int32 -> string = "caml_int32_format" -(** [Int32.format fmt n] return the string representation of the - 32-bit integer [n] in the format specified by [fmt]. - [fmt] is a [Printf]-style format consisting of exactly - one [%d], [%i], [%u], [%x], [%X] or [%o] conversion specification. - This function is deprecated; use {!Printf.sprintf} with a [%lx] format - instead. *) +(** Do not use this deprecated function. Instead, + used {!Printf.sprintf} with a [%l...] format. *) diff --git a/stdlib/int64.mli b/stdlib/int64.mli index 7bc39e6123..3b641338e7 100644 --- a/stdlib/int64.mli +++ b/stdlib/int64.mli @@ -182,9 +182,5 @@ val compare: t -> t -> int (** {6 Deprecated functions} *) external format : string -> int64 -> string = "caml_int64_format" -(** [Int64.format fmt n] return the string representation of the - 64-bit integer [n] in the format specified by [fmt]. - [fmt] is a {!Printf}-style format consisting of exactly one - [%d], [%i], [%u], [%x], [%X] or [%o] conversion specification. - This function is deprecated; use {!Printf.sprintf} with a [%Lx] format - instead. *) +(** Do not use this deprecated function. Instead, + used {!Printf.sprintf} with a [%L...] format. *) diff --git a/stdlib/lazy.ml b/stdlib/lazy.ml index 70acccd10a..b1a9cbbda3 100644 --- a/stdlib/lazy.ml +++ b/stdlib/lazy.ml @@ -46,46 +46,16 @@ *) type 'a t = 'a lazy_t;; -exception Undefined;; -let raise_undefined = Obj.repr (fun () -> raise Undefined);; +exception Undefined = CamlinternalLazy.Undefined;; -external follow_forward : Obj.t -> 'a = "caml_lazy_follow_forward";; external make_forward : 'a -> 'a lazy_t = "caml_lazy_make_forward";; -let force (l : 'arg t) = - let x = Obj.repr l in - let t = Obj.tag x in - if t = Obj.forward_tag then (follow_forward x : 'arg) - else if t <> Obj.lazy_tag then (Obj.obj x : 'arg) - else begin - let closure = (Obj.obj (Obj.field x 0) : unit -> 'arg) in - Obj.set_field x 0 raise_undefined; - try - let result = closure () in - Obj.set_field x 0 (Obj.repr result); (* do set_field BEFORE set_tag *) - Obj.set_tag x Obj.forward_tag; - result - with e -> - Obj.set_field x 0 (Obj.repr (fun () -> raise e)); - raise e - end -;; +external force : 'a t -> 'a = "%lazy_force";; -let force_val (l : 'arg t) = - let x = Obj.repr l in - let t = Obj.tag x in - if t = Obj.forward_tag then (follow_forward x : 'arg) - else if t <> Obj.lazy_tag then (Obj.obj x : 'arg) - else begin - let closure = (Obj.obj (Obj.field x 0) : unit -> 'arg) in - Obj.set_field x 0 raise_undefined; - let result = closure () in - Obj.set_field x 0 (Obj.repr result); (* do set_field BEFORE set_tag *) - Obj.set_tag x (Obj.forward_tag); - result - end -;; +(* let force = force;; *) + +let force_val = CamlinternalLazy.force_val;; let lazy_from_fun (f : unit -> 'arg) = let x = Obj.new_block Obj.lazy_tag 1 in diff --git a/stdlib/lazy.mli b/stdlib/lazy.mli index afdb1e6d17..f0255c224d 100644 --- a/stdlib/lazy.mli +++ b/stdlib/lazy.mli @@ -39,7 +39,8 @@ type 'a t = 'a lazy_t;; exception Undefined;; -val force : 'a t -> 'a;; +external force : 'a t -> 'a = "%lazy_force";; +(* val force : 'a t -> 'a ;; *) (** [force x] forces the suspension [x] and returns its result. If [x] has already been forced, [Lazy.force x] returns the same value again without recomputing it. If it raised an exception, diff --git a/stdlib/lexing.ml b/stdlib/lexing.ml index 8aec2ef124..9e01415265 100644 --- a/stdlib/lexing.ml +++ b/stdlib/lexing.ml @@ -220,6 +220,14 @@ let lexeme_end lexbuf = lexbuf.lex_curr_p.pos_cnum;; let lexeme_start_p lexbuf = lexbuf.lex_start_p;; let lexeme_end_p lexbuf = lexbuf.lex_curr_p;; +let new_line lexbuf = + let lcp = lexbuf.lex_curr_p in + lexbuf.lex_curr_p <- { lcp with + pos_lnum = lcp.pos_lnum + 1; + pos_bol = lcp.pos_cnum; + } +;; + (* Discard data left in lexer buffer. *) diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli index 7bf47ea49d..1868825ce7 100644 --- a/stdlib/lexing.mli +++ b/stdlib/lexing.mli @@ -68,7 +68,7 @@ type lexbuf = without change by the lexing engine. In order to keep them accurate, they must be initialised before the first use of the lexbuf, and updated by the relevant lexer actions (i.e. at each - end of line). + end of line -- see also [new_line]). *) val from_channel : in_channel -> lexbuf @@ -129,6 +129,11 @@ val lexeme_end_p : lexbuf -> position (** Like [lexeme_end], but return a complete [position] instead of an offset. *) +val new_line : lexbuf -> unit +(** Update the [lex_curr_p] field of the lexbuf to reflect the start + of a new line. You can call this function in the semantic action + of the rule that matches the end-of-line character. *) + (** {6 Miscellaneous functions} *) val flush_input : lexbuf -> unit diff --git a/stdlib/obj.ml b/stdlib/obj.ml index 20f3b695fc..9685be38ff 100644 --- a/stdlib/obj.ml +++ b/stdlib/obj.ml @@ -54,3 +54,4 @@ let final_tag = custom_tag let int_tag = 1000 let out_of_heap_tag = 1001 +let unaligned_tag = 1002 diff --git a/stdlib/obj.mli b/stdlib/obj.mli index 4455612563..a35b119bde 100644 --- a/stdlib/obj.mli +++ b/stdlib/obj.mli @@ -49,6 +49,7 @@ val final_tag : int (* DEPRECATED *) val int_tag : int val out_of_heap_tag : int +val unaligned_tag : int (* should never happen *) (** The following two functions are deprecated. Use module {!Marshal} instead. *) diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml index 8df008c5cb..2b4d93ddb8 100644 --- a/stdlib/parsing.ml +++ b/stdlib/parsing.ml @@ -78,6 +78,9 @@ external parse_engine : parse_tables -> parser_env -> parser_input -> Obj.t -> parser_output = "caml_parse_engine" +external set_trace: bool -> bool + = "caml_set_parser_trace" + let env = { s_stack = Array.create 100 0; v_stack = Array.create 100 (Obj.repr ()); diff --git a/stdlib/parsing.mli b/stdlib/parsing.mli index c6dc8e3212..c323922cfa 100644 --- a/stdlib/parsing.mli +++ b/stdlib/parsing.mli @@ -59,6 +59,13 @@ exception Parse_error Can also be raised from the action part of a grammar rule, to initiate error recovery. *) +val set_trace: bool -> bool +(** Control debugging support for [ocamlyacc]-generated parsers. + After [Parsing.set_trace true], the pushdown automaton that + executes the parsers prints a trace of its actions (reading a token, + shifting a state, reducing by a rule) on standard output. + [Parsing.set_trace false] turns this debugging trace off. + The boolean returned is the previous state of the trace flag. *) (**/**) diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index 3ff3f40418..7ead634fbb 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -49,7 +49,7 @@ external ( = ) : 'a -> 'a -> bool = "%equal" if and only if their current contents are structurally equal, even if the two mutable objects are not the same physical object. Equality between functional values raises [Invalid_argument]. - Equality between cyclic data structures does not terminate. *) + Equality between cyclic data structures may not terminate. *) external ( <> ) : 'a -> 'a -> bool = "%notequal" (** Negation of {!Pervasives.(=)}. *) @@ -361,7 +361,8 @@ val min_float : float (** The smallest positive, non-zero, non-denormalized value of type [float]. *) val epsilon_float : float -(** The smallest positive float [x] such that [1.0 +. x <> 1.0]. *) +(** The difference between [1.0] and the smallest exactly representable + floating-point number greater than [1.0]. *) type fpclass = FP_normal (** Normal number, none of the below *) @@ -674,7 +675,7 @@ val open_in_bin : string -> in_channel mode, this function behaves like {!Pervasives.open_in}. *) val open_in_gen : open_flag list -> int -> string -> in_channel -(** [open_in mode perm filename] opens the named file for reading, +(** [open_in_gen mode perm filename] opens the named file for reading, as described above. The extra arguments [mode] and [perm] specify the opening mode and file permissions. {!Pervasives.open_in} and {!Pervasives.open_in_bin} are special @@ -816,17 +817,22 @@ external decr : int ref -> unit = "%decr" (** {6 Operations on format strings} *) -(** See modules {!Printf} and {!Scanf} for more operations on - format strings. *) -type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 +(** Format strings are used to read and print data using formatted input + functions in module {!Scanf} and formatted output in modules {!Printf} and + {!Format}. *) -type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 -(** Simplified type for format strings, included for backward compatibility - with earlier releases of Objective Caml. +(** Format strings have a general and highly polymorphic type + [('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in. + The two simplified types, [format] and [format4] below are + included for backward compatibility with earlier releases of Objective + Caml. ['a] is the type of the parameters of the format, ['c] is the result type for the "printf"-style function, and ['b] is the type of the first argument given to [%a] and [%t] printing functions. *) +type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 + +type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 val string_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string (** Converts a format string into a string. *) @@ -851,7 +857,7 @@ val ( ^^ ) : val exit : int -> 'a (** Terminate the process, returning the given status code to the operating system: usually 0 to indicate no errors, - and a small positive integer to indicate failure. + and a small positive integer to indicate failure. All open output channels are flushed with flush_all. An implicit [exit 0] is performed each time a program terminates normally. An implicit [exit 2] is performed if the program diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml index cbc9d3a685..f06717c274 100644 --- a/stdlib/printexc.ml +++ b/stdlib/printexc.ml @@ -68,3 +68,60 @@ let catch fct arg = flush stdout; eprintf "Uncaught exception: %s\n" (to_string x); exit 2 + +type loc_info = + | Known_location of bool (* is_raise *) + * string (* filename *) + * int (* line number *) + * int (* start char *) + * int (* end char *) + | Unknown_location of bool (*is_raise*) + +external get_exception_backtrace: + unit -> loc_info array option = "caml_get_exception_backtrace" + +let format_loc_info pos li = + let is_raise = + match li with + | Known_location(is_raise, _, _, _, _) -> is_raise + | Unknown_location(is_raise) -> is_raise in + let info = + if is_raise then + if pos = 0 then "Raised at" else "Re-raised at" + else + if pos = 0 then "Raised by primitive operation at" else "Called from" + in + match li with + | Known_location(is_raise, filename, lineno, startchar, endchar) -> + sprintf "%s file \"%s\", line %d, characters %d-%d" + info filename lineno startchar endchar + | Unknown_location(is_raise) -> + sprintf "%s unknown location" + info + +let print_backtrace outchan = + match get_exception_backtrace() with + | None -> + fprintf outchan + "(Program not linked with -g, cannot print stack backtrace)\n" + | Some a -> + for i = 0 to Array.length a - 1 do + if a.(i) <> Unknown_location true then + fprintf outchan "%s\n" (format_loc_info i a.(i)) + done + +let get_backtrace () = + match get_exception_backtrace() with + | None -> + "(Program not linked with -g, cannot print stack backtrace)\n" + | Some a -> + let b = Buffer.create 1024 in + for i = 0 to Array.length a - 1 do + if a.(i) <> Unknown_location true then + bprintf b "%s\n" (format_loc_info i a.(i)) + done; + Buffer.contents b + +external record_backtrace: bool -> unit = "caml_record_backtrace" +external backtrace_status: unit -> bool = "caml_backtrace_status" + diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli index 887169c429..a3ae6ba7b4 100644 --- a/stdlib/printexc.mli +++ b/stdlib/printexc.mli @@ -36,3 +36,24 @@ val catch : ('a -> 'b) -> 'a -> 'b makes it harder to track the location of the exception using the debugger or the stack backtrace facility. So, do not use [Printexc.catch] in new code. *) + +val print_backtrace: out_channel -> unit +(** [Printexc.print_backtrace oc] prints an exception backtrace + on the output channel [oc]. The backtrace lists the program + locations where the most-recently raised exception was raised + and where it was propagated through function calls. *) + +val get_backtrace: unit -> string +(** [Printexc.get_backtrace ()] returns a string containing the + same exception backtrace that [Printexc.print_backtrace] would + print. *) + +val record_backtrace: bool -> unit +(** [Printexc.record_backtrace b] turns recording of exception backtraces + on (if [b = true]) or off (if [b = false]). Initially, backtraces + are not recorded, unless the [b] flag is given to the program + through the [OCAMLRUNPARAM] variable. *) + +val backtrace_status: unit -> bool +(** [Printexc.backtrace_status()] returns [true] if exception + backtraces are currently recorded, [false] if not. *) diff --git a/stdlib/printf.ml b/stdlib/printf.ml index f4a27ca521..92ce254769 100644 --- a/stdlib/printf.ml +++ b/stdlib/printf.ml @@ -28,11 +28,14 @@ module Sformat = struct type index;; - external unsafe_index_of_int : int -> index = "%identity";; + external unsafe_index_of_int : int -> index = "%identity" + ;; let index_of_int i = if i >= 0 then unsafe_index_of_int i - else failwith ("index_of_int: negative argument " ^ string_of_int i);; - external int_of_index : index -> int = "%identity";; + else failwith ("Sformat.index_of_int: negative argument " ^ string_of_int i) + ;; + external int_of_index : index -> int = "%identity" + ;; let add_int_index i idx = index_of_int (i + int_of_index idx);; let succ_index = add_int_index 1;; @@ -40,31 +43,41 @@ module Sformat = struct 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 = @@ -79,7 +92,9 @@ let parse_string_conversion sfmt = parse true (succ i) | _ -> parse neg (succ i) in - try parse false 1 with Failure _ -> bad_conversion sfmt 0 's' + try parse false 1 with + | Failure _ -> bad_conversion sfmt 0 's' +;; (* Pad a (sub) string into a blank string of length [p], on the right if [neg] is true, on the left otherwise. *) @@ -93,14 +108,16 @@ let pad_string pad_char p neg s i len = res (* Format a string given a %s format, e.g. %40s or %-20s. - To do: ignore other flags (#, +, etc)? *) + To do ?: ignore other flags (#, +, etc). *) let format_string sfmt s = let (p, neg) = parse_string_conversion sfmt in - pad_string ' ' p neg s 0 (String.length s);; + pad_string ' ' p neg s 0 (String.length s) +;; (* Extract a format string out of [fmt] between [start] and [stop] inclusive. - '*' in the format are replaced by integers taken from the [widths] list. - extract_format returns a string. *) + ['*'] in the format are replaced by integers taken from the [widths] list. + [extract_format] returns a string which is the string representation of + the resulting format string. *) let extract_format fmt start stop widths = let skip_positional_spec start = match Sformat.unsafe_get fmt start with @@ -127,7 +144,8 @@ let extract_format fmt start stop widths = | (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 @@ -135,7 +153,8 @@ let extract_format_int conv fmt start stop widths = | 'n' | 'N' -> sfmt.[String.length sfmt - 1] <- 'u'; sfmt - | _ -> sfmt;; + | _ -> sfmt +;; (* Returns the position of the next character following the meta format string, starting from position [i], inside a given format [fmt]. @@ -157,12 +176,14 @@ let sub_format incomplete_format bad_conversion_format conv fmt i = if j >= len then incomplete_format fmt else match Sformat.get fmt j with | '(' | '{' as c -> - let j = sub_fmt c (succ j) in sub (succ j) + let j = sub_fmt c (succ j) in + sub (succ j) | '}' | ')' as c -> if c = close then succ j else bad_conversion_format fmt i c | _ -> sub (succ j) in sub i in - sub_fmt conv i;; + sub_fmt conv i +;; let sub_format_for_printf conv = sub_format incomplete_format bad_conversion_format conv;; @@ -175,7 +196,7 @@ let iter_on_format_args fmt add_conv add_char = if i > lim then incomplete_format fmt else match Sformat.unsafe_get fmt i with | '*' -> scan_flags skip (add_conv skip i 'i') - | '$' -> scan_flags skip (succ i) + (* | '$' -> scan_flags skip (succ i) *** PR#4321 *) | '#' | '-' | ' ' | '+' -> scan_flags skip (succ i) | '_' -> scan_flags true (succ i) | '0'..'9' @@ -225,7 +246,8 @@ let iter_on_format_args fmt add_conv add_char = else scan_fmt (succ i) else i in - ignore (scan_fmt 0);; + ignore (scan_fmt 0) +;; (* Returns a string that summarizes the typing information that a given format string contains. @@ -239,7 +261,8 @@ let summarize_format_type fmt = if skip then Buffer.add_string b "%_" else Buffer.add_char b '%'; add_char i c in iter_on_format_args fmt add_conv add_char; - Buffer.contents b;; + Buffer.contents b +;; module Ac = struct type ac = { @@ -247,11 +270,12 @@ module Ac = struct mutable ac_skip : int; mutable ac_rdrs : int; } -end;; +end +;; open Ac;; -(* Computes the number of arguments of a format (including flag +(* Computes the number of arguments of a format (including the flag arguments if any). *) let ac_of_format fmt = let ac = { ac_rglr = 0; ac_skip = 0; ac_rdrs = 0; } in @@ -268,23 +292,26 @@ let ac_of_format fmt = and add_char i c = succ i in iter_on_format_args fmt add_conv add_char; - ac;; + ac +;; let count_arguments_of_format fmt = let ac = ac_of_format fmt in - ac.ac_rglr + ac.ac_skip + ac.ac_rdrs;; + ac.ac_rglr + ac.ac_skip + ac.ac_rdrs +;; let list_iter_i f l = let rec loop i = function | [] -> () | [x] -> f i x (* Tail calling [f] *) | x :: xs -> f i x; loop (succ i) xs in - loop 0 l;; + loop 0 l +;; (* ``Abstracting'' version of kprintf: returns a (curried) function that will print when totally applied. Note: in the following, we are careful not to be badly caught - by the compiler optimizations on the representation of arrays. *) + by the compiler optimizations for the representation of arrays. *) let kapr kpr fmt = match count_arguments_of_format fmt with | 0 -> kpr fmt [||] @@ -322,19 +349,37 @@ let kapr kpr fmt = list_iter_i (fun i arg -> a.(nargs - i - 1) <- arg) args; kpr fmt a else Obj.magic (fun x -> loop (succ i) (x :: args)) in - loop 0 [];; + loop 0 [] +;; type positional_specification = - | Spec_none | Spec_index of Sformat.index;; + | Spec_none | Spec_index of Sformat.index +;; (* To scan an optional positional parameter specification, i.e. an integer followed by a [$]. - We do not support [*$] specifications, since this would lead to type checking - problems: the type of the specified [*$] parameter would be the type of the - corresponding argument to [printf], hence the type of the $n$-th argument to - [printf] with $n$ being the {\em value} of the integer argument defining - [*]; this means type dependency, which is out of scope of the Caml type - algebra. *) + + 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 -> @@ -343,40 +388,48 @@ let scan_positional_spec fmt got_spec n i = | '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 + 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. *) + (* 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. *) - | _ -> got_spec Spec_none 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 position of the next argument to printf, according to the given +(* 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;; + | Spec_index _ -> n +;; -(* Get the position of the actual argument to printf, according to its +(* 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;; + | 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]. *) @@ -488,11 +541,12 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m = | conv -> bad_conversion_format fmt i conv in - scan_positional 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 @@ -505,34 +559,36 @@ let mkprintf to_s get_out outc outs flush k fmt = match Sformat.unsafe_get fmt i with | '%' -> scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m | c -> outc out c; doprn n (succ i) - and cont_s n s i = - outs out s; doprn n i - and cont_a n printer arg i = - if to_s then - outs out ((Obj.magic printer : unit -> _ -> string) () arg) - else - printer out arg; - doprn n i - and cont_t n printer i = - if to_s then - outs out ((Obj.magic printer : unit -> string) ()) - else - printer out; - doprn n i - and cont_f n i = - flush out; doprn n i - and cont_m n xf i = - let m = Sformat.add_int_index (count_arguments_of_format xf) n in - pr (Obj.magic (fun _ -> doprn m i)) n xf v in - - doprn n 0 in + and cont_s n s i = + outs out s; doprn n i + and cont_a n printer arg i = + if to_s then + outs out ((Obj.magic printer : unit -> _ -> string) () arg) + else + printer out arg; + doprn n i + and cont_t n printer i = + if to_s then + outs out ((Obj.magic printer : unit -> string) ()) + else + printer out; + doprn n i + and cont_f n i = + flush out; doprn n i + and cont_m n xf i = + let m = Sformat.add_int_index (count_arguments_of_format xf) n in + pr (Obj.magic (fun _ -> doprn m i)) n xf v in + + doprn n 0 in let kpr = pr k (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;; @@ -540,22 +596,26 @@ let printf fmt = fprintf stdout fmt;; let eprintf fmt = fprintf stderr fmt;; let kbprintf k b = - mkprintf false (fun _ -> b) Buffer.add_char Buffer.add_string ignore k;; + mkprintf false (fun _ -> b) Buffer.add_char Buffer.add_string ignore k +;; let bprintf b = kbprintf ignore b;; let get_buff fmt = let len = 2 * Sformat.length fmt in - Buffer.create len;; + Buffer.create len +;; let get_contents b = let s = Buffer.contents b in Buffer.clear b; - s;; + s +;; let get_cont k b = k (get_contents b);; let ksprintf k = - mkprintf true get_buff Buffer.add_char Buffer.add_string ignore (get_cont k);; + mkprintf true get_buff Buffer.add_char Buffer.add_string ignore (get_cont k) +;; let kprintf = ksprintf;; @@ -572,7 +632,8 @@ module CamlinternalPr = struct mutable ac_rglr : int; mutable ac_skip : int; mutable ac_rdrs : int; - };; + } + ;; let ac_of_format = ac_of_format;; @@ -584,6 +645,8 @@ module CamlinternalPr = struct let kapr = kapr;; - end;; + end + ;; -end;; +end +;; diff --git a/stdlib/printf.mli b/stdlib/printf.mli index e8bd7d6c92..059779922b 100644 --- a/stdlib/printf.mli +++ b/stdlib/printf.mli @@ -27,7 +27,7 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a Conversion specifications have the following form: - [% \[positional specifier\] \[flags\] \[width\] \[.precision\] type] + [% \[flags\] \[width\] \[.precision\] type] In short, a conversion specification consists in the [%] character, followed by optional modifiers and a type which is made of one or @@ -79,10 +79,6 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a - [!]: take no argument and flush the output. - [%]: take no argument and output one [%] character. - The optional [positional specifier] consists of an integer followed - by a [$]; the integer indicates which argument to use, the first - argument being denoted by 1. - The optional [flags] are: - [-]: left-justify the output (default is right justification). - [0]: for numerical conversions, pad with zeroes instead of spaces. @@ -102,10 +98,9 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a The integer in a [width] or [precision] can also be specified as [*], in which case an extra integer argument is taken to specify the corresponding [width] or [precision]. This integer argument - precedes immediately the argument to print, unless an optional - [positional specifier] is given to indicates which argument to - use. For instance, [%.*3$f] prints a [float] with as many fractional - digits as the value of the third argument. *) + precedes immediately the argument to print. + For instance, [%.*f] prints a [float] with as many fractional + digits as the value of the argument given before the float. *) val printf : ('a, out_channel, unit) format -> 'a (** Same as {!Printf.fprintf}, but output on [stdout]. *) @@ -127,6 +122,7 @@ val bprintf : Buffer.t -> ('a, Buffer.t, unit) format -> 'a (see module {!Buffer}). *) (** Formatted output functions with continuations. *) + val kfprintf : (out_channel -> 'a) -> out_channel -> ('b, out_channel, unit, 'a) format4 -> 'b;; (** Same as [fprintf], but instead of returning immediately, @@ -185,7 +181,10 @@ module CamlinternalPr : sig val sub_format : (('a, 'b, 'c, 'd, 'e, 'f) format6 -> int) -> (('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char -> int) -> - char -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> int + char -> + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + int -> + int val summarize_format_type : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string @@ -197,12 +196,14 @@ module CamlinternalPr : sig (Sformat.index -> 'i -> 'j -> int -> 'h) -> (Sformat.index -> 'k -> int -> 'h) -> (Sformat.index -> int -> 'h) -> - (Sformat.index -> ('l, 'm, 'n, 'o, 'p, 'q) format6 -> int -> 'h) -> 'h + (Sformat.index -> ('l, 'm, 'n, 'o, 'p, 'q) format6 -> int -> 'h) -> + 'h val kapr : (('a, 'b, 'c, 'd, 'e, 'f) format6 -> Obj.t array -> 'g) -> - ('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + 'g + end;; end;; - diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml index a32a48b3f5..5ab7aeba73 100644 --- a/stdlib/scanf.ml +++ b/stdlib/scanf.ml @@ -36,7 +36,7 @@ val invalidate_current_char : scanbuf -> unit;; val peek_char : scanbuf -> char;; (* [Scanning.peek_char ib] returns the current char available in - the buffer or read one if necessary (when the current character is + the buffer or reads one if necessary (when the current character is already scanned). If no character can be read, sets an end of file condition and returns '\000'. *) @@ -104,7 +104,8 @@ val from_file : string -> scanbuf;; val from_file_bin : string -> scanbuf;; val from_function : (unit -> char) -> scanbuf;; -end;; +end +;; module Scanning : SCANNING = struct @@ -121,7 +122,8 @@ type scanbuf = { mutable get_next_char : unit -> char; tokbuf : Buffer.t; file_name : file_name; -};; +} +;; let null_char = '\000';; @@ -134,14 +136,15 @@ let next_char ib = ib.current_char <- c; ib.current_char_is_valid <- true; ib.char_count <- succ ib.char_count; - if c == '\n' then ib.line_count <- succ ib.line_count; + if c = '\n' then ib.line_count <- succ ib.line_count; c with | End_of_file -> let c = null_char in ib.current_char <- c; ib.current_char_is_valid <- false; ib.eof <- true; - c;; + c +;; let peek_char ib = if ib.current_char_is_valid then ib.current_char else next_char ib;; @@ -154,17 +157,21 @@ let peek_char ib = let checked_peek_char ib = let c = peek_char ib in if ib.eof then raise End_of_file; - c;; + c +;; let end_of_input ib = ignore (peek_char ib); - ib.eof;; + ib.eof +;; let eof ib = ib.eof;; let beginning_of_input ib = ib.char_count = 0;; let name_of_input ib = ib.file_name;; -let char_count ib = ib.char_count;; +let char_count ib = + if ib.current_char_is_valid then ib.char_count - 1 else ib.char_count +;; let line_count ib = ib.line_count;; let reset_token ib = Buffer.reset ib.tokbuf;; let invalidate_current_char ib = ib.current_char_is_valid <- false;; @@ -174,19 +181,22 @@ let token ib = let tok = Buffer.contents tokbuf in Buffer.clear tokbuf; ib.token_count <- succ ib.token_count; - tok;; + tok +;; let token_count ib = ib.token_count;; let skip_char ib max = invalidate_current_char ib; - max;; + max +;; let ignore_char ib max = skip_char ib (max - 1);; let store_char ib c max = Buffer.add_char ib.tokbuf c; - ignore_char ib max;; + ignore_char ib max +;; let default_token_buffer_size = 1024;; @@ -200,7 +210,8 @@ let create fname next = { get_next_char = next; tokbuf = Buffer.create default_token_buffer_size; file_name = fname; -};; +} +;; let from_string s = let i = ref 0 in @@ -210,57 +221,75 @@ let from_string s = let c = s.[!i] in incr i; c in - create "string input" next;; + create "string input" next +;; let from_function = create "function input";; -(* Scan from an input channel. *) - -(* The input channel [ic] may not be allocated in this library, hence it may be +(* Scanning from an input channel. *) + +(* Position of the problem: + + We cannot prevent the scanning mechanism to use one lookahead character, + if needed by the semantics of the format string specifications (e.g. a + trailing ``skip space'' specification in the format string); in this case, + the mandatory lookahead character is indeed read from the input and not + used to return the token read. It is thus mandatory to be able to store + an unused lookahead character somewhere to get it as the first character + of the next scan. + + To circumvent this problem, all the scanning functions get a low level + input buffer argument where they store the lookahead character when + needed; additionnaly, the input buffer is the only source of character of + a scanner. The [scanbuf] input buffers are defined in module {!Scanning}. + + Now we understand that it is extremely important that related successive + calls to scanners inded read from the same input buffer. In effect, if a + scanner [scan1] is reading from [ib1] and stores an unused lookahead + character [c1] into its input buffer [ib1], then another scanner [scan2] + not reading from the same buffer [ib1] will miss the character [c], + seemingly vanished in the air from the point of view of [scan2]. + + This mechanism works perfectly to read from strings, from files, and from + functions, since in those cases, allocating two buffers reading from the + same source is unnatural. + + Still, there is a difficulty in the case of scanning from an input + channel. In effect, when scanning from an input channel [ic], this channel + may not have been allocated from within this library. Hence, it may be shared (two functions of the user's program may successively read from - it). Furthermore, the user may define more than one scanning buffer reading - from the same [ic] channel. - - However, we cannot prevent the scanning mechanism to use one lookahead - character, if needed by the semantics of format string specifications - (e.g. a trailing ``skip space'' specification in the format string); in this - case, the mandatory lookahead character is read from the channel and stored - into the scanning buffer for further reading. This implies that multiple - functions alternatively scanning the same [ic] channel will miss characters - from time to time, due to unnoticed look ahead characters, silently read - from [ic] (hence no more available for reading) and retained inside the - scanning buffer to ensure the correct incremental scanning of the same - scanning buffer. This phenomenon is even worse if one defines more than one - scanning buffer reading from the same input channel [ic]. We have no simple - way to circumvent this problem (unless the scanning buffer allocation is a - memo function that never allocates two different scanning buffers for the - same input channel, orelse the input channel API offers a ``consider this - char as unread'' procedure to keep back the lookahead character as available - in the input channel for further reading). - - Hence, we do bufferize characters to create a scanning buffer from an input - channel in order to preserve the same semantics as other from_* functions - above: two successive calls to the scanner will work appropriately, since - the bufferized character (if any) will be retained inside the scanning - buffer from a call to the next one. - - Otherwise, if we do not bufferize characters, we will loose the clearly - correct scanning behaviour even for the simple regular case, when we scan - the (possibly shared) channel [ic] using a unique function, while not - gaining anything for multiple functions reading from [ic] or multiple - allocation of scanning buffers reading from the same [ic]. + [ic]). This is highly error prone since, one of the function may seek the + input channel, while the other function has still an unused lookahead + character in its input buffer. In conclusion, you should never mixt direct + low level reading and high level scanning from the same input channel. + + This phenomenon of reading mess is even worse when one defines more than + one scanning buffer reading from the same input channel + [ic]. Unfortunately, we have no simple way to get rid of this problem + (unless the basic input channel API is modified to offer a ``consider this + char as unread'' procedure to keep back the unused lookahead character as + available in the input channel for further reading). + + To prevent some of the confusion the scanning buffer allocation function + is a memo function that never allocates two different scanning buffers for + the same input channel. This way, the user can naively perform successive + call to [fscanf] below, without allocating a new scanning buffer at each + invocation and hence preserving the expected semantics. As mentioned above, a more ambitious fix could be to change the input - channel API or to have a memo scanning buffer allocation for reading from - input channel not allocated from within Scanf's input buffer creation - functions. *) + channel API to allow arbitrary mixing of direct and formatted reading from + input channels. *) (* Perform bufferized input to improve efficiency. *) let file_buffer_size = ref 1024;; -(* To close a channel at end of input. *) +(* The scanner closes the input channel at end of input. *) let scan_close_at_end ic = close_in ic; raise End_of_file;; +(* The scanner does not close the input channel at end of input: + it just raises [End_of_file]. *) +let scan_raise_at_end _ic = raise End_of_file;; + let from_ic scan_close_ic fname ic = let len = !file_buffer_size in let buf = String.create len in @@ -276,41 +305,53 @@ let from_ic scan_close_ic fname ic = buf.[0] end end in - create fname next;; + create fname next +;; let from_ic_close_at_end = from_ic scan_close_at_end;; let from_file fname = from_ic_close_at_end fname (open_in fname);; let from_file_bin fname = from_ic_close_at_end fname (open_in_bin fname);; -let scan_raise_at_end ic = raise End_of_file;; - -let from_channel = from_ic scan_raise_at_end "input channel";; - (* The scanning buffer reading from [stdin]. - One could try to define stdib as a scanning buffer reading a character at a + One could try to define [stdib] as a scanning buffer reading a character at a time (no bufferization at all), but unfortunately the toplevel interaction would be wrong. - This is due to some kind of ``race condition'' when reading from stdin, - since the interactive compiler and scanf will simultaneously read the - material they need from stdin; then, confusion will result from what should - be read by the toplevel and what should be read by scanf. - This is even more complicated by the one character lookahead that scanf + This is due to some kind of ``race condition'' when reading from [stdin], + since the interactive compiler and [scanf] will simultaneously read the + material they need from [stdin]; then, confusion will result from what should + be read by the toplevel and what should be read by [scanf]. + This is even more complicated by the one character lookahead that [scanf] is sometimes obliged to maintain: the lookahead character will be available - for the next (scanf) entry, seamingly coming from nowhere. - Also no End_of_file is raised when reading from stdin: if not enough + for the next ([scanf]) entry, seamingly coming from nowhere. + Also no [End_of_file] is raised when reading from stdin: if not enough characters have been read, we simply ask to read more. *) let stdib = from_ic scan_raise_at_end "stdin" stdin;; -end;; +let memo_from_ic = + let memo = ref [] in + (fun scan_close_ic fname ic -> + try List.assq ic !memo with + | Not_found -> + let ib = from_ic scan_close_ic fname ic in + memo := (ic, ib) :: !memo; + ib) +;; + +let from_channel = memo_from_ic scan_raise_at_end "input channel";; + +end +;; (* Formatted input functions. *) type ('a, 'b, 'c, 'd) scanner = - ('a, Scanning.scanbuf, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c;; + ('a, Scanning.scanbuf, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c +;; external string_to_format : - string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity";; + string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" +;; (* Reporting errors. *) exception Scan_failure of string;; @@ -319,13 +360,8 @@ let bad_input s = raise (Scan_failure s);; let bad_input_char c = bad_input (String.make 1 c);; let bad_input_escape c = - bad_input (Printf.sprintf "illegal escape character %C" c);; - -let scanf_bad_input ib = function - | Scan_failure s | Failure s -> - let i = Scanning.char_count ib in - bad_input (Printf.sprintf "scanf: bad input at char number %i: %s" i s) - | x -> raise x;; + bad_input (Printf.sprintf "illegal escape character %C" c) +;; module Sformat = Printf.CamlinternalPr.Sformat;; module Tformat = Printf.CamlinternalPr.Tformat;; @@ -334,23 +370,35 @@ let bad_conversion fmt i c = invalid_arg (Printf.sprintf "scanf: bad conversion %%%c, at char number %i \ - in format string ``%s''" c i (Sformat.to_string fmt));; + in format string ``%s''" c i (Sformat.to_string fmt)) +;; let incomplete_format fmt = invalid_arg (Printf.sprintf "scanf: premature end of format string ``%s''" - (Sformat.to_string fmt));; + (Sformat.to_string fmt)) +;; + +let bad_float () = bad_input "no dot or exponent part found in +float token" +;; + +let character_mismatch_err c ci = + Printf.sprintf "looking for %C, found %C" c ci +;; -let bad_float () = bad_input "no dot or exponent part found in float token";; +let character_mismatch c ci = + bad_input (character_mismatch_err c ci) +;; let format_mismatch_err fmt1 fmt2 = Printf.sprintf - "format read ``%s'' does not match specification ``%s''" fmt1 fmt2;; + "format read ``%s'' does not match specification ``%s''" fmt1 fmt2 +;; -let format_mismatch fmt1 fmt2 ib = - scanf_bad_input ib (Scan_failure (format_mismatch_err fmt1 fmt2));; +let format_mismatch fmt1 fmt2 = bad_input (format_mismatch_err fmt1 fmt2);; -(* Checking that 2 format string are type compatible. *) +(* Checking that 2 format strings are type compatible. *) let compatible_format_type fmt1 fmt2 = Tformat.summarize_format_type (string_to_format fmt1) = Tformat.summarize_format_type (string_to_format fmt2);; @@ -362,9 +410,9 @@ let compatible_format_type fmt1 fmt2 = That's why we use checked_peek_char here. *) let check_char ib c = let ci = Scanning.checked_peek_char ib in - if ci != c then - bad_input (Printf.sprintf "looking for %C, found %C" c ci) else - Scanning.invalidate_current_char ib;; + if ci = c then Scanning.invalidate_current_char ib else + character_mismatch c ci +;; (* Checks that the current char is indeed one of the stopper characters, then skips it. @@ -377,7 +425,8 @@ let ignore_stoppers stps ib = if List.memq ci stps then Scanning.invalidate_current_char ib else let sr = String.concat "" (List.map (String.make 1) stps) in bad_input - (Printf.sprintf "looking for one of range %S, found %C" sr ci);; + (Printf.sprintf "looking for one of range %S, found %C" sr ci) +;; (* Extracting tokens from ouput token buffer. *) @@ -403,26 +452,31 @@ let token_int_literal conv ib = | 'b' -> "0b" ^ Scanning.token ib | _ -> assert false in let l = String.length tok in - if l = 0 || tok.[0] <> '+' then tok else String.sub tok 1 (l - 1);; + if l = 0 || tok.[0] <> '+' then tok else String.sub tok 1 (l - 1) +;; (* All the functions that convert a string to a number raise the exception Failure when the conversion is not possible. - This exception is then trapped in kscanf. *) + This exception is then trapped in [kscanf]. *) let token_int conv ib = int_of_string (token_int_literal conv ib);; + let token_float ib = float_of_string (Scanning.token ib);; (* To scan native ints, int32 and int64 integers. We cannot access to conversions to/from strings for those types, Nativeint.of_string, Int32.of_string, and Int64.of_string, - since those modules are not available to Scanf. + since those modules are not available to [Scanf]. However, we can bind and use the corresponding primitives that are available in the runtime. *) external nativeint_of_string : string -> nativeint - = "caml_nativeint_of_string";; + = "caml_nativeint_of_string" +;; external int32_of_string : string -> int32 - = "caml_int32_of_string";; + = "caml_int32_of_string" +;; external int64_of_string : string -> int64 - = "caml_int64_of_string";; + = "caml_int64_of_string" +;; let token_nativeint conv ib = nativeint_of_string (token_int_literal conv ib);; let token_int32 conv ib = int32_of_string (token_int_literal conv ib);; @@ -451,7 +505,8 @@ let rec scan_decimal_digits max ib = | '_' -> let max = Scanning.ignore_char ib max in scan_decimal_digits max ib - | _ -> max;; + | _ -> max +;; let scan_decimal_digits_plus max ib = let c = Scanning.checked_peek_char ib in @@ -459,7 +514,8 @@ let scan_decimal_digits_plus max ib = | '0' .. '9' -> let max = Scanning.store_char ib c max in scan_decimal_digits max ib - | c -> bad_input_char c;; + | c -> bad_input_char c +;; let scan_digits_plus digitp max ib = (* To scan numbers from other bases, we use a predicate argument to @@ -481,23 +537,27 @@ let scan_digits_plus digitp max ib = if digitp c then let max = Scanning.store_char ib c max in scan_digits max - else bad_input_char c;; + else bad_input_char c +;; let is_binary_digit = function | '0' .. '1' -> true - | _ -> false;; + | _ -> false +;; let scan_binary_int = scan_digits_plus is_binary_digit;; let is_octal_digit = function | '0' .. '7' -> true - | _ -> false;; + | _ -> false +;; let scan_octal_int = scan_digits_plus is_octal_digit;; let is_hexa_digit = function | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true - | _ -> false;; + | _ -> false +;; let scan_hexadecimal_int = scan_digits_plus is_hexa_digit;; @@ -509,11 +569,13 @@ let scan_sign max ib = match c with | '+' -> Scanning.store_char ib c max | '-' -> Scanning.store_char ib c max - | c -> max;; + | c -> max +;; let scan_optionally_signed_decimal_int max ib = let max = scan_sign max ib in - scan_unsigned_decimal_int max ib;; + scan_unsigned_decimal_int max ib +;; (* Scan an unsigned integer that could be given in any (common) basis. If digits are prefixed by one of 0x, 0X, 0o, or 0b, the number is @@ -531,11 +593,13 @@ let scan_unsigned_int max ib = | 'o' -> scan_octal_int (Scanning.store_char ib c max) ib | 'b' -> scan_binary_int (Scanning.store_char ib c max) ib | c -> scan_decimal_digits max ib end - | c -> scan_unsigned_decimal_int max ib;; + | c -> scan_unsigned_decimal_int max ib +;; let scan_optionally_signed_int max ib = let max = scan_sign max ib in - scan_unsigned_int max ib;; + scan_unsigned_int max ib +;; let scan_int_conv conv max ib = match conv with @@ -545,7 +609,8 @@ let scan_int_conv conv max ib = | 'o' -> scan_octal_int max ib | 'u' -> scan_unsigned_decimal_int max ib | 'x' | 'X' -> scan_hexadecimal_int max ib - | c -> assert false;; + | c -> assert false +;; (* Scanning floating point numbers. *) (* Fractional part is optional and can be reduced to 0 digits. *) @@ -556,7 +621,8 @@ let scan_frac_part max ib = match c with | '0' .. '9' as c -> scan_decimal_digits (Scanning.store_char ib c max) ib - | _ -> max;; + | _ -> max +;; (* Exp part is optional and can be reduced to 0 digits. *) let scan_exp_part max ib = @@ -566,7 +632,8 @@ let scan_exp_part max ib = match c with | 'e' | 'E' as c -> scan_optionally_signed_decimal_int (Scanning.store_char ib c max) ib - | _ -> max;; + | _ -> max +;; (* Scan the integer part of a floating point number, (not using the Caml lexical convention since the integer part can be empty): @@ -574,7 +641,8 @@ let scan_exp_part max ib = digits (e.g. -.1). *) let scan_int_part max ib = let max = scan_sign max ib in - scan_decimal_digits max ib;; + scan_decimal_digits max ib +;; let scan_float max ib = let max = scan_int_part max ib in @@ -586,7 +654,8 @@ let scan_float max ib = let max = Scanning.store_char ib c max in let max = scan_frac_part max ib in scan_exp_part max ib - | c -> scan_exp_part max ib;; + | c -> scan_exp_part max ib +;; let scan_Float max ib = let max = scan_optionally_signed_decimal_int max ib in @@ -600,7 +669,8 @@ let scan_Float max ib = scan_exp_part max ib | 'e' | 'E' -> scan_exp_part max ib - | c -> bad_float ();; + | c -> bad_float () +;; (* Scan a regular string: stops when encountering a space or one of the characters in stp. It also stops when the maximum number of @@ -610,24 +680,27 @@ let scan_string stp max ib = if max = 0 then max else let c = Scanning.peek_char ib in if Scanning.eof ib then max else - if stp == [] then + if stp = [] then match c with | ' ' | '\t' | '\n' | '\r' -> max | c -> loop (Scanning.store_char ib c max) else if List.memq c stp then Scanning.skip_char ib max else loop (Scanning.store_char ib c max) in - loop max;; + loop max +;; (* Scan a char: peek strictly one character in the input, whatsoever. *) let scan_char max ib = - Scanning.store_char ib (Scanning.checked_peek_char ib) max;; + Scanning.store_char ib (Scanning.checked_peek_char ib) max +;; let char_for_backslash = function | 'n' -> '\010' | 'r' -> '\013' | 'b' -> '\008' | 't' -> '\009' - | c -> c;; + | c -> c +;; (* The integer value corresponding to the facial value of a valid decimal digit character. *) @@ -640,7 +713,8 @@ let char_for_decimal_code c0 c1 c2 = int_value_of_char c2 in if c < 0 || c > 255 then bad_input (Printf.sprintf "bad char \\%c%c%c" c0 c1 c2) - else char_of_int c;; + else char_of_int c +;; (* Called when encountering '\\' as starter of a char. Stops before the corresponding '\''. *) @@ -661,7 +735,8 @@ let scan_backslash_char max ib = let c1 = get_digit () in let c2 = get_digit () in Scanning.store_char ib (char_for_decimal_code c0 c1 c2) (max - 2) - | c -> bad_input_char c;; + | c -> bad_input_char c +;; let scan_Char max ib = let rec loop s max = @@ -669,12 +744,21 @@ let scan_Char max ib = let c = Scanning.checked_peek_char ib in if Scanning.eof ib then bad_input "a char" else match c, s with + (* Looking for the '\'' at the beginning of the delimited char. *) | '\'', 3 -> loop 2 (Scanning.ignore_char ib max) + (* Looking for the '\'' at the end of the delimited char. *) | '\'', 1 -> Scanning.ignore_char ib max + (* Any other char at the beginning or end of the delimited char should be + '\''. *) + | c, (3 | 1) -> character_mismatch '\'' c + (* Found a '\\': check and read this escape char. *) | '\\', 2 -> loop 1 (scan_backslash_char (Scanning.ignore_char ib max) ib) + (* The regular case, remember the char, then look for the terminal '\\'. *) | c, 2 -> loop 1 (Scanning.store_char ib c max) - | c, _ -> bad_input_escape c in - loop 3 max;; + (* Any other case is an error, *) + | c, _ -> bad_input_char c in + loop 3 max +;; let scan_String max ib = let rec loop s max = @@ -701,7 +785,8 @@ let scan_String max ib = | '\\', false -> loop false max | c, false -> loop false (Scanning.store_char ib c max) | _, _ -> loop false (scan_backslash_char (max - 1) ib) in - loop true max;; + loop true max +;; let scan_bool max ib = if max < 4 then bad_input "a boolean" else @@ -712,12 +797,14 @@ let scan_bool max ib = | 't' -> 4 | 'f' -> 5 | _ -> bad_input "a boolean" in - scan_string [] (min max m) ib;; + scan_string [] (min max m) ib +;; (* Reading char sets in %[...] conversions. *) type char_set = | Pos_set of string (* Positive (regular) set. *) - | Neg_set of string (* Negative (complementary) set. *);; + | Neg_set of string (* Negative (complementary) set. *) +;; (* Char sets are read as sub-strings in the format string. *) let read_char_set fmt i = @@ -743,14 +830,16 @@ let read_char_set fmt i = j, Neg_set (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) | _ -> let j = find_set i in - j, Pos_set (Sformat.sub fmt (Sformat.index_of_int i) (j - i));; + j, Pos_set (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) +;; (* Char sets are now represented as bitvects that are represented as byte strings. *) (* Bit manipulations into bytes. *) let set_bit_of_byte byte idx b = - (b lsl idx) lor (byte land (* mask idx *) (lnot (1 lsl idx)));; + (b lsl idx) lor (byte land (* mask idx *) (lnot (1 lsl idx))) +;; let get_bit_of_byte byte idx = (byte lsr idx) land 1;; @@ -759,29 +848,32 @@ let set_bit_of_range r c b = let idx = c land 0x7 in let ydx = c lsr 3 in let byte = r.[ydx] in - r.[ydx] <- char_of_int (set_bit_of_byte (int_of_char byte) idx b);; + r.[ydx] <- char_of_int (set_bit_of_byte (int_of_char byte) idx b) +;; let get_bit_of_range r c = let idx = c land 0x7 in let ydx = c lsr 3 in let byte = r.[ydx] in - get_bit_of_byte (int_of_char byte) idx;; + get_bit_of_byte (int_of_char byte) idx +;; (* Char sets represented as bitvects represented as fixed length byte strings. *) (* Create a full or empty set of chars. *) let make_range bit = let c = char_of_int (if bit = 0 then 0 else 0xFF) in - String.make 32 c;; + String.make 32 c +;; -(* Test is a char belongs to a set of chars. *) +(* Test if a char belongs to a set of chars. *) let get_char_in_range r c = get_bit_of_range r (int_of_char c);; let bit_not b = (lnot b) land 1;; (* Build the bit vector corresponding to the set of characters that belongs to the string argument [set]. - (In the Scanf module [set] is always a sub-string of the format). *) + (In the [Scanf] module [set] is always a sub-string of the format.) *) let make_char_bit_vect bit set = let r = make_range (bit_not bit) in let lim = String.length set - 1 in @@ -802,14 +894,16 @@ let make_char_bit_vect bit set = set_bit_of_range r (int_of_char set.[i]) bit; loop bit true (succ i) in loop bit false 0; - r;; + r +;; (* Compute the predicate on chars corresponding to a char set. *) let make_pred bit set stp = let r = make_char_bit_vect bit set in List.iter (fun c -> set_bit_of_range r (int_of_char c) (bit_not bit)) stp; - (fun c -> get_char_in_range r c);; + (fun c -> get_char_in_range r c) +;; let make_setp stp char_set = match char_set with @@ -842,7 +936,8 @@ let make_setp stp char_set = if p2 = '-' then make_pred 0 set stp else (fun c -> if c != p1 && c != p2 && c != p3 then 1 else 0) | n -> make_pred 0 set stp - end;; + end +;; let setp_table = Hashtbl.create 7;; @@ -853,14 +948,16 @@ let add_setp stp char_set setp = let char_set_tbl = Hashtbl.create 3 in Hashtbl.add setp_table char_set char_set_tbl; char_set_tbl in - Hashtbl.add char_set_tbl stp setp;; + Hashtbl.add char_set_tbl stp setp +;; let find_setp stp char_set = try Hashtbl.find (Hashtbl.find setp_table char_set) stp with | Not_found -> let setp = make_setp stp char_set in add_setp stp char_set setp; - setp;; + setp +;; let scan_chars_in_char_set stp char_set max ib = let rec loop_pos1 cp1 max = @@ -930,13 +1027,15 @@ let scan_chars_in_char_set stp char_set max ib = | 3 when set.[1] != '-' -> loop_neg3 set.[0] set.[1] set.[2] max | n -> loop (find_setp stp char_set) max end in ignore_stoppers stp ib; - max;; + max +;; let get_count t ib = match t with | 'l' -> Scanning.line_count ib | 'n' -> Scanning.char_count ib - | _ -> Scanning.token_count ib;; + | _ -> Scanning.token_count ib +;; let rec skip_whites ib = let c = Scanning.peek_char ib in @@ -945,188 +1044,221 @@ let rec skip_whites ib = | ' ' | '\t' | '\n' | '\r' -> Scanning.invalidate_current_char ib; skip_whites ib | _ -> () - end;; + end +;; let list_iter_i f l = let rec loop i = function | [] -> () | [x] -> f i x (* Tail calling [f] *) | x :: xs -> f i x; loop (succ i) xs in - loop 0 l;; + loop 0 l +;; + +(* The global error report function for [Scanf]. *) +let scanf_bad_input ib = function + | Scan_failure s | Failure s -> + let i = Scanning.char_count ib in + bad_input (Printf.sprintf "scanf: bad input at char number %i: %s" i s) + | x -> raise x +;; -(* The [kscanf] main scanning function. +let ascanf sc fmt = + let ac = Tformat.ac_of_format fmt in + match ac.Tformat.ac_rdrs with + | 0 -> + Obj.magic (fun f -> sc fmt [||] f) + | 1 -> + Obj.magic (fun x f -> sc fmt [| Obj.repr x |] f) + | 2 -> + Obj.magic (fun x y f -> sc fmt [| Obj.repr x; Obj.repr y; |] f) + | 3 -> + Obj.magic + (fun x y z f -> sc fmt [| Obj.repr x; Obj.repr y; Obj.repr z; |] f) + | nargs -> + let rec loop i args = + if i >= nargs then + let a = Array.make nargs (Obj.repr 0) in + list_iter_i (fun i arg -> a.(nargs - i - 1) <- arg) args; + Obj.magic (fun f -> sc fmt a f) + else Obj.magic (fun x -> loop (succ i) (x :: args)) in + loop 0 [] +;; + +(* The [scan_format] main scanning function. It takes as arguments: - an input buffer [ib] from which to read characters, - an error handling function [ef], - a format [fmt] that specifies what to read in the input, + - a vector of user's defined readers rv, - and a function [f] to pass the tokens read to. - Then [kscanf] scans the format and the buffer in parallel to find - out tokens as specified by the format; when it founds one token, it + Then [scan_format] scans the format and the input buffer in parallel to + find out tokens as specified by the format; when it founds one token, it converts it as specified, remembers the converted value as a future argument to the function [f], and continues scanning. If the entire scanning succeeds (i.e. the format string has been exhausted and the buffer has provided tokens according to the - format string), the tokens are applied to [f]. + format string), [f] is applied to the tokens. If the scanning or some conversion fails, the main scanning function aborts and applies the scanning buffer and a string that explains the error to the error handling function [ef] (the error continuation). *) -let ascanf sc fmt = - let ac = Tformat.ac_of_format fmt in - match ac.Tformat.ac_rdrs with - | 0 -> Obj.magic (fun f -> sc fmt [||] f) - | 1 -> Obj.magic (fun x f -> sc fmt [| Obj.repr x |] f) - | 2 -> Obj.magic (fun x y f -> sc fmt [| Obj.repr x; Obj.repr y; |] f) - | 3 -> Obj.magic (fun x y z f -> - sc fmt [| Obj.repr x; Obj.repr y; Obj.repr z; |] f) - | nargs -> - let rec loop i args = - if i >= nargs then - let a = Array.make nargs (Obj.repr 0) in - list_iter_i (fun i arg -> a.(nargs - i - 1) <- arg) args; - Obj.magic (fun f -> sc fmt a f) - else Obj.magic (fun x -> loop (succ i) (x :: args)) in - loop 0 [];; - -let scan_format ib ef fmt v f = + +let scan_format ib ef fmt rv f = let lim = Sformat.length fmt - 1 in - let limr = Array.length v - 1 in + let limr = Array.length rv - 1 in let return v = Obj.magic v () in let delay f x () = f x in let stack f = delay (return f) in let no_stack f x = f in - let rec scan_fmt ir f i = - if i > lim then f else - match Sformat.get fmt i with - | ' ' -> skip_whites ib; scan_fmt ir f (succ i) - | '%' -> - if i > lim then incomplete_format fmt else - scan_conversion false max_int ir f (succ i) - | '@' -> - let i = succ i in - if i > lim then incomplete_format fmt else begin - check_char ib (Sformat.get fmt i); - scan_fmt ir f (succ i) end - | c -> check_char ib c; scan_fmt ir f (succ i) + let rec scan fmt = - and scan_conversion skip max ir f i = - let stack = if skip then no_stack else stack in - match Sformat.get fmt i with - | '%' as conv -> - check_char ib conv; scan_fmt ir f (succ i) - | 's' -> - let i, stp = scan_fmt_stoppers (succ i) in - let _x = scan_string stp max ib in - scan_fmt ir (stack f (token_string ib)) (succ i) - | 'S' -> - let _x = scan_String max ib in - scan_fmt ir (stack f (token_string ib)) (succ i) - | '[' (* ']' *) -> - let i, char_set = read_char_set fmt (succ i) in - let i, stp = scan_fmt_stoppers (succ i) in - let _x = scan_chars_in_char_set stp char_set max ib in - scan_fmt ir (stack f (token_string ib)) (succ i) - | 'c' when max = 0 -> - let c = Scanning.checked_peek_char ib in - scan_fmt ir (stack f c) (succ i) - | 'c' | 'C' as conv -> - if max <> 1 && max <> max_int then bad_conversion fmt i conv else - let _x = - if conv = 'c' then scan_char max ib else scan_Char max ib in - scan_fmt ir (stack f (token_char ib)) (succ i) - | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv -> - let _x = scan_int_conv conv max ib in - scan_fmt ir (stack f (token_int conv ib)) (succ i) - | 'N' as conv -> - scan_fmt ir (stack f (get_count conv ib)) (succ i) - | 'f' | 'e' | 'E' | 'g' | 'G' -> - let _x = scan_float max ib in - scan_fmt ir (stack f (token_float ib)) (succ i) - | 'F' -> - let _x = scan_Float max ib in - scan_fmt ir (stack f (token_float ib)) (succ i) - | 'B' | 'b' -> - let _x = scan_bool max ib in - scan_fmt ir (stack f (token_bool ib)) (succ i) - | 'r' -> - if ir > limr then assert false else - let token = Obj.magic v.(ir) ib in - scan_fmt (succ ir) (stack f token) (succ i) - | 'l' | 'n' | 'L' as conv -> - let i = succ i in - if i > lim then scan_fmt ir (stack f (get_count conv ib)) i else begin + let rec scan_fmt ir f i = + if i > lim then ir, f else + match Sformat.get fmt i with + | ' ' -> skip_whites ib; scan_fmt ir f (succ i) + | '%' -> + if i > lim then incomplete_format fmt else + scan_conversion false max_int ir f (succ i) + | '@' -> + let i = succ i in + if i > lim then incomplete_format fmt else begin + check_char ib (Sformat.get fmt i); + scan_fmt ir f (succ i) end + | c -> check_char ib c; scan_fmt ir f (succ i) + + and scan_conversion skip max ir f i = + let stack = if skip then no_stack else stack in match Sformat.get fmt i with - (* This is in fact an integer conversion (e.g. %ld, %ni, or %Lo). *) + | '%' as conv -> + check_char ib conv; scan_fmt ir f (succ i) + | 's' -> + let i, stp = scan_fmt_stoppers (succ i) in + let _x = scan_string stp max ib in + scan_fmt ir (stack f (token_string ib)) (succ i) + | 'S' -> + let _x = scan_String max ib in + scan_fmt ir (stack f (token_string ib)) (succ i) + | '[' (* ']' *) -> + let i, char_set = read_char_set fmt (succ i) in + let i, stp = scan_fmt_stoppers (succ i) in + let _x = scan_chars_in_char_set stp char_set max ib in + scan_fmt ir (stack f (token_string ib)) (succ i) + | 'c' when max = 0 -> + let c = Scanning.checked_peek_char ib in + scan_fmt ir (stack f c) (succ i) + | 'c' | 'C' as conv -> + if max <> 1 && max <> max_int then bad_conversion fmt i conv else + let _x = + if conv = 'c' then scan_char max ib else scan_Char max ib in + scan_fmt ir (stack f (token_char ib)) (succ i) | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv -> let _x = scan_int_conv conv max ib in - (* Look back to the character that triggered the integer conversion - (this character is either 'l', 'n' or 'L'), to find the - conversion to apply to the integer token read. *) - begin match Sformat.get fmt (i - 1) with - | 'l' -> scan_fmt ir (stack f (token_int32 conv ib)) (succ i) - | 'n' -> scan_fmt ir (stack f (token_nativeint conv ib)) (succ i) - | _ -> scan_fmt ir (stack f (token_int64 conv ib)) (succ i) end - (* This is not an integer conversion, but a regular %l, %n or %L. *) - | _ -> scan_fmt ir (stack f (get_count conv ib)) i end - | '!' -> - if Scanning.end_of_input ib then scan_fmt ir f (succ i) - else bad_input "end of input not found" - | '_' -> - if i > lim then incomplete_format fmt else - scan_conversion true max ir f (succ i) - | '0' .. '9' as conv -> - let rec read_width accu i = - if i > lim then accu, i else + scan_fmt ir (stack f (token_int conv ib)) (succ i) + | 'N' as conv -> + scan_fmt ir (stack f (get_count conv ib)) (succ i) + | 'f' | 'e' | 'E' | 'g' | 'G' -> + let _x = scan_float max ib in + scan_fmt ir (stack f (token_float ib)) (succ i) + | 'F' -> + let _x = scan_Float max ib in + scan_fmt ir (stack f (token_float ib)) (succ i) + | 'B' | 'b' -> + let _x = scan_bool max ib in + scan_fmt ir (stack f (token_bool ib)) (succ i) + | 'r' -> + if ir > limr then assert false else + let token = Obj.magic rv.(ir) ib in + scan_fmt (succ ir) (stack f token) (succ i) + | 'l' | 'n' | 'L' as conv -> + let i = succ i in + if i > lim then scan_fmt ir (stack f (get_count conv ib)) i else begin + match Sformat.get fmt i with + (* This is in fact an integer conversion (e.g. %ld, %ni, or %Lo). *) + | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv -> + let _x = scan_int_conv conv max ib in + (* Look back to the character that triggered the integer conversion + (this character is either 'l', 'n' or 'L'), to find the + conversion to apply to the integer token read. *) + begin match Sformat.get fmt (i - 1) with + | 'l' -> scan_fmt ir (stack f (token_int32 conv ib)) (succ i) + | 'n' -> scan_fmt ir (stack f (token_nativeint conv ib)) (succ i) + | _ -> scan_fmt ir (stack f (token_int64 conv ib)) (succ i) end + (* This is not an integer conversion, but a regular %l, %n or %L. *) + | _ -> scan_fmt ir (stack f (get_count conv ib)) i end + | '!' -> + if Scanning.end_of_input ib then scan_fmt ir f (succ i) + else bad_input "end of input not found" + | '_' -> + if i > lim then incomplete_format fmt else + scan_conversion true max ir f (succ i) + | '0' .. '9' as conv -> + let rec read_width accu i = + if i > lim then accu, i else + match Sformat.get fmt i with + | '0' .. '9' as c -> + let accu = 10 * accu + int_value_of_char c in + read_width accu (succ i) + | _ -> accu, i in + let max, i = read_width (int_value_of_char conv) (succ i) in + if i > lim then incomplete_format fmt else begin match Sformat.get fmt i with - | '0' .. '9' as c -> - let accu = 10 * accu + int_value_of_char c in - read_width accu (succ i) - | _ -> accu, i in - let max, i = read_width (int_value_of_char conv) (succ i) in - if i > lim then incomplete_format fmt else begin + | '.' -> + let p, i = read_width 0 (succ i) in + scan_conversion skip (succ (max + p)) ir f i + | _ -> scan_conversion skip max ir f i end + | '(' | '{' as conv (* ')' '}' *) -> + let i = succ i in + (* Find the static specification for the format to read. *) + let j = + Tformat.sub_format + incomplete_format bad_conversion conv fmt i in + let mf = Sformat.sub fmt (Sformat.index_of_int i) (j - 2 - i) in + (* Read the specified format string in the input buffer, + and check its correctness. *) + let _x = scan_String max ib in + let rf = token_string ib in + if not (compatible_format_type rf mf) then format_mismatch rf mf else + (* For conversion %{%}, just return this format string as the token + read. *) + if conv = '{' (* '}' *) then scan_fmt ir (stack f rf) j else + (* Or else, read according to the format string just read. *) + let ir, nf = scan (Obj.magic rf) ir (stack f rf) 0 in + (* Return the format string read and the value just read, + then go on with the rest of the format. *) + scan_fmt ir nf j + + | c -> bad_conversion fmt i c + + and scan_fmt_stoppers i = + if i > lim then i - 1, [] else match Sformat.get fmt i with - | '.' -> - let p, i = read_width 0 (succ i) in - scan_conversion skip (succ (max + p)) ir f i - | _ -> scan_conversion skip max ir f i end - | '(' | '{' as conv (* ')' '}' *) -> - let i = succ i in - let j = - Tformat.sub_format - incomplete_format bad_conversion conv fmt i in - let mf = Sformat.sub fmt (Sformat.index_of_int i) (j - 2 - i) in - let _x = scan_String max ib in - let rf = token_string ib in - if not (compatible_format_type rf mf) then format_mismatch rf mf ib else - if conv = '{' (* '}' *) then scan_fmt ir (stack f rf) j else - let nf = scan_fmt ir (Obj.magic rf) 0 in - scan_fmt ir (stack f nf) j - | c -> bad_conversion fmt i c - - and scan_fmt_stoppers i = - if i > lim then i - 1, [] else - match Sformat.get fmt i with - | '@' when i < lim -> let i = succ i in i, [Sformat.get fmt i] - | '@' when i = lim -> incomplete_format fmt - | _ -> i - 1, [] in + | '@' when i < lim -> let i = succ i in i, [Sformat.get fmt i] + | '@' when i = lim -> incomplete_format fmt + | _ -> i - 1, [] in + + scan_fmt in + Scanning.reset_token ib; let v = - try scan_fmt 0 (fun () -> f) 0 with + try snd (scan fmt 0 (fun () -> f) 0) with | (Scan_failure _ | Failure _ | End_of_file) as exc -> stack (delay ef ib) exc in - return v;; + return v +;; let mkscanf ib ef fmt = let sc = scan_format ib ef in - ascanf sc fmt;; + ascanf sc fmt +;; let kscanf ib ef fmt = mkscanf ib ef fmt;; @@ -1142,8 +1274,9 @@ let bscanf_format ib fmt f = let fmt = Sformat.unsafe_to_string fmt in let fmt1 = ignore (scan_String max_int ib); token_string ib in if not (compatible_format_type fmt1 fmt) then - format_mismatch fmt1 fmt ib else - f (string_to_format fmt1);; + format_mismatch fmt1 fmt else + f (string_to_format fmt1) +;; let sscanf_format s fmt f = bscanf_format (Scanning.from_string s) fmt f;; @@ -1152,7 +1285,9 @@ let quote_string s = Buffer.add_char b '\"'; Buffer.add_string b s; Buffer.add_char b '\"'; - Buffer.contents b;; + Buffer.contents b +;; let format_from_string s fmt = - sscanf_format (quote_string s) fmt (fun x -> x);; + sscanf_format (quote_string s) fmt (fun x -> x) +;; diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli index d0f6ae8447..f3049f91eb 100644 --- a/stdlib/scanf.mli +++ b/stdlib/scanf.mli @@ -15,40 +15,67 @@ (** Formatted input functions. *) -(** {6 Functional input with format strings.} *) - -(** The formatted input functions provided by module [Scanf] are functionals - that apply their function argument to the values they read in the input. - The specification of the values to read is simply given by a format string - (the same format strings as those used to print material using module - {!Printf} or module {!Format}). - - As an example, consider the formatted input function [scanf] that reads - from standard input; a typical call to [scanf] is simply [scanf fmt f], - meaning that [f] should be applied to the arguments read according to the - format string [fmt]. For instance, if [f] is defined as [let f x = x + 1], - then [scanf "%d" f] will read a decimal integer [i] from [stdin] and return - [f i]; thus, if we enter [41] at the keyboard, [scanf "%d" f] evaluates to - [42]. - - This module provides general formatted input functions that read from any - kind of input, including strings, files, or anything that can return - characters. - Hence, a typical call to a formatted input function [bscan] is - [bscan ib fmt f], meaning that [f] should be applied to the arguments - read from input [ib], according to the format string [fmt]. - - The Caml scanning facility is reminiscent of the corresponding C feature. - However, it is also largely different, simpler, and yet more powerful: the - formatted input functions are higher-order functionals and the parameter - passing mechanism is simply the regular function application not the - variable assigment based mechanism which is typical of formatted input in - imperative languages; the format strings also feature useful additions to - easily define complex tokens; as expected of a functional programming - language feature, the formatted input functions support polymorphism, in - particular arbitrary interaction with polymorphic user-defined scanners. - Furthermore, the Caml formatted input facility is fully type-checked at - compile time. *) +(** {6 Introduction} *) + +(** {7 Functional input with format strings} *) + +(** The module [Scanf] provides formatted input functions or {e scanners}. + + The formatted input functions can read from any kind of input, including + strings, files, or anything that can return characters. The more general + source of characters is named a {e scanning buffer} and has type + {!Scanning.scanbuf}. The more general formatted input function reads from + any scanning buffer and is named [bscanf]. + + Generally speaking, the formatted input functions have 3 arguments: + - the first argument is a source of characters for the input, + - the second argument is a format string that specifies the values to + read, + - the third argument is a {e receiver function} that is applied to the + values read. + + Hence, a typical call to the formatted input function {!Scanf.bscanf} is + [bscanf ib fmt f], where: + + - [ib] is a source of characters (typically a {e + scanning buffer} with type {!Scanning.scanbuf}), + + - [fmt] is a format string (the same format strings as those used to print + material with module {!Printf} or {!Format}), + + - [f] is a function that has as many arguments as the number of values to + read in the input. *) + +(** {7 A simple example} *) + +(** As suggested above, the expression [bscanf ib "%d" f] reads a decimal + integer [n] from the source of characters [ib] and returns [f n]. + + For instance, + + - if we use [stdib] as the source of characters ({!Scanning.stdib} is + the predefined input buffer that reads from standard input), + + - if we define the receiver [f] as [let f x = x + 1], + + then [bscanf stdib "%d" f] reads an integer [n] from the standard input + and returns [f n] (that is [n + 1]). Thus, if we evaluate [bscanf stdib + "%d" f], and then enter [41] at the keyboard, we get [42] as the final + result. *) + +(** {7 Formatted input as a functional feature} *) + +(** The Caml scanning facility is reminiscent of the corresponding C feature. + However, it is also largely different, simpler, and yet more powerful: + the formatted input functions are higher-order functionals and the + parameter passing mechanism is just the regular function application not + the variable assigment based mechanism which is typical for formatted + input in imperative languages; the Caml format strings also feature + useful additions to easily define complex tokens; as expected within a + functional programming language, the formatted input functions also + support polymorphism, in particular arbitrary interaction with + polymorphic user-defined scanners. Furthermore, the Caml formatted input + facility is fully type-checked at compile time. *) (** {6 Scanning buffers} *) module Scanning : sig @@ -100,9 +127,8 @@ val from_function : (unit -> char) -> scanbuf;; end-of-input condition by raising the exception [End_of_file]. *) val from_channel : in_channel -> scanbuf;; -(** [Scanning.from_channel ic] returns a scanning buffer which reads - one character at a time from the input channel [ic], starting at the - current reading position. *) +(** [Scanning.from_channel ic] returns a scanning buffer which reads from the + input channel [ic], starting at the current reading position. *) val end_of_input : scanbuf -> bool;; (** [Scanning.end_of_input ib] tests the end-of-input condition of the given @@ -118,9 +144,7 @@ val name_of_input : scanbuf -> string;; end;; -exception Scan_failure of string;; -(** The exception raised by formatted input functions when the input cannot be - read according to the given format. *) +(** {6 Type of formatted input functions} *) type ('a, 'b, 'c, 'd) scanner = ('a, Scanning.scanbuf, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c;; @@ -129,7 +153,7 @@ type ('a, 'b, 'c, 'd) scanner = according to some format string; more precisely, if [scan] is some formatted input function, then [scan ib fmt f] applies [f] to the arguments specified by the format string [fmt], when [scan] has read those arguments - from some scanning buffer [ib]. + from the scanning input buffer [ib]. For instance, the [scanf] function below has type [('a, 'b, 'c, 'd) scanner], since it is a formatted input function that reads from [stdib]: @@ -137,185 +161,220 @@ type ('a, 'b, 'c, 'd) scanner = those arguments from [stdin] as expected. If the format [fmt] has some [%r] indications, the corresponding input - functions must be provided before the [f] argument. For instance, if - [read_elem] is an input function for values of type [t], then [bscanf ib - "%r;" read_elem f] reads a value of type [t] followed by a [';'] - character. *) + functions must be provided before the receiver [f] argument. For + instance, if [read_elem] is an input function for values of type [t], + then [bscanf ib "%r;" read_elem f] reads a value [v] of type [t] followed + by a [';'] character, and returns [f v]. *) -(** {6 Formatted input functions} *) +exception Scan_failure of string;; +(** The exception that formatted input functions raise when the input cannot be + read according to the given format. *) + +(** {6 The general formatted input function} *) val bscanf : Scanning.scanbuf -> ('a, 'b, 'c, 'd) scanner;; -(** [bscanf ib fmt r1 ... rN f] reads arguments for the function [f] from the - scanning buffer [ib] according to the format string [fmt], and applies [f] - to these values. - The result of this call to [f] is returned as the result of [bscanf]. - For instance, if [f] is the function [fun s i -> i + 1], then - [Scanf.sscanf "x = 1" "%s = %i" f] returns [2]. - - Arguments [r1] to [rN] are user-defined input functions that read the - argument corresponding to a [%r] conversion. - - The format is a character string which contains three types of - objects: - - plain characters, which are simply matched with the characters of the - input, - - conversion specifications, each of which causes reading and conversion of - one argument for [f], - - scanning indications to specify boundaries of tokens. - - Among plain characters the space character (ASCII code 32) has a - special meaning: it matches ``whitespace'', that is any number of tab, - space, line feed and carriage return characters. Hence, a space in the format - matches any amount of whitespace in the input. - - Conversion specifications consist in the [%] character, followed by - an optional flag, an optional field width, and followed by one or - two conversion characters. The conversion characters and their - meanings are: - - - [d]: reads an optionally signed decimal integer. - - [i]: reads an optionally signed integer - (usual input formats for hexadecimal ([0x[d]+] and [0X[d]+]), - octal ([0o[d]+]), and binary [0b[d]+] notations are understood). - - [u]: reads an unsigned decimal integer. - - [x] or [X]: reads an unsigned hexadecimal integer. - - [o]: reads an unsigned octal integer. - - [s]: reads a string argument that spreads as much as possible, - until the next white space, the next scanning indication, or the - end-of-input is reached. Hence, this conversion always succeeds: - it returns an empty string if the bounding condition holds - when the scan begins. - - [S]: reads a delimited string argument (delimiters and special - escaped characters follow the lexical conventions of Caml). - - [c]: reads a single character. To test the current input character - without reading it, specify a null field width, i.e. use - specification [%0c]. Raise [Invalid_argument], if the field width - specification is greater than 1. - - [C]: reads a single delimited character (delimiters and special - escaped characters follow the lexical conventions of Caml). - - [f], [e], [E], [g], [G]: reads an optionally signed - floating-point number in decimal notation, in the style [dddd.ddd - e/E+-dd]. - - [F]: reads a floating point number according to the lexical - conventions of Caml (hence the decimal point is mandatory if the - exponent part is not mentioned). - - [B]: reads a boolean argument ([true] or [false]). - - [b]: reads a boolean argument (for backward compatibility; do not use - in new programs). - - [ld], [li], [lu], [lx], [lX], [lo]: reads an [int32] argument to - the format specified by the second letter (decimal, hexadecimal, etc). - - [nd], [ni], [nu], [nx], [nX], [no]: reads a [nativeint] argument to - the format specified by the second letter. - - [Ld], [Li], [Lu], [Lx], [LX], [Lo]: reads an [int64] argument to - the format specified by the second letter. - - [\[ range \]]: reads characters that matches one of the characters - mentioned in the range of characters [range] (or not mentioned in - it, if the range starts with [^]). Reads a [string] that can be - empty, if the next input character does not match the range. The set of - characters from [c1] to [c2] (inclusively) is denoted by [c1-c2]. - Hence, [%\[0-9\]] returns a string representing a decimal number - or an empty string if no decimal digit is found; similarly, - [%\[\\048-\\057\\065-\\070\]] returns a string of hexadecimal digits. - If a closing bracket appears in a range, it must occur as the - first character of the range (or just after the [^] in case of - range negation); hence [\[\]\]] matches a [\]] character and - [\[^\]\]] matches any character that is not [\]]. - - [r]: user-defined reader. Takes the next [ri] formatted input function and - applies it to the scanning buffer [ib] to read the next argument. The - input function [ri] must therefore have type [Scanning.scanbuf -> 'a] and - the argument read has type ['a]. - - [\{ fmt %\}]: reads a format string argument to the format - specified by the internal format [fmt]. The format string to be - read must have the same type as the internal format [fmt]. - For instance, "%\{%i%\}" reads any format string that can read a value of - type [int]; hence [Scanf.sscanf "fmt:\\\"number is %u\\\"" "fmt:%\{%i%\}"] - succeeds and returns the format string ["number is %u"]. - - [\( fmt %\)]: scanning format substitution. - Reads a format string to replace [fmt]. The format string read - must have the same type as [fmt]. - - [l]: returns the number of lines read so far. - - [n]: returns the number of characters read so far. - - [N] or [L]: returns the number of tokens read so far. - - [!]: matches the end of input condition. - - [%]: matches one [%] character in the input. - - Following the [%] character that introduces a conversion, there may be - the special flag [_]: the conversion that follows occurs as usual, - but the resulting value is discarded. - For instance, if [f] is the function [fun i -> i + 1], then - [Scanf.sscanf "x = 1" "%_s = %i" f] returns [2]. - - The field width is composed of an optional integer literal - indicating the maximal width of the token to read. - For instance, [%6d] reads an integer, having at most 6 decimal digits; - [%4f] reads a float with at most 4 characters; and [%8\[\\000-\\255\]] - returns the next 8 characters (or all the characters still available, - if fewer than 8 characters are available in the input). - - Scanning indications appear just after the string conversions [%s] - and [%\[ range \]] to delimit the end of the token. A scanning - indication is introduced by a [@] character, followed by some - constant character [c]. It means that the string token should end - just before the next matching [c] (which is skipped). If no [c] - character is encountered, the string token spreads as much as - possible. For instance, ["%s@\t"] reads a string up to the next - tab character or to the end of input. If a scanning - indication [\@c] does not follow a string conversion, it is treated - as a plain [c] character. - - Raise [Scanf.Scan_failure] if the input does not match the format. - - Raise [Failure] if a conversion to a number is not possible. - - Raise [End_of_file] if the end of input is encountered while some more - characters are needed to read the current conversion specification. - As a consequence, scanning a [%s] conversion never raises exception - [End_of_file]: if the end of input is reached the conversion succeeds and - simply returns the characters read so far, or [""] if none were read. - - Raise [Invalid_argument] if the format string is invalid. - - Notes: - - - the scanning indications introduce slight differences in the - syntax of [Scanf] format strings compared to those used by the - [Printf] module. However, scanning indications are similar to those - of the [Format] module; hence, when producing formatted text to be - scanned by [!Scanf.bscanf], it is wise to use printing functions - from [Format] (or, if you need to use functions from [Printf], - banish or carefully double check the format strings that contain - ['\@'] characters). - - - in addition to relevant digits, ['_'] characters may appear - inside numbers (this is reminiscent to the usual Caml lexical - conventions). If stricter scanning is desired, use the range - conversion facility instead of the number conversions. - - - the [scanf] facility is not intended for heavy duty lexical - analysis and parsing. If it appears not expressive enough for your - needs, several alternative exists: regular expressions (module - [Str]), stream parsers, [ocamllex]-generated lexers, - [ocamlyacc]-generated parsers. -*) +(** [bscanf ib fmt r1 ... rN f] reads arguments for the function [f], from the + scanning buffer [ib], according to the format string [fmt], and applies [f] + to these values. + The result of this call to [f] is returned as the result of the entire + [bscanf] call. + For instance, if [f] is the function [fun s i -> i + 1], then + [Scanf.sscanf "x= 1" "%s = %i" f] returns [2]. + + Arguments [r1] to [rN] are user-defined input functions that read the + argument corresponding to a [%r] conversion. *) + +(** {6 Format string description} *) + +(** The format is a character string which contains three types of + objects: + - plain characters, which are simply matched with the characters of the + input, + - conversion specifications, each of which causes reading and conversion of + one argument for the function [f], + - scanning indications to specify boundaries of tokens. *) + +(** {7 The space character in format strings} *) + +(** As mentioned above, a plain character in the format string is just + matched with the characters of the input; however, one character is a + special exception to this simple rule: the space character (ASCII code + 32) does not match a single space character, but any amount of + ``whitespace'' in the input. More precisely, a space inside the format + string matches {e any number} of tab, space, line feed and carriage + return characters. + + Matching {e any} amount of whitespace, a space in the format string + also matches no amount of whitespace at all; hence, the call [bscanf ib + "Price = %d $" (fun p -> p)] succeds and returns [1] when reading an + input with various whitespace in it, such as [Price = 1 $], + [Price = 1 $], or even [Price=1$]. *) + +(** {7 Conversion specifications in format strings} *) + +(** Conversion specifications consist in the [%] character, followed by + an optional flag, an optional field width, and followed by one or + two conversion characters. The conversion characters and their + meanings are: + + - [d]: reads an optionally signed decimal integer. + - [i]: reads an optionally signed integer + (usual input formats for hexadecimal ([0x[d]+] and [0X[d]+]), + octal ([0o[d]+]), and binary [0b[d]+] notations are understood). + - [u]: reads an unsigned decimal integer. + - [x] or [X]: reads an unsigned hexadecimal integer. + - [o]: reads an unsigned octal integer. + - [s]: reads a string argument that spreads as much as possible, until the + following bounding condition holds: a whitespace has been found, a + scanning indication has been encountered, or the end-of-input has been + reached. + Hence, this conversion always succeeds: it returns an empty + string, if the bounding condition holds when the scan begins. + - [S]: reads a delimited string argument (delimiters and special + escaped characters follow the lexical conventions of Caml). + - [c]: reads a single character. To test the current input character + without reading it, specify a null field width, i.e. use + specification [%0c]. Raise [Invalid_argument], if the field width + specification is greater than 1. + - [C]: reads a single delimited character (delimiters and special + escaped characters follow the lexical conventions of Caml). + - [f], [e], [E], [g], [G]: reads an optionally signed + floating-point number in decimal notation, in the style [dddd.ddd + e/E+-dd]. + - [F]: reads a floating point number according to the lexical + conventions of Caml (hence the decimal point is mandatory if the + exponent part is not mentioned). + - [B]: reads a boolean argument ([true] or [false]). + - [b]: reads a boolean argument (for backward compatibility; do not use + in new programs). + - [ld], [li], [lu], [lx], [lX], [lo]: reads an [int32] argument to + the format specified by the second letter (decimal, hexadecimal, etc). + - [nd], [ni], [nu], [nx], [nX], [no]: reads a [nativeint] argument to + the format specified by the second letter. + - [Ld], [Li], [Lu], [Lx], [LX], [Lo]: reads an [int64] argument to + the format specified by the second letter. + - [\[ range \]]: reads characters that matches one of the characters + mentioned in the range of characters [range] (or not mentioned in + it, if the range starts with [^]). Reads a [string] that can be + empty, if the next input character does not match the range. The set of + characters from [c1] to [c2] (inclusively) is denoted by [c1-c2]. + Hence, [%\[0-9\]] returns a string representing a decimal number + or an empty string if no decimal digit is found; similarly, + [%\[\\048-\\057\\065-\\070\]] returns a string of hexadecimal digits. + If a closing bracket appears in a range, it must occur as the + first character of the range (or just after the [^] in case of + range negation); hence [\[\]\]] matches a [\]] character and + [\[^\]\]] matches any character that is not [\]]. + - [r]: user-defined reader. Takes the next [ri] formatted input function and + applies it to the scanning buffer [ib] to read the next argument. The + input function [ri] must therefore have type [Scanning.scanbuf -> 'a] and + the argument read has type ['a]. + - [\{ fmt %\}]: reads a format string argument. + The format string read must have the same type as the format string + specification [fmt]. + For instance, ["%\{%i%\}"] reads any format string that can read a value of + type [int]; hence [Scanf.sscanf "fmt:\\\"number is %u\\\"" "fmt:%\{%i%\}"] + succeeds and returns the format string ["number is %u"]. + - [\( fmt %\)]: scanning format substitution. + Reads a format string to replace [fmt]. + The format string read must have the same type as the format string + specification [fmt]. + For instance, ["%\( %i% \)"] reads any format string that can read a value + of type [int]; hence [Scanf.sscanf "\\\"%4d\\\"1234.00" "%\(%i%\)"] + is equivalent to [Scanf.sscanf "1234.00" "%4d"]. + - [l]: returns the number of lines read so far. + - [n]: returns the number of characters read so far. + - [N] or [L]: returns the number of tokens read so far. + - [!]: matches the end of input condition. + - [%]: matches one [%] character in the input. + + Following the [%] character that introduces a conversion, there may be + the special flag [_]: the conversion that follows occurs as usual, + but the resulting value is discarded. + For instance, if [f] is the function [fun i -> i + 1], then + [Scanf.sscanf "x = 1" "%_s = %i" f] returns [2]. + + The field width is composed of an optional integer literal + indicating the maximal width of the token to read. + For instance, [%6d] reads an integer, having at most 6 decimal digits; + [%4f] reads a float with at most 4 characters; and [%8\[\\000-\\255\]] + returns the next 8 characters (or all the characters still available, + if fewer than 8 characters are available in the input). + + Notes: + + - as mentioned above, a [%s] convertion always succeeds, even if there is + nothing to read in the input: it simply returns [""]. + + - in addition to the relevant digits, ['_'] characters may appear + inside numbers (this is reminiscent to the usual Caml lexical + conventions). If stricter scanning is desired, use the range + conversion facility instead of the number conversions. + + - the [scanf] facility is not intended for heavy duty lexical + analysis and parsing. If it appears not expressive enough for your + needs, several alternative exists: regular expressions (module + [Str]), stream parsers, [ocamllex]-generated lexers, + [ocamlyacc]-generated parsers. *) + +(** {7 Scanning indications in format strings} *) + +(** Scanning indications appear just after the string conversions [%s] + and [%\[ range \]] to delimit the end of the token. A scanning + indication is introduced by a [@] character, followed by some + constant character [c]. It means that the string token should end + just before the next matching [c] (which is skipped). If no [c] + character is encountered, the string token spreads as much as + possible. For instance, ["%s@\t"] reads a string up to the next + tab character or to the end of input. If a scanning + indication [\@c] does not follow a string conversion, it is treated + as a plain [c] character. + + Note: + + - the scanning indications introduce slight differences in the syntax of + [Scanf] format strings, compared to those used for the [Printf] + module. However, the scanning indications are similar to those used in + the [Format] module; hence, when producing formatted text to be scanned + by [!Scanf.bscanf], it is wise to use printing functions from the + [Format] module (or, if you need to use functions from [Printf], banish + or carefully double check the format strings that contain ['\@'] + characters). *) + +(** {7 Exceptions during scanning} *) + +(** Scanners may raise the following exceptions when the input cannot be read + according to the format string: + + - Raise [Scanf.Scan_failure] if the input does not match the format. + + - Raise [Failure] if a conversion to a number is not possible. + + - Raise [End_of_file] if the end of input is encountered while some more + characters are needed to read the current conversion specification. + + - Raise [Invalid_argument] if the format string is invalid. + + Note: + + - as a consequence, scanning a [%s] conversion never raises exception + [End_of_file]: if the end of input is reached the conversion succeeds and + simply returns the characters read so far, or [""] if none were read. *) + +(** {6 Specialized formatted input functions} *) val fscanf : in_channel -> ('a, 'b, 'c, 'd) scanner;; (** Same as {!Scanf.bscanf}, but reads from the given channel. Warning: since all formatted input functions operate from a scanning - buffer, be aware that each [fscanf] invocation must allocate a new - fresh scanning buffer (unless you make careful use of partial - application). Hence, there are chances that some characters seem - to be skipped (in fact they are pending in the previously used - scanning buffer). This happens in particular when calling [fscanf] again - after a scan involving a format that necessitated some look ahead - (such as a format that ends by skipping whitespace in the input). + buffer, be aware that each [fscanf] invocation will operate with a + scanning buffer reading from the given channel. This extra level of + bufferization can lead to strange scanning behaviour if you use low level + primitives on the channel (reading characters, seeking the reading + position, and so on). - To avoid confusion, consider using [bscanf] with an explicitly - created scanning buffer. Use for instance [Scanning.from_file f] - to allocate the scanning buffer reading from file [f]. - - This method is not only clearer it is also faster, since scanning - buffers to files are optimized for fast buffered reading. *) + As a consequence, never mixt direct low level reading and high level + scanning from the same input channel. *) val sscanf : string -> ('a, 'b, 'c, 'd) scanner;; (** Same as {!Scanf.bscanf}, but reads from the given string. *) @@ -328,19 +387,21 @@ val kscanf : Scanning.scanbuf -> (Scanning.scanbuf -> exn -> 'd) -> ('a, 'b, 'c, 'd) scanner;; (** Same as {!Scanf.bscanf}, but takes an additional function argument - [ef] that is called in case of error: if the scanning process or - some conversion fails, the scanning function aborts and calls the - error handling function [ef] with the scanning buffer and the - exception that aborted the scanning process. *) + [ef] that is called in case of error: if the scanning process or + some conversion fails, the scanning function aborts and calls the + error handling function [ef] with the scanning buffer and the + exception that aborted the scanning process. *) + +(** {6 Reading format strings from input} *) val bscanf_format : Scanning.scanbuf -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g;; (** [bscanf_format ib fmt f] reads a format string token from the scannning - buffer [ib], according to the given format string [fmt], and applies [f] to - the resulting format string value. - Raise [Scan_failure] if the format string value read doesn't have the - same type as [fmt]. *) + buffer [ib], according to the given format string [fmt], and applies [f] to + the resulting format string value. + Raise [Scan_failure] if the format string value read does not have the + same type as [fmt]. *) val sscanf_format : string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> @@ -351,6 +412,6 @@ val format_from_string : string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6;; (** [format_from_string s fmt] converts a string argument to a format string, - according to the given format string [fmt]. - Raise [Scan_failure] if [s], considered as a format string, doesn't - have the same type as [fmt]. *) + according to the given format string [fmt]. + Raise [Scan_failure] if [s], considered as a format string, does not + have the same type as [fmt]. *) diff --git a/stdlib/stdlib.mllib b/stdlib/stdlib.mllib index b3c6924f52..9f835c6fa6 100644 --- a/stdlib/stdlib.mllib +++ b/stdlib/stdlib.mllib @@ -8,6 +8,7 @@ Array ArrayLabels Buffer Callback +CamlinternalLazy CamlinternalMod CamlinternalOO Char diff --git a/stdlib/stream.ml b/stdlib/stream.ml index c9975c4a01..aa6a2a2ab2 100644 --- a/stdlib/stream.ml +++ b/stdlib/stream.ml @@ -22,7 +22,7 @@ and 'a data = Sempty | Scons of 'a * 'a data | Sapp of 'a data * 'a data - | Slazy of (unit -> 'a data) + | Slazy of 'a data Lazy.t | Sgen of 'a gen | Sbuffio of buffio and 'a gen = { mutable curr : 'a option option; func : int -> 'a option } @@ -42,44 +42,54 @@ let fill_buff b = b.len <- input b.ic b.buff 0 (String.length b.buff); b.ind <- 0 ;; -let rec get_data = - function - Sempty -> None - | Scons (a, d) -> Some (a, d) - | Sapp (d1, d2) -> - begin match get_data d1 with - Some (a, d1) -> Some (a, Sapp (d1, d2)) - | None -> get_data d2 - end - | Slazy f -> - begin match f () with - Sgen _ | Sbuffio _ -> failwith "illegal stream concatenation" - | x -> get_data x - end - | Sgen _ | Sbuffio _ -> - failwith "illegal stream concatenation" +let rec get_data count d = match d with + (* Returns either Sempty or Scons(a, _) even when d is a generator + or a buffer. In those cases, the item a is seen as extracted from + the generator/buffer. + The count parameter is used for calling `Sgen-functions'. *) + Sempty | Scons (_, _) -> d + | Sapp (d1, d2) -> + begin match get_data count d1 with + Scons (a, d11) -> Scons (a, Sapp (d11, d2)) + | Sempty -> get_data count d2 + | _ -> assert false + end + | Sgen {curr = Some None; func = _ } -> Sempty + | Sgen ({curr = Some(Some a); func = f} as g) -> + g.curr <- None; Scons(a, d) + | Sgen g -> + begin match g.func count with + None -> g.curr <- Some(None); Sempty + | Some a -> Scons(a, d) + (* Warning: anyone using g thinks that an item has been read *) + end + | Sbuffio b -> + if b.ind >= b.len then fill_buff b; + if b.len == 0 then Sempty else + let r = Obj.magic (String.unsafe_get b.buff b.ind) in + (* Warning: anyone using g thinks that an item has been read *) + b.ind <- succ b.ind; Scons(r, d) + | Slazy f -> get_data count (Lazy.force f) ;; let rec peek s = - match s.data with - Sempty -> None - | Scons (a, _) -> Some a - | Sapp (_, _) -> - begin match get_data s.data with - Some (a, d) -> set_data s (Scons (a, d)); Some a - | None -> None - end - | Slazy f -> - begin match f () with - Sgen _ | Sbuffio _ -> failwith "illegal stream concatenation" - | d -> set_data s d; peek s - end - | Sgen {curr = Some a} -> a - | Sgen g -> let x = g.func s.count in g.curr <- Some x; x - | Sbuffio b -> - if b.ind >= b.len then fill_buff b; - if b.len == 0 then begin set_data s Sempty; None end - else Some (Obj.magic (String.unsafe_get b.buff b.ind)) + (* consult the first item of s *) + match s.data with + Sempty -> None + | Scons (a, _) -> Some a + | Sapp (_, _) -> + begin match get_data s.count s.data with + Scons(a, _) as d -> set_data s d; Some a + | Sempty -> None + | _ -> assert false + end + | Slazy f -> set_data s (Lazy.force f); peek s + | Sgen {curr = Some a} -> a + | Sgen g -> let x = g.func s.count in g.curr <- Some x; x + | Sbuffio b -> + if b.ind >= b.len then fill_buff b; + if b.len == 0 then begin set_data s Sempty; None end + else Some (Obj.magic (String.unsafe_get b.buff b.ind)) ;; let rec junk s = @@ -152,13 +162,13 @@ let icons i s = {count = 0; data = Scons (i, s.data)};; let ising i = {count = 0; data = Scons (i, Sempty)};; let lapp f s = - {count = 0; data = Slazy (fun _ -> Sapp ((f ()).data, s.data))} + {count = 0; data = Slazy (lazy(Sapp ((f ()).data, s.data)))} ;; -let lcons f s = {count = 0; data = Slazy (fun _ -> Scons (f (), s.data))};; -let lsing f = {count = 0; data = Slazy (fun _ -> Scons (f (), Sempty))};; +let lcons f s = {count = 0; data = Slazy (lazy(Scons (f (), s.data)))};; +let lsing f = {count = 0; data = Slazy (lazy(Scons (f (), Sempty)))};; let sempty = {count = 0; data = Sempty};; -let slazy f = {count = 0; data = Slazy (fun _ -> (f ()).data)};; +let slazy f = {count = 0; data = Slazy (lazy(f ()).data)};; (* For debugging use *) @@ -184,7 +194,7 @@ and dump_data f = print_string ", "; dump_data f d2; print_string ")" - | Slazy f -> print_string "Slazy" + | Slazy _ -> print_string "Slazy" | Sgen _ -> print_string "Sgen" | Sbuffio b -> print_string "Sbuffio" ;; diff --git a/stdlib/string.ml b/stdlib/string.ml index dc1e6418d1..2c140c206c 100644 --- a/stdlib/string.ml +++ b/stdlib/string.ml @@ -87,8 +87,8 @@ let escaped s = for i = 0 to length s - 1 do n := !n + (match unsafe_get s i with - '"' | '\\' | '\n' | '\t' -> 2 - | c -> if is_printable c then 1 else 4) + | '"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 + | c -> if is_printable c then 1 else 4) done; if !n = length s then s else begin let s' = create !n in @@ -96,12 +96,16 @@ let escaped s = for i = 0 to length s - 1 do begin match unsafe_get s i with - ('"' | '\\') as c -> + | ('"' | '\\') as c -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n c | '\n' -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'n' | '\t' -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 't' + | '\r' -> + unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'r' + | '\b' -> + unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'b' | c -> if is_printable c then unsafe_set s' !n c @@ -144,34 +148,40 @@ let uncapitalize s = apply1 Char.lowercase s let rec index_rec s lim i c = if i >= lim then raise Not_found else - if unsafe_get s i = c then i else index_rec s lim (i+1) c;; + if unsafe_get s i = c then i else index_rec s lim (i + 1) c;; let index s c = index_rec s (length s) 0 c;; let index_from s i c = - if i < 0 || i > length s then invalid_arg "String.index_from" else - index_rec s (length s) i c;; + let l = length s in + if i < 0 || i >= l then invalid_arg "String.index_from" else + index_rec s l i c;; let rec rindex_rec s i c = if i < 0 then raise Not_found else - if unsafe_get s i = c then i else rindex_rec s (i-1) c;; + if unsafe_get s i = c then i else rindex_rec s (i - 1) c;; let rindex s c = rindex_rec s (length s - 1) c;; let rindex_from s i c = - if i < -1 || i >= length s then invalid_arg "String.rindex_from" else + let l = length s in + if i < 0 || i >= l then invalid_arg "String.rindex_from" else rindex_rec s i c;; let contains_from s i c = - if i < 0 || i > length s then invalid_arg "String.contains_from" else - try ignore(index_rec s (length s) i c); true with Not_found -> false;; + let l = length s in + if i < 0 || i >= l then invalid_arg "String.contains_from" else + try ignore (index_rec s l i c); true with Not_found -> false;; -let rcontains_from s i c = - if i < 0 || i >= length s then invalid_arg "String.rcontains_from" else - try ignore(rindex_rec s i c); true with Not_found -> false;; +let contains s c = + let l = length s in + l <> 0 && contains_from s 0 c;; -let contains s c = contains_from s 0 c;; +let rcontains_from s i c = + let l = length s in + if i < 0 || i >= l then invalid_arg "String.rcontains_from" else + try ignore (rindex_rec s i c); true with Not_found -> false;; type t = string -let compare (x: t) (y: t) = Pervasives.compare x y +let compare = Pervasives.compare diff --git a/stdlib/weak.ml b/stdlib/weak.ml index 317c3729f8..4adacd8e4a 100644 --- a/stdlib/weak.ml +++ b/stdlib/weak.ml @@ -13,7 +13,6 @@ (* $Id$ *) - (** Weak array operations *) type 'a t;; @@ -26,6 +25,8 @@ external set : 'a t -> int -> 'a option -> unit = "caml_weak_set";; external get: 'a t -> int -> 'a option = "caml_weak_get";; external get_copy: 'a t -> int -> 'a option = "caml_weak_get_copy";; external check: 'a t -> int -> bool = "caml_weak_check";; +external blit: 'a t -> int -> 'a t -> int -> int -> unit = "caml_weak_blit";; +(* blit: src srcoff dst dstoff len *) let fill ar ofs len x = if ofs < 0 || len < 0 || ofs + len > length ar @@ -37,23 +38,6 @@ let fill ar ofs len x = end ;; -let blit ar1 of1 ar2 of2 len = - if of1 < 0 || of1 + len > length ar1 || of2 < 0 || of2 + len > length ar2 - then raise (Invalid_argument "Weak.blit") - else begin - if of2 > of1 then begin - for i = 0 to len - 1 do - set ar2 (of2 + i) (get ar1 (of1 + i)) - done - end else begin - for i = len - 1 downto 0 do - set ar2 (of2 + i) (get ar1 (of1 + i)) - done - end - end -;; - - (** Weak hash tables *) module type S = sig @@ -83,27 +67,35 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct type t = { mutable table : data weak_t array; - mutable totsize : int; (* sum of the bucket sizes *) - mutable limit : int; (* max ratio totsize/table length *) + mutable hashes : int array array; + mutable limit : int; (* bucket size limit *) + mutable oversize : int; (* number of oversize buckets *) + mutable rover : int; (* for internal bookkeeping *) };; - let get_index t d = (H.hash d land max_int) mod (Array.length t.table);; + let get_index t h = (h land max_int) mod (Array.length t.table);; + + let limit = 7;; + let over_limit = 2;; let create sz = let sz = if sz < 7 then 7 else sz in let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in { table = Array.create sz emptybucket; - totsize = 0; - limit = 3; + hashes = Array.create sz [| |]; + limit = limit; + oversize = 0; + rover = 0; };; let clear t = for i = 0 to Array.length t.table - 1 do t.table.(i) <- emptybucket; + t.hashes.(i) <- [| |]; done; - t.totsize <- 0; - t.limit <- 3; + t.limit <- limit; + t.oversize <- 0; ;; let fold f t init = @@ -126,85 +118,155 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct Array.iter (iter_bucket 0) t.table ;; - let count t = - let rec count_bucket i b accu = - if i >= length b then accu else - count_bucket (i+1) b (accu + (if check b i then 1 else 0)) + let iter_weak f t = + let rec iter_bucket i j b = + if i >= length b then () else + match check b i with + | true -> f b t.hashes.(j) i; iter_bucket (i+1) j b + | false -> iter_bucket (i+1) j b in + Array.iteri (iter_bucket 0) t.table + ;; + + let rec count_bucket i b accu = + if i >= length b then accu else + count_bucket (i+1) b (accu + (if check b i then 1 else 0)) + ;; + + let count t = Array.fold_right (count_bucket 0) t.table 0 ;; - let next_sz n = min (3*n/2 + 3) (Sys.max_array_length - 1);; + let next_sz n = min (3 * n / 2 + 3) Sys.max_array_length;; + let prev_sz n = ((n - 3) * 2 + 2) / 3;; + + let test_shrink_bucket t = + let bucket = t.table.(t.rover) in + let hbucket = t.hashes.(t.rover) in + let len = length bucket in + let prev_len = prev_sz len in + let live = count_bucket 0 bucket 0 in + if live <= prev_len then begin + let rec loop i j = + if j >= prev_len then begin + if check bucket i then loop (i + 1) j + else if check bucket j then begin + blit bucket j bucket i 1; + hbucket.(i) <- hbucket.(j); + loop (i + 1) (j - 1); + end else loop i (j - 1); + end; + in + loop 0 (length bucket - 1); + if prev_len = 0 then begin + t.table.(t.rover) <- emptybucket; + t.hashes.(t.rover) <- [| |]; + end else begin + Obj.truncate (Obj.repr bucket) (prev_len + 1); + Obj.truncate (Obj.repr hbucket) prev_len; + end; + if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1; + end; + t.rover <- (t.rover + 1) mod (Array.length t.table); + ;; let rec resize t = let oldlen = Array.length t.table in let newlen = next_sz oldlen in if newlen > oldlen then begin let newt = create newlen in - newt.limit <- t.limit + 100; (* prevent resizing of newt *) - fold (fun d () -> add newt d) t (); - (* assert Array.length newt.table = newlen; *) + let add_weak ob oh oi = + let setter nb ni _ = blit ob oi nb ni 1 in + let h = oh.(oi) in + add_aux newt setter None h (get_index newt h); + in + iter_weak add_weak t; t.table <- newt.table; - (* t.limit <- t.limit + 2; -- performance bug *) + t.hashes <- newt.hashes; + t.limit <- newt.limit; + t.oversize <- newt.oversize; + t.rover <- t.rover mod Array.length newt.table; + end else begin + t.limit <- max_int; (* maximum size already reached *) + t.oversize <- 0; end - and add_aux t d index = + and add_aux t setter d h index = let bucket = t.table.(index) in + let hashes = t.hashes.(index) in let sz = length bucket in let rec loop i = if i >= sz then begin - let newsz = min (sz + 3) (Sys.max_array_length - 1) in - if newsz <= sz then failwith "Weak.Make : hash bucket cannot grow more"; + let newsz = min (3 * sz / 2 + 3) (Sys.max_array_length - 1) in + if newsz <= sz then failwith "Weak.Make: hash bucket cannot grow more"; let newbucket = weak_create newsz in + let newhashes = Array.make newsz 0 in blit bucket 0 newbucket 0 sz; - set newbucket i (Some d); + Array.blit hashes 0 newhashes 0 sz; + setter newbucket sz d; + newhashes.(sz) <- h; t.table.(index) <- newbucket; - t.totsize <- t.totsize + (newsz - sz); - if t.totsize > t.limit * Array.length t.table then resize t; + t.hashes.(index) <- newhashes; + if sz <= t.limit && newsz > t.limit then begin + t.oversize <- t.oversize + 1; + for i = 0 to over_limit do test_shrink_bucket t done; + end; + if t.oversize > Array.length t.table / over_limit then resize t; + end else if check bucket i then begin + loop (i + 1) end else begin - if check bucket i - then loop (i+1) - else set bucket i (Some d) - end + setter bucket i d; + hashes.(i) <- h; + end; in loop 0; + ;; - and add t d = add_aux t d (get_index t d) + let add t d = + let h = H.hash d in + add_aux t set (Some d) h (get_index t h); ;; let find_or t d ifnotfound = - let index = get_index t d in + let h = H.hash d in + let index = get_index t h in let bucket = t.table.(index) in + let hashes = t.hashes.(index) in let sz = length bucket in let rec loop i = - if i >= sz then ifnotfound index - else begin + if i >= sz then ifnotfound h index + else if h = hashes.(i) then begin match get_copy bucket i with | Some v when H.equal v d -> begin match get bucket i with | Some v -> v - | None -> loop (i+1) + | None -> loop (i + 1) end - | _ -> loop (i+1) - end + | _ -> loop (i + 1) + end else loop (i + 1) in loop 0 ;; - let merge t d = find_or t d (fun index -> add_aux t d index; d);; + let merge t d = + find_or t d (fun h index -> add_aux t set (Some d) h index; d) + ;; - let find t d = find_or t d (fun index -> raise Not_found);; + let find t d = find_or t d (fun h index -> raise Not_found);; let find_shadow t d iffound ifnotfound = - let index = get_index t d in + let h = H.hash d in + let index = get_index t h in let bucket = t.table.(index) in + let hashes = t.hashes.(index) in let sz = length bucket in let rec loop i = - if i >= sz then ifnotfound else begin + if i >= sz then ifnotfound + else if h = hashes.(i) then begin match get_copy bucket i with | Some v when H.equal v d -> iffound bucket i - | _ -> loop (i+1) - end + | _ -> loop (i + 1) + end else loop (i + 1) in loop 0 ;; @@ -214,20 +276,22 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct let mem t d = find_shadow t d (fun w i -> true) false;; let find_all t d = - let index = get_index t d in + let h = H.hash d in + let index = get_index t h in let bucket = t.table.(index) in + let hashes = t.hashes.(index) in let sz = length bucket in let rec loop i accu = if i >= sz then accu - else begin + else if h = hashes.(i) then begin match get_copy bucket i with | Some v when H.equal v d -> begin match get bucket i with - | Some v -> loop (i+1) (v::accu) - | None -> loop (i+1) accu + | Some v -> loop (i + 1) (v :: accu) + | None -> loop (i + 1) accu end - | _ -> loop (i+1) accu - end + | _ -> loop (i + 1) accu + end else loop (i + 1) accu in loop 0 [] ;; diff --git a/stdlib/weak.mli b/stdlib/weak.mli index a0b794e664..70fcfa3f54 100644 --- a/stdlib/weak.mli +++ b/stdlib/weak.mli @@ -24,9 +24,11 @@ type 'a t any time. A weak pointer is said to be full if it points to a value, empty if the value was erased by the GC. - Note that weak arrays cannot be marshaled using - {!Pervasives.output_value} or the functions of the {!Marshal} - module. + + Notes: + - Integers are not allocated and cannot be stored in weak arrays. + - Weak arrays cannot be marshaled using {!Pervasives.output_value} + nor the functions of the {!Marshal} module. *) diff --git a/tools/Makefile b/tools/Makefile index 2bc6cf04e5..bad14c7e50 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -12,255 +12,10 @@ # $Id$ -include ../config/Makefile - -CAMLRUN=../boot/ocamlrun -CAMLC=$(CAMLRUN) ../boot/ocamlc -nostdlib -I ../boot $(NOJOIN) -CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib $(NOJOIN) -CAMLLEX=$(CAMLRUN) ../boot/ocamllex -INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \ - -I ../driver -COMPFLAGS= -warn-error A $(NOJOIN) $(INCLUDES) -LINKFLAGS=$(NOJOIN) $(INCLUDES) - -all: ocamldep ocamlmktop ocamlmklib -#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)/jocamldep$(EXE) - if test -f ocamldep.opt; \ - then cp ocamldep.opt $(BINDIR)/jocamldep.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)/jocamlprof$(EXE) -# cp ocamlcp $(BINDIR)/jocamlcp$(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)/jocamlmktop - -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)/jocamlmklib - -clean:: - rm -f ocamlmklib - -ocamlmklib.ml: ocamlmklib.mlp ../config/Makefile - echo '(* THIS FILE IS GENERATED FROM ocamlmklib.mlp *)' >ocamlmklib.ml - sed -e "s|%%BINDIR%%|$(BINDIR)|" \ - -e "s|%%SUPPORTS_SHARED_LIBRARIES%%|$(SUPPORTS_SHARED_LIBRARIES)|" \ - -e "s|%%MKSHAREDLIB%%|$(MKSHAREDLIB)|" \ - -e "s|%%BYTECCRPATH%%|$(BYTECCRPATH)|" \ - -e "s|%%NATIVECCRPATH%%|$(NATIVECCRPATH)|" \ - -e "s|%%MKSHAREDLIBRPATH%%|$(MKSHAREDLIBRPATH)|" \ - -e "s|%%RANLIB%%|$(RANLIB)|" \ - ocamlmklib.mlp >> ocamlmklib.ml - -beforedepend:: ocamlmklib.ml - -clean:: - rm -f ocamlmklib.ml - -# Converter olabl/ocaml 2.99 to ocaml 3 - -OCAML299TO3= lexer299.cmo ocaml299to3.cmo -LIBRARY3= misc.cmo warnings.cmo linenum.cmo location.cmo - -ocaml299to3: $(OCAML299TO3) - $(CAMLC) $(LINKFLAGS) -o ocaml299to3 $(LIBRARY3) $(OCAML299TO3) - -lexer299.ml: lexer299.mll - $(CAMLLEX) lexer299.mll - -#install:: -# cp ocaml299to3 $(BINDIR)/ocaml299to3$(EXE) - -clean:: - rm -f ocaml299to3 lexer299.ml - -# Label remover for interface files (upgrade 3.02 to 3.03) - -SCRAPELABELS= lexer301.cmo scrapelabels.cmo - -scrapelabels: $(SCRAPELABELS) - $(CAMLC) $(LINKFLAGS) -o scrapelabels $(LIBRARY3) $(SCRAPELABELS) - -lexer301.ml: lexer301.mll - $(CAMLLEX) lexer301.mll - -#install:: -# cp scrapelabels $(LIBDIR) - -clean:: - rm -f scrapelabels lexer301.ml - -# Insert labels following an interface file (upgrade 3.02 to 3.03) - -ADDLABELS_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ - linenum.cmo warnings.cmo location.cmo longident.cmo \ - syntaxerr.cmo parser.cmo lexer.cmo parse.cmo - -addlabels: addlabels.ml - $(CAMLC) $(LINKFLAGS) -w sl -o addlabels \ - $(ADDLABELS_IMPORTS) addlabels.ml - -#install:: -# cp addlabels $(LIBDIR) - -clean:: - rm -f addlabels - -# The preprocessor for asm generators - -CVT_EMIT=cvt_emit.cmo - -cvt_emit: $(CVT_EMIT) - $(CAMLC) $(LINKFLAGS) -o cvt_emit $(CVT_EMIT) - -# cvt_emit is precious: sometimes we are stuck in the middle of a -# bootstrap and we need to remake the dependencies -clean:: - if test -f cvt_emit; then mv -f cvt_emit cvt_emit.bak; else :; fi - -cvt_emit.ml: cvt_emit.mll - $(CAMLLEX) cvt_emit.mll - -clean:: - rm -f cvt_emit.ml - -beforedepend:: cvt_emit.ml - -# The bytecode disassembler - -DUMPOBJ=opnames.cmo dumpobj.cmo - -dumpobj: $(DUMPOBJ) - $(CAMLC) $(LINKFLAGS) -o dumpobj \ - misc.cmo tbl.cmo config.cmo ident.cmo \ - opcodes.cmo bytesections.cmo $(DUMPOBJ) - -clean:: - rm -f dumpobj - -opnames.ml: ../byterun/instruct.h - unset LC_ALL || : ; \ - unset LC_CTYPE || : ; \ - unset LC_COLLATE LANG || : ; \ - sed -e '/\/\*/d' \ - -e '/^#/d' \ - -e 's/enum \(.*\) {/let names_of_\1 = [|/' \ - -e 's/};$$/ |]/' \ - -e 's/\([A-Z][A-Z_0-9a-z]*\)/"\1"/g' \ - -e 's/,/;/g' \ - ../byterun/instruct.h > opnames.ml - -clean:: - rm -f opnames.ml - -beforedepend:: opnames.ml - -# Dump .cmx files - -dumpapprox: dumpapprox.cmo - $(CAMLC) $(LINKFLAGS) -o dumpapprox config.cmo dumpapprox.cmo - -clean:: - rm -f dumpapprox - -# Print imported interfaces for .cmo files - -objinfo: objinfo.cmo - $(CAMLC) $(LINKFLAGS) -o objinfo config.cmo objinfo.cmo - -clean:: - rm -f objinfo - -# Scan object files for required primitives - -PRIMREQ=primreq.cmo - -primreq: $(PRIMREQ) - $(CAMLC) $(LINKFLAGS) -o primreq config.cmo $(PRIMREQ) - -clean:: - rm -f primreq - -# Common stuff - -.SUFFIXES: -.SUFFIXES: .ml .cmo .mli .cmi .cmx - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) $(COMPFLAGS) -c $< - -clean:: - rm -f *.cmo *.cmi - -depend: beforedepend - $(CAMLRUN) ./ocamldep $(INCLUDES) *.mli *.ml > .depend - -include .depend diff --git a/tools/Makefile.nt b/tools/Makefile.nt index e3619727c0..f0e586124f 100644 --- a/tools/Makefile.nt +++ b/tools/Makefile.nt @@ -12,161 +12,14 @@ # $Id$ -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)/jocamldep.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)/jocamlprof.exe - cp ocamlcp.exe $(BINDIR)/jocamlcp.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)/jocamlmktop.exe - -clean:: - rm -f ocamlmktop.exe - -# The preprocessor for asm generators - -CVT_EMIT=cvt_emit.cmo - -cvt_emit: $(CVT_EMIT) - $(CAMLC) $(LINKFLAGS) -o cvt_emit $(CVT_EMIT) - -clean:: - rm -f cvt_emit - -cvt_emit.ml: cvt_emit.mll - $(CAMLLEX) cvt_emit.mll - -clean:: - rm -f cvt_emit.ml - -beforedepend:: cvt_emit.ml - -# The bytecode disassembler - -DUMPOBJ=opnames.cmo dumpobj.cmo - -dumpobj: $(DUMPOBJ) - $(CAMLC) $(LINKFLAGS) -o dumpobj \ - misc.cmo tbl.cmo config.cmo ident.cmo \ - opcodes.cmo bytesections.cmo $(DUMPOBJ) - -clean:: - rm -f dumpobj - -opnames.ml: ../byterun/instruct.h - sed -e '////*/d' \ - -e 's/enum /(.*/) {/let names_of_/1 = [|/' \ - -e 's/};$$/ |]/' \ - -e 's//([A-Z][A-Z_0-9a-z]*/)/"/1"/g' \ - -e 's/,/;/g' \ - ../byterun/instruct.h > opnames.ml - -clean:: - rm -f opnames.ml - -beforedepend:: opnames.ml - -# Dump .cmx files - -dumpapprox: dumpapprox.cmo - $(CAMLC) $(LINKFLAGS) -o dumpapprox config.cmo dumpapprox.cmo - -clean:: - rm -f dumpapprox - -# Print imported interfaces for .cmo files - -objinfo: objinfo.cmo - $(CAMLC) $(LINKFLAGS) -o objinfo config.cmo objinfo.cmo - -clean:: - rm -f objinfo - -# Scan object files for required primitives - -PRIMREQ=primreq.cmo - -primreq: $(PRIMREQ) - $(CAMLC) $(LINKFLAGS) -o primreq config.cmo $(PRIMREQ) - -clean:: - rm -f primreq - -# Common stuff - -.SUFFIXES: -.SUFFIXES: .ml .cmo .mli .cmi - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -clean:: - rm -f *.cmo *.cmi -depend: beforedepend - $(CAMLRUN) ./ocamldep $(INCLUDES) *.mli *.ml > .depend -include .depend +ocamlmktop: $(OCAMLMKTOP) + $(CAMLC) $(LINKFLAGS) -o ocamlmktop $(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP) diff --git a/tools/Makefile.shared b/tools/Makefile.shared index aa8aba5f70..3b68be2bf6 100644 --- a/tools/Makefile.shared +++ b/tools/Makefile.shared @@ -15,8 +15,8 @@ include ../config/Makefile CAMLRUN=../boot/ocamlrun -CAMLC=$(CAMLRUN) ../boot/ocamlc -nostdlib -I ../boot -CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib +CAMLC=$(CAMLRUN) ../boot/ocamlc -nostdlib $(NOJOIN) -I ../boot +CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib $(NOJOIN) -I ../stdlib CAMLLEX=$(CAMLRUN) ../boot/ocamllex INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \ -I ../driver diff --git a/tools/addlabels.ml b/tools/addlabels.ml index 3c5f7889ff..777275442b 100644 --- a/tools/addlabels.ml +++ b/tools/addlabels.ml @@ -62,6 +62,7 @@ let rec pattern_vars pat = List.concat (List.map l ~f:(fun (_,p) -> pattern_vars p)) | Ppat_or (pat1, pat2) -> pattern_vars pat1 @ pattern_vars pat2 + | Ppat_lazy pat -> pattern_vars pat | Ppat_any | Ppat_constant _ | Ppat_construct _ | Ppat_variant _ | Ppat_type _ -> [] diff --git a/tools/depend.ml b/tools/depend.ml index 70acbb7da6..f58dc9f69b 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -68,10 +68,10 @@ let add_type_declaration bv td = td.ptype_cstrs; add_opt add_type bv td.ptype_manifest; let rec add_tkind = function - Ptype_abstract | Ptype_private -> () - | Ptype_variant (cstrs, _) -> + Ptype_abstract -> () + | Ptype_variant cstrs -> List.iter (fun (c, args, _) -> List.iter (add_type bv) args) cstrs - | Ptype_record (lbls, _) -> + | Ptype_record lbls -> List.iter (fun (l, mut, ty, _) -> add_type bv ty) lbls in add_tkind td.ptype_kind @@ -112,6 +112,7 @@ let rec add_pattern bv pat = | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty | Ppat_variant(_, op) -> add_opt add_pattern bv op | Ppat_type (li) -> add bv li + | Ppat_lazy p -> add_pattern bv p let rec add_expr bv exp = match exp.pexp_desc with @@ -290,8 +291,8 @@ and add_class_expr bv ce = add bv l; List.iter (add_type bv) tyl | Pcl_structure(pat, fieldl) -> add_pattern bv pat; List.iter (add_class_field bv) fieldl - | Pcl_fun(_, _, pat, ce) -> - add_pattern bv pat; add_class_expr bv ce + | Pcl_fun(_, opte, pat, ce) -> + add_opt add_expr bv opte; add_pattern bv pat; add_class_expr bv ce | Pcl_apply(ce, exprl) -> add_class_expr bv ce; List.iter (fun (_,e) -> add_expr bv e) exprl | Pcl_let(_, pel, ce) -> diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml index b2fefad8b1..2a054ee684 100644 --- a/tools/dumpobj.ml +++ b/tools/dumpobj.ml @@ -451,7 +451,7 @@ let print_instr ic = print_int nvars; for i = 0 to nfuncs - 1 do print_string ", "; - print_int (orig + inputu ic); + print_int (orig + inputs ic); done; | Pubmet -> let tag = inputs ic in diff --git a/tools/make-package-macosx b/tools/make-package-macosx index 1839c52c61..5a1b76eef1 100755 --- a/tools/make-package-macosx +++ b/tools/make-package-macosx @@ -18,23 +18,8 @@ cd package-macosx rm -rf ocaml.pkg ocaml-rw.dmg VERSION=`head -1 ../VERSION` -VERSION_MAJOR=`sed -n -e '1s/^\([0-9]*\)\..*/\1/p' ../VERSION -VERSION_MINOR=`sed -n -e '1s/^[0-9]*\.\([0-9]*\)[.+].*/\1/p' ../VERSION - -# Worked in 10.2: - -# cat >ocaml.info <<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 +VERSION_MAJOR=`sed -n -e '1s/^\([0-9]*\)\..*/\1/p' ../VERSION` +VERSION_MINOR=`sed -n -e '1s/^[0-9]*\.\([0-9]*\)[.+].*/\1/p' ../VERSION` cat >Description.plist <<EOF <?xml version="1.0" encoding="UTF-8"?> @@ -101,8 +86,8 @@ mkdir -p resources # stop here -> | cat >resources/ReadMe.txt <<EOF This package installs Objective Caml version ${VERSION}. -You need Mac OS X 10.4.x (Tiger), with X11 and the -XCode tools (v2.4) 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: @@ -112,7 +97,7 @@ Files will be installed in the following directories: EOF chmod -R g-w root -sudo chown -R root:admin root +sudo chown -R root:wheel root /Developer/Applications/Utilities/PackageMaker.app/Contents/MacOS/PackageMaker \ -build -p "`pwd`/ocaml.pkg" -f "`pwd`/root" -i "`pwd`/Info.plist" \ @@ -123,18 +108,20 @@ size=`expr $size + 8192` hdiutil create -sectors $size ocaml-rw.dmg name=`hdid -nomount ocaml-rw.dmg | grep Apple_HFS | cut -d ' ' -f 1` -newfs_hfs -v 'Objective Caml' $name +volname="Objective Caml ${VERSION}" +newfs_hfs -v "$volname" $name hdiutil detach $name name=`hdid ocaml-rw.dmg | grep Apple_HFS | cut -d ' ' -f 1` -if test -d '/Volumes/Objective Caml'; then - ditto -rsrcFork ocaml.pkg "/Volumes/Objective Caml/ocaml.pkg" - cp resources/ReadMe.txt "/Volumes/Objective Caml/" +if test -d "/Volumes/$volname"; then + ditto -rsrcFork ocaml.pkg "/Volumes/$volname/ocaml.pkg" + cp resources/ReadMe.txt "/Volumes/$volname/" else - echo 'Unable to mount the disk image as "/Volumes/Objective Caml"' >&2 + echo "Unable to mount the disk image as \"/Volumes/$volname\"" >&2 exit 3 fi -open "/Volumes/Objective Caml" +open "/Volumes/$volname" +sleep 2 hdiutil detach $name rm -rf "ocaml-${VERSION}.dmg" diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml index 25bf68193a..ad7a13bbc6 100644 --- a/tools/ocamlcp.ml +++ b/tools/ocamlcp.ml @@ -43,6 +43,7 @@ let incompatible o = 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 diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml index 68fc083988..b30a0f4a71 100644 --- a/tools/ocamldep.ml +++ b/tools/ocamldep.ml @@ -115,21 +115,18 @@ let print_filename s = ;; 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 ":"; @@ -206,7 +203,7 @@ let ml_file_dependencies source_file = if !raw_dependencies then begin print_raw_dependencies source_file !Depend.free_structure_names end else begin - let basename = Filename.chop_suffix source_file ".ml" in + let basename = Filename.chop_extension source_file in let init_deps = if Sys.file_exists (basename ^ ".mli") then let cmi_name = basename ^ ".cmi" in ([cmi_name], [cmi_name]) @@ -231,7 +228,7 @@ let mli_file_dependencies source_file = if !raw_dependencies then begin print_raw_dependencies source_file !Depend.free_structure_names end else begin - let basename = Filename.chop_suffix source_file ".mli" in + let basename = Filename.chop_extension source_file in let (byt_deps, opt_deps) = Depend.StringSet.fold find_dependency !Depend.free_structure_names ([], []) in @@ -241,21 +238,21 @@ let mli_file_dependencies source_file = with x -> close_in ic; remove_preprocessed input_file; raise x -let file_dependencies source_file = +type file_kind = ML | MLI;; + +let file_dependencies_as kind source_file = Location.input_name := source_file; try if Sys.file_exists source_file then begin - if Filename.check_suffix source_file ".ml" then - ml_file_dependencies source_file - else if Filename.check_suffix source_file ".mli" then - mli_file_dependencies source_file - else () + match kind with + | ML -> ml_file_dependencies source_file + | MLI -> mli_file_dependencies source_file end with x -> let report_err = function | Lexer.Error(err, range) -> fprintf Format.err_formatter "@[%a%a@]@." - Location.print range Lexer.report_error err + Location.print_error range Lexer.report_error err | Syntaxerr.Error err -> fprintf Format.err_formatter "@[%a@]@." Syntaxerr.report_error err @@ -268,6 +265,13 @@ let file_dependencies source_file = error_occurred := true; report_err x +let file_dependencies source_file = + if Filename.check_suffix source_file ".ml" then + file_dependencies_as ML source_file + else if Filename.check_suffix source_file ".mli" then + file_dependencies_as MLI source_file + else () + (* Entry point *) let usage = "Usage: jocamldep [options] <source files>\nOptions are:" @@ -285,15 +289,18 @@ let _ = "act over pure OCaml source files" ; "-I", Arg.String add_to_load_path, "<dir> Add <dir> to the list of include directories"; + "-impl", Arg.String (file_dependencies_as ML), + "<f> Process <f> as a .ml file"; + "-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; diff --git a/tools/ocamlmklib.mlp b/tools/ocamlmklib.mlp index 3fcc1526fb..39aac11ff1 100644 --- a/tools/ocamlmklib.mlp +++ b/tools/ocamlmklib.mlp @@ -16,8 +16,8 @@ open Printf open Myocamlbuild_config let bytecode_objs = ref [] (* .cmo,.cma,.ml,.mli files to pass to jocamlc *) -and native_objs = ref [] (* .cmx,.cmxa,.ml,.mli files to pass to jocamlopt *) -and c_objs = ref [] (* .o, .a, .obj, .libfiles to pass to mksharedlib and ar *) +and native_objs = ref [] (* .cmx,.cmxa,.ml,.mli files to pass to jocamlopt *) +and c_objs = ref [] (* .o, .a, .obj, .libfiles to pass to mksharedlib and ar *) and caml_libs = ref [] (* -cclib to pass to jocamlc, jocamlopt *) and caml_opts = ref [] (* -ccopt to pass to jocamlc, jocamlopt *) @@ -31,7 +31,6 @@ and jocamlopt = ref (Filename.concat bindir "jocamlopt") 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 = @@ -64,7 +63,7 @@ let parse_arguments argv = else if ends_with s ".ml" || ends_with s ".mli" then (bytecode_objs := s :: !bytecode_objs; native_objs := s :: !native_objs) - else if 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 @@ -72,13 +71,11 @@ let parse_arguments argv = caml_opts := next_arg () :: "-ccopt" :: !caml_opts else if s = "-custom" then dynlink := false - else if s = "-implib" then - implib := next_arg () else if s = "-I" then caml_opts := next_arg () :: "-I" :: !caml_opts else if s = "-failsafe" then failsafe := true - else if s = "-h" || s = "-help" then + else if s = "-h" || s = "-help" || s = "--help" then raise (Bad_argument "") else if s = "-ldopt" then ld_opts := next_arg () :: !ld_opts @@ -129,15 +126,23 @@ let parse_arguments argv = (fun r -> r := List.rev !r) [ bytecode_objs; native_objs; c_objs; caml_libs; caml_opts; c_libs; c_objs; c_opts; ld_opts; rpath ]; + (* On retourne deux fois c_objs ?? -- AF *) + if !output_c = "" then output_c := !output let usage = "\ -Usage: jocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib files> +Usage: jocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|.dll files> + Options are: -cclib <lib> C library passed to jocamlc -a or jocamlopt -a only -ccopt <opt> C option passed to jocamlc -a or jocamlopt -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 -jocamlc <cmd> Use <cmd> in place of \"jocamlc\" -jocamlopt <cmd> Use <cmd> in place of \"jocamlopt\" @@ -153,12 +158,11 @@ Options are: -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 = @@ -197,18 +201,29 @@ let prepostfix pre name post = Filename.concat dir (pre ^ base ^ post) ;; +let transl_path s = + match Sys.os_type with + | "Win32" -> + let rec aux i = + if i = String.length s || s.[i] = ' ' then s + else (if s.[i] = '/' then s.[i] <- '\\'; aux (i + 1)) + in aux 0 + | _ -> s + let build_libs () = if !c_objs <> [] then begin if !dynlink then begin let retcode = command - (mkdll (prepostfix "dll" !output_c ext_dll) - !implib - (sprintf "%s %s %s %s %s" - (String.concat " " !c_objs) - (String.concat " " !c_opts) - (String.concat " " !ld_opts) - (make_rpath mksharedlibrpath) - (String.concat " " !c_libs)) "") in + (Printf.sprintf "%s -o %s %s %s %s %s %s" + mkdll + (prepostfix "dll" !output_c ext_dll) + (String.concat " " !c_objs) + (String.concat " " !c_opts) + (String.concat " " !ld_opts) + (make_rpath mksharedlibrpath) + (String.concat " " !c_libs) + ) + in if retcode <> 0 then if !failsafe then dynlink := false else exit 2 end; safe_remove (prepostfix "lib" !output_c ext_lib); @@ -219,7 +234,7 @@ let build_libs () = if !bytecode_objs <> [] then scommand (sprintf "%s -a %s -o %s.cma %s %s -dllib -l%s -cclib -l%s %s %s %s %s" - !jocamlc + (transl_path !jocamlc) (if !dynlink then "" else "-custom") !output (String.concat " " !caml_opts) @@ -233,7 +248,7 @@ let build_libs () = if !native_objs <> [] then scommand (sprintf "%s -a -o %s.cmxa %s %s -cclib -l%s %s %s %s %s" - !jocamlopt + (transl_path !jocamlopt) !output (String.concat " " !caml_opts) (String.concat " " !native_objs) diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml index 7eb3f1b609..d97b1effa7 100644 --- a/tools/ocamlprof.ml +++ b/tools/ocamlprof.ml @@ -482,7 +482,7 @@ let main () = let report_error ppf = function | Lexer.Error(err, range) -> fprintf ppf "@[%a%a@]@." - Location.print range Lexer.report_error err + Location.print_error range Lexer.report_error err | Syntaxerr.Error err -> fprintf ppf "@[%a@]@." Syntaxerr.report_error err diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 97c4e02995..a0ec5bc05e 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -242,7 +242,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct tree_of_val depth obj (try Ctype.apply env decl.type_params body ty_list with Ctype.Cannot_apply -> abstract_type) - | {type_kind = Type_variant(constr_list, priv)} -> + | {type_kind = Type_variant constr_list} -> let tag = if O.is_block obj then Cstr_block(O.tag obj) @@ -257,7 +257,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct constr_args in tree_of_constr_with_args (tree_of_constr env path) constr_name 0 depth obj ty_args - | {type_kind = Type_record(lbl_list, rep, priv)} -> + | {type_kind = Type_record(lbl_list, rep)} -> begin match check_depth depth obj ty with Some x -> x | None -> diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index bfaebd29ff..80d7c6c32f 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -100,7 +100,8 @@ let remove_printer = Printer.remove_printer let parse_toplevel_phrase = ref Parse.toplevel_phrase let parse_use_file = ref Parse.use_file -let print_location = Location.print +let print_location = Location.print_error (* FIXME change back to print *) +let print_error = Location.print_error let print_warning = Location.print_warning let input_name = Location.input_name @@ -218,7 +219,8 @@ let execute_phrase print_outcome ppf phr = let oldenv = !toplevel_env in let _ = Unused_var.warn ppf sstr in Typecore.reset_delayed_checks (); - let (str, sg, newenv) = Typemod.type_structure oldenv sstr in + let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none + in Typecore.force_delayed_checks (); let lam = Translmod.transl_toplevel_definition str in Warnings.check_fatal (); diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli index 6b25941c83..35eb5dbf5b 100644 --- a/toplevel/toploop.mli +++ b/toplevel/toploop.mli @@ -80,6 +80,7 @@ val max_printer_steps: int ref val parse_toplevel_phrase : (Lexing.lexbuf -> Parsetree.toplevel_phrase) ref val parse_use_file : (Lexing.lexbuf -> Parsetree.toplevel_phrase list) ref val print_location : formatter -> Location.t -> unit +val print_error : formatter -> Location.t -> unit val print_warning : Location.t -> formatter -> Warnings.t -> unit val input_name : string ref diff --git a/typing/btype.ml b/typing/btype.ml index 1f3732d45b..4d4333c60c 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -140,7 +140,7 @@ let proxy ty = in proxy_obj ty | _ -> ty0 -(**** Utilities for private types ****) +(**** Utilities for fixed row private types ****) let has_constr_row t = match (repr t).desc with @@ -176,8 +176,7 @@ let rec iter_row f row = match (repr row.row_more).desc with Tvariant row -> iter_row f row | Tvar | Tunivar | Tsubst _ | Tconstr _ -> - Misc.may (fun (_,l) -> List.iter f l) row.row_name; - List.iter f row.row_bound + Misc.may (fun (_,l) -> List.iter f l) row.row_name | _ -> assert false let iter_type_expr f ty = @@ -200,11 +199,10 @@ let iter_type_expr f ty = let rec iter_abbrev f = function Mnil -> () - | Mcons(_, ty, ty', rem) -> f ty; f ty'; iter_abbrev f rem + | Mcons(_, _, ty, ty', rem) -> f ty; f ty'; iter_abbrev f rem | Mlink rem -> iter_abbrev f !rem let copy_row f fixed row keep more = - let bound = ref [] in let fields = List.map (fun (l, fi) -> l, match row_field_repr fi with @@ -213,10 +211,6 @@ let copy_row f fixed row keep more = let e = if keep then e else ref None in let m = if row.row_fixed then fixed else m in let tl = List.map f tl in - bound := List.filter - (function {desc=Tconstr(_,[],_)} -> false | _ -> true) - (List.map repr tl) - @ !bound; Reither(c, tl, m, e) | _ -> fi) row.row_fields in @@ -224,7 +218,7 @@ let copy_row f fixed row keep more = match row.row_name with None -> None | Some (path, tl) -> Some (path, List.map f tl) in { row_fields = fields; row_more = more; - row_bound = !bound; row_fixed = row.row_fixed && fixed; + row_bound = (); row_fixed = row.row_fixed && fixed; row_closed = row.row_closed; row_name = name; } let rec copy_kind = function @@ -319,9 +313,9 @@ let unmark_type_decl decl = List.iter unmark_type decl.type_params; begin match decl.type_kind with Type_abstract -> () - | Type_variant (cstrs, priv) -> + | Type_variant cstrs -> List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs - | Type_record(lbls, rep, priv) -> + | Type_record(lbls, rep) -> List.iter (fun (c, mut, t) -> unmark_type t) lbls end; begin match decl.type_manifest with @@ -348,11 +342,12 @@ let rec unmark_class_type = (*******************************************) (* Search whether the expansion has been memorized. *) -let rec find_expans p1 = function +let rec find_expans priv p1 = function Mnil -> None - | Mcons (p2, ty0, ty, _) when Path.same p1 p2 -> Some ty - | Mcons (_, _, _, rem) -> find_expans p1 rem - | Mlink {contents = rem} -> find_expans p1 rem + | Mcons (priv', p2, ty0, ty, _) + when priv' >= priv && Path.same p1 p2 -> Some ty + | Mcons (_, _, _, _, rem) -> find_expans priv p1 rem + | Mlink {contents = rem} -> find_expans priv p1 rem (* debug: check for cycles in abbreviation. only works with -principal let rec check_expans visited ty = @@ -375,9 +370,9 @@ let cleanup_abbrev () = List.iter (fun abbr -> abbr := Mnil) !memo; memo := [] -let memorize_abbrev mem path v v' = +let memorize_abbrev mem priv path v v' = (* Memorize the expansion of an abbreviation. *) - mem := Mcons (path, v, v', !mem); + mem := Mcons (priv, path, v, v', !mem); (* check_expans [] v; *) memo := mem :: !memo @@ -385,10 +380,10 @@ let rec forget_abbrev_rec mem path = match mem with Mnil -> assert false - | Mcons (path', _, _, rem) when Path.same path path' -> + | Mcons (_, path', _, _, rem) when Path.same path path' -> rem - | Mcons (path', v, v', rem) -> - Mcons (path', v, v', forget_abbrev_rec rem path) + | Mcons (priv, path', v, v', rem) -> + Mcons (priv, path', v, v', forget_abbrev_rec rem path) | Mlink mem' -> mem' := forget_abbrev_rec !mem' path; raise Exit diff --git a/typing/btype.mli b/typing/btype.mli index 6e1f2f215b..4ea5e3b40b 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -59,7 +59,7 @@ val proxy: type_expr -> type_expr (* Return the proxy representative of the type: either itself or a row variable *) -(**** Utilities for private types ****) +(**** Utilities for private abbreviations with fixed rows ****) val has_constr_row: type_expr -> bool val is_row_name: string -> bool @@ -104,14 +104,15 @@ val unmark_class_signature: class_signature -> unit (**** Memorization of abbreviation expansion ****) -val find_expans: Path.t -> abbrev_memo -> type_expr option +val find_expans: private_flag -> Path.t -> abbrev_memo -> type_expr option (* Look up a memorized abbreviation *) val cleanup_abbrev: unit -> unit (* Flush the cache of abbreviation expansions. When some types are saved (using [output_value]), this function MUST be called just before. *) val memorize_abbrev: - abbrev_memo ref -> Path.t -> type_expr -> type_expr -> unit + abbrev_memo ref -> + private_flag -> Path.t -> type_expr -> type_expr -> unit (* Add an expansion in the cache *) val forget_abbrev: abbrev_memo ref -> Path.t -> unit diff --git a/typing/ctype.ml b/typing/ctype.ml index 645f9890c7..69061e5f1c 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -101,7 +101,6 @@ let current_level = ref 0 let nongen_level = ref 0 let global_level = ref 1 let saved_level = ref [] -let saved_global_level = ref [] let init_def level = current_level := level; nongen_level := level let begin_def () = @@ -119,8 +118,7 @@ let end_def () = current_level := cl; nongen_level := nl let reset_global_level () = - global_level := !current_level + 1; - saved_global_level := [] + global_level := !current_level + 1 let increase_global_level () = let gl = !global_level in global_level := !current_level; @@ -322,17 +320,21 @@ let rec class_type_arity = let sort_row_fields = Sort.list (fun (p,_) (q,_) -> p < q) +let rec merge_rf r1 r2 pairs fi1 fi2 = + match fi1, fi2 with + (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' -> + if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else + if l1 < l2 then merge_rf (p1::r1) r2 pairs fi1' fi2 else + merge_rf r1 (p2::r2) pairs fi1 fi2' + | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs) + | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs) + let merge_row_fields fi1 fi2 = - let rec merge r1 r2 pairs fi1 fi2 = - match fi1, fi2 with - (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' -> - if l1 = l2 then merge r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else - if l1 < l2 then merge (p1::r1) r2 pairs fi1' fi2 else - merge r1 (p2::r2) pairs fi1 fi2' - | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs) - | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs) - in - merge [] [] [] (sort_row_fields fi1) (sort_row_fields fi2) + match fi1, fi2 with + [], _ | _, [] -> (fi1, fi2, []) + | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, []) + | _, [p2] when not (List.mem_assoc (fst p2) fi1) -> (fi1, fi2, []) + | _ -> merge_rf [] [] [] (sort_row_fields fi1) (sort_row_fields fi2) let rec filter_row_fields erase = function [] -> [] @@ -364,7 +366,7 @@ let rec closed_schema_rec ty = closed_schema_rec t2 | Tvariant row -> let row = row_repr row in - iter_row closed_schema_rec {row with row_bound = []}; + iter_row closed_schema_rec row; if not (static_row row) then closed_schema_rec row.row_more | _ -> iter_type_expr closed_schema_rec ty @@ -401,7 +403,7 @@ let rec free_vars_rec real ty = free_vars_rec true ty1; free_vars_rec false ty2 | Tvariant row -> let row = row_repr row in - iter_row (free_vars_rec true) {row with row_bound = []}; + iter_row (free_vars_rec true) row; if not (static_row row) then free_vars_rec false row.row_more | _ -> iter_type_expr (free_vars_rec true) ty @@ -439,9 +441,9 @@ let closed_type_decl decl = begin match decl.type_kind with Type_abstract -> () - | Type_variant(v, priv) -> + | Type_variant v -> List.iter (fun (_, tyl) -> List.iter closed_type tyl) v - | Type_record(r, rep, priv) -> + | Type_record(r, rep) -> List.iter (fun (_, _, ty) -> closed_type ty) r end; begin match decl.type_manifest with @@ -575,7 +577,7 @@ let rec generalize_spine ty = generalize_spine ty' | _ -> () -let try_expand_once' = (* Forward declaration *) +let forward_try_expand_once = (* Forward declaration *) ref (fun env ty -> raise Cannot_expand) (* @@ -597,7 +599,7 @@ let rec update_level env level ty = Tconstr(p, tl, abbrev) when level < Path.binding_time p -> (* Try first to replace an abbreviation by its expansion. *) begin try - link_type ty (!try_expand_once' env ty); + link_type ty (!forward_try_expand_once env ty); update_level env level ty with Cannot_expand -> (* +++ Levels should be restored... *) @@ -733,9 +735,9 @@ let rec find_repr p1 = function Mnil -> None - | Mcons (p2, ty, _, _) when Path.same p1 p2 -> + | Mcons (Public, p2, ty, _, _) when Path.same p1 p2 -> Some ty - | Mcons (_, _, _, rem) -> + | Mcons (_, _, _, _, rem) -> find_repr p1 rem | Mlink {contents = rem} -> find_repr p1 rem @@ -1007,7 +1009,7 @@ let instance_label fixed lbl = let unify' = (* Forward declaration *) ref (fun env ty1 ty2 -> raise (Unify [])) -let rec subst env level abbrev ty params args body = +let rec subst env level priv abbrev ty params args body = if List.length params <> List.length args then raise (Unify []); let old_level = !current_level in current_level := level; @@ -1017,7 +1019,7 @@ let rec subst env level abbrev ty params args body = None -> () | Some ({desc = Tconstr (path, tl, _)} as ty) -> let abbrev = proper_abbrevs path tl abbrev in - memorize_abbrev abbrev path ty body0 + memorize_abbrev abbrev priv path ty body0 | _ -> assert false end; @@ -1040,7 +1042,7 @@ let rec subst env level abbrev ty params args body = *) let apply env params body args = try - subst env generic_level (ref Mnil) None params args body + subst env generic_level Public (ref Mnil) None params args body with Unify _ -> raise Cannot_apply @@ -1056,8 +1058,10 @@ let apply env params body args = type or module definition is overriden in the environnement. *) let previous_env = ref Env.empty +let string_of_kind = function Public -> "public" | Private -> "private" let check_abbrev_env env = if env != !previous_env then begin + (* prerr_endline "cleanup expansion cache"; *) cleanup_abbrev (); previous_env := env end @@ -1080,13 +1084,15 @@ let check_abbrev_env env = 4. The expansion requires the expansion of another abbreviation, and this other expansion fails. *) -let expand_abbrev env ty = +let expand_abbrev_gen kind find_type_expansion env ty = check_abbrev_env env; match ty with {desc = Tconstr (path, args, abbrev); level = level} -> let lookup_abbrev = proper_abbrevs path args abbrev in - begin match find_expans path !lookup_abbrev with + begin match find_expans kind path !lookup_abbrev with Some ty -> + (* prerr_endline + ("found a "^string_of_kind kind^" expansion for "^Path.name path);*) if level <> generic_level then begin try update_level env level ty @@ -1099,10 +1105,12 @@ let expand_abbrev env ty = ty | None -> let (params, body) = - try Env.find_type_expansion path env with Not_found -> + try find_type_expansion path env with Not_found -> raise Cannot_expand in - let ty' = subst env level abbrev (Some ty) params args body in + (* prerr_endline + ("add a "^string_of_kind kind^" expansion for "^Path.name path);*) + let ty' = subst env level kind abbrev (Some ty) params args body in (* Hack to name the variant type *) begin match repr ty' with {desc=Tvariant row} as ty when static_row row -> @@ -1114,6 +1122,8 @@ let expand_abbrev env ty = | _ -> assert false +let expand_abbrev = expand_abbrev_gen Public Env.find_type_expansion + let safe_abbrev env ty = let snap = Btype.snapshot () in try ignore (expand_abbrev env ty); true @@ -1127,7 +1137,7 @@ let try_expand_once env ty = Tconstr _ -> repr (expand_abbrev env ty) | _ -> raise Cannot_expand -let _ = try_expand_once' := try_expand_once +let _ = forward_try_expand_once := try_expand_once (* Fully expand the head of a type. Raise Cannot_expand if the type cannot be expanded. @@ -1155,6 +1165,36 @@ let expand_head env ty = Btype.backtrack snap; repr ty +(* Implementing function [expand_head_opt], the compiler's own version of + [expand_head] used for type-based optimisations. + [expand_head_opt] uses [Env.find_type_expansion_opt] to access the + manifest type information of private abstract data types which is + normally hidden to the type-checker out of the implementation module of + the private abbreviation. *) + +let expand_abbrev_opt = expand_abbrev_gen Private Env.find_type_expansion_opt + +let try_expand_once_opt env ty = + let ty = repr ty in + match ty.desc with + Tconstr _ -> repr (expand_abbrev_opt env ty) + | _ -> raise Cannot_expand + +let rec try_expand_head_opt env ty = + let ty' = try_expand_once_opt env ty in + begin try + try_expand_head_opt env ty' + with Cannot_expand -> + ty' + end + +let expand_head_opt env ty = + let snap = Btype.snapshot () in + try try_expand_head_opt env ty + with Cannot_expand | Unify _ -> (* expand_head shall never fail *) + Btype.backtrack snap; + repr ty + (* Make sure that the type parameters of the type constructor [ty] respect the type constraints *) let enforce_constraints env ty = @@ -1162,7 +1202,8 @@ let enforce_constraints env ty = {desc = Tconstr (path, args, abbrev); level = level} -> let decl = Env.find_type path env in ignore - (subst env level (ref Mnil) None decl.type_params args (newvar2 level)) + (subst env level Public (ref Mnil) None decl.type_params args + (newvar2 level)) | _ -> assert false @@ -1208,7 +1249,7 @@ let rec non_recursive_abbrev env ty0 ty = match ty.desc with Tconstr(p, args, abbrev) -> begin try - non_recursive_abbrev env ty0 (try_expand_head env ty) + non_recursive_abbrev env ty0 (try_expand_once env ty) with Cannot_expand -> if !Clflags.recursive_types then () else iter_type_expr (non_recursive_abbrev env ty0) ty @@ -1224,11 +1265,11 @@ let correct_abbrev env path params ty = check_abbrev_env env; let ty0 = newgenvar () in visited := []; - let abbrev = Mcons (path, ty0, ty0, Mnil) in + let abbrev = Mcons (Public, path, ty0, ty0, Mnil) in simple_abbrevs := abbrev; try non_recursive_abbrev env ty0 - (subst env generic_level (ref abbrev) None [] [] ty); + (subst env generic_level Public (ref abbrev) None [] [] ty); simple_abbrevs := Mnil; visited := [] with exn -> @@ -1424,7 +1465,7 @@ let univar_pairs = ref [] let rec has_cached_expansion p abbrev = match abbrev with Mnil -> false - | Mcons(p', _, _, rem) -> Path.same p p' || has_cached_expansion p rem + | Mcons(_, p', _, _, rem) -> Path.same p p' || has_cached_expansion p rem | Mlink rem -> has_cached_expansion p !rem (**** Transform error trace ****) @@ -1441,7 +1482,7 @@ let mkvariant fields closed = newgenty (Tvariant {row_fields = fields; row_closed = closed; row_more = newvar(); - row_bound = []; row_fixed = false; row_name = None }) + row_bound = (); row_fixed = false; row_name = None }) (**** Unification ****) @@ -1745,8 +1786,7 @@ and unify_row env row1 row2 = then row2.row_name else None in - let bound = row1.row_bound @ row2.row_bound in - let row0 = {row_fields = []; row_more = more; row_bound = bound; + let row0 = {row_fields = []; row_more = more; row_bound = (); row_closed = closed; row_fixed = fixed; row_name = name} in let set_more row rest = let rest = @@ -1999,6 +2039,10 @@ let moregen_occur env level ty = occur_univar env ty; update_level env level ty +let may_instantiate inst_nongen t1 = + if inst_nongen then t1.level <> generic_level - 1 + else t1.level = generic_level + let rec moregen inst_nongen type_pairs env t1 t2 = if t1 == t2 then () else let t1 = repr t1 in @@ -2009,8 +2053,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 = match (t1.desc, t2.desc) with (Tunivar, Tunivar) -> unify_univar t1 t2 !univar_pairs - | (Tvar, _) when if inst_nongen then t1.level <> generic_level - 1 - else t1.level = generic_level -> + | (Tvar, _) when may_instantiate inst_nongen t1 -> moregen_occur env t1.level t2; occur env t1 t2; link_type t1 t2 @@ -2027,8 +2070,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 = with Not_found -> TypePairs.add type_pairs (t1', t2') (); match (t1'.desc, t2'.desc) with - (Tvar, _) when if inst_nongen then t1'.level <> generic_level - 1 - else t1'.level = generic_level -> + (Tvar, _) when may_instantiate inst_nongen t1 -> moregen_occur env t1'.level t2; link_type t1' t2 | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 @@ -2090,33 +2132,36 @@ and moregen_kind k1 k2 = and moregen_row inst_nongen type_pairs env row1 row2 = let row1 = row_repr row1 and row2 = row_repr row2 in + let rm1 = repr row1.row_more and rm2 = repr row2.row_more in + if rm1 == rm2 then () else + let may_inst = rm1.desc = Tvar && may_instantiate inst_nongen rm1 in let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in let r1, r2 = if row2.row_closed then - filter_row_fields true r1, filter_row_fields false r2 + filter_row_fields may_inst r1, filter_row_fields false r2 else r1, r2 in if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> []) then raise (Unify []); - let rm1 = repr row1.row_more and rm2 = repr row2.row_more in - let univ = - match rm1.desc, rm2.desc with - Tunivar, Tunivar -> - unify_univar rm1 rm2 !univar_pairs; - true - | Tunivar, _ | _, Tunivar -> - raise (Unify []) - | _ -> - if not (static_row row2) then moregen_occur env rm1.level rm2; - let ext = - if r2 = [] then rm2 else - let row_ext = {row2 with row_fields = r2} in - iter_row (moregen_occur env rm1.level) row_ext; - newty2 rm1.level (Tvariant row_ext) - in - if ext != rm1 then link_type rm1 ext; - false - in + begin match rm1.desc, rm2.desc with + Tunivar, Tunivar -> + unify_univar rm1 rm2 !univar_pairs + | Tunivar, _ | _, Tunivar -> + raise (Unify []) + | _ when static_row row1 -> () + | _ when may_inst -> + if not (static_row row2) then moregen_occur env rm1.level rm2; + let ext = + if r2 = [] then rm2 else + let row_ext = {row2 with row_fields = r2} in + iter_row (moregen_occur env rm1.level) row_ext; + newty2 rm1.level (Tvariant row_ext) + in + link_type rm1 ext + | Tconstr _, Tconstr _ -> + moregen inst_nongen type_pairs env rm1 rm2 + | _ -> raise (Unify []) + end; List.iter (fun (l,f1,f2) -> let f1 = row_field_repr f1 and f2 = row_field_repr f2 in @@ -2125,7 +2170,7 @@ and moregen_row inst_nongen type_pairs env row1 row2 = Rpresent(Some t1), Rpresent(Some t2) -> moregen inst_nongen type_pairs env t1 t2 | Rpresent None, Rpresent None -> () - | Reither(false, tl1, _, e1), Rpresent(Some t2) when not univ -> + | Reither(false, tl1, _, e1), Rpresent(Some t2) when may_inst -> set_row_field e1 f2; List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1 | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) -> @@ -2141,9 +2186,9 @@ and moregen_row inst_nongen type_pairs env row1 row2 = | [] -> if tl1 <> [] then raise (Unify []) end - | Reither(true, [], _, e1), Rpresent None when not univ -> + | Reither(true, [], _, e1), Rpresent None when may_inst -> set_row_field e1 f2 - | Reither(_, _, _, e1), Rabsent when not univ -> + | Reither(_, _, _, e1), Rabsent when may_inst -> set_row_field e1 f2 | Rabsent, Rabsent -> () | _ -> raise (Unify [])) @@ -2780,7 +2825,8 @@ let rec build_subtype env visited loops posi level t = Tobject _ when posi && not (opened_object t') -> let cl_abbr, body = find_cltype_for_path env p in let ty = - subst env !current_level abbrev None cl_abbr.type_params tl body in + subst env !current_level Public abbrev None + cl_abbr.type_params tl body in let ty = repr ty in let ty1, tl1 = match ty.desc with @@ -2839,7 +2885,6 @@ let rec build_subtype env visited loops posi level t = let level' = pred_enlarge level in let visited = t :: if level' < level then [] else filter_visited visited in - let bound = ref row.row_bound in let fields = filter_row_fields false row.row_fields in let fields = List.map @@ -2851,18 +2896,18 @@ let rec build_subtype env visited loops posi level t = orig, Unchanged | Rpresent(Some t) -> let (t', c) = build_subtype env visited loops posi level' t in - if posi && level > 0 then begin - bound := t' :: !bound; - (l, Reither(false, [t'], false, ref None)), c - end else - (l, Rpresent(Some t')), c + let f = + if posi && level > 0 + then Reither(false, [t'], false, ref None) + else Rpresent(Some t') + in (l, f), c | _ -> assert false) fields in let c = collect fields in let row = { row_fields = List.map fst fields; row_more = newvar(); - row_bound = !bound; row_closed = posi; row_fixed = false; + row_bound = (); row_closed = posi; row_fixed = false; row_name = if c > Unchanged then None else row.row_name } in (newty (Tvariant row), Changed) @@ -2925,6 +2970,12 @@ let subtypes = TypePairs.create 17 let subtype_error env trace = raise (Subtype (expand_trace env (List.rev trace), [])) +let private_abbrev env path = + try + let decl = Env.find_type path env in + decl.type_private = Private && decl.type_manifest <> None + with Not_found -> false + let rec subtype_rec env trace t1 t2 cstrs = let t1 = repr t1 in let t2 = repr t2 in @@ -2969,6 +3020,8 @@ let rec subtype_rec env trace t1 t2 cstrs = with Not_found -> (trace, t1, t2, !univar_pairs)::cstrs end + | (Tconstr(p1, tl1, _), _) when private_abbrev env p1 -> + subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs | (Tobject (f1, _), Tobject (f2, _)) when (object_row f1).desc = Tvar && (object_row f2).desc = Tvar -> (* Same row variable implies same object. *) @@ -2983,6 +3036,9 @@ let rec subtype_rec env trace t1 t2 cstrs = end | (Tpoly (u1, []), Tpoly (u2, [])) -> subtype_rec env trace u1 u2 cstrs + | (Tpoly (u1, tl1), Tpoly (u2, [])) -> + let _, u1' = instance_poly false tl1 u1 in + subtype_rec env trace u1' u2 cstrs | (Tpoly (u1, tl1), Tpoly (u2,tl2)) -> begin try enter_poly env univar_pairs u1 tl1 u2 tl2 @@ -3176,13 +3232,9 @@ let rec normalize_type_rec env ty = row.row_fields in let fields = List.sort (fun (p,_) (q,_) -> compare p q) - (List.filter (fun (_,fi) -> fi <> Rabsent) fields) - and bound = List.fold_left - (fun tyl ty -> if List.memq ty tyl then tyl else ty :: tyl) - [] (List.map repr row.row_bound) - in + (List.filter (fun (_,fi) -> fi <> Rabsent) fields) in log_type ty; - ty.desc <- Tvariant {row with row_fields = fields; row_bound = bound} + ty.desc <- Tvariant {row with row_fields = fields} | Tobject (fi, nm) -> begin match !nm with | None -> () @@ -3312,16 +3364,16 @@ let nondep_type_decl env mid id is_covariant decl = match decl.type_kind with Type_abstract -> Type_abstract - | Type_variant(cstrs, priv) -> + | Type_variant cstrs -> Type_variant(List.map (fun (c, tl) -> (c, List.map (nondep_type_rec env mid) tl)) - cstrs, priv) - | Type_record(lbls, rep, priv) -> + cstrs) + | Type_record(lbls, rep) -> Type_record( List.map (fun (c, mut, t) -> (c, mut, nondep_type_rec env mid t)) lbls, - rep, priv) + rep) with Not_found when is_covariant -> Type_abstract end; @@ -3334,6 +3386,7 @@ let nondep_type_decl env mid id is_covariant decl = with Not_found when is_covariant -> None end; + type_private = decl.type_private; type_variance = decl.type_variance; } in @@ -3341,9 +3394,9 @@ let nondep_type_decl env mid id is_covariant decl = List.iter unmark_type decl.type_params; begin match decl.type_kind with Type_abstract -> () - | Type_variant(cstrs, priv) -> + | Type_variant cstrs -> List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs - | Type_record(lbls, rep, priv) -> + | Type_record(lbls, rep) -> List.iter (fun (c, mut, t) -> unmark_type t) lbls end; begin match decl.type_manifest with diff --git a/typing/ctype.mli b/typing/ctype.mli index 3e57be887a..29349573e6 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -133,6 +133,9 @@ val apply: val expand_head_once: Env.t -> type_expr -> type_expr val expand_head: Env.t -> type_expr -> type_expr +val expand_head_opt: Env.t -> type_expr -> type_expr +(** The compiler's own version of [expand_head] necessary for type-based + optimisations. *) val full_expand: Env.t -> type_expr -> type_expr val enforce_constraints: Env.t -> type_expr -> unit diff --git a/typing/env.ml b/typing/env.ml index fc510ec04c..e349207186 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -44,6 +44,7 @@ type summary = type t = { values: (Path.t * value_description) Ident.tbl; + annotations: (Path.t * Annot.ident) Ident.tbl; constrs: constructor_description Ident.tbl; labels: label_description Ident.tbl; types: (Path.t * type_declaration) Ident.tbl; @@ -66,6 +67,7 @@ and module_components_repr = and structure_components = { mutable comp_values: (string, (value_description * int)) Tbl.t; + mutable comp_annotations: (string, (Annot.ident * int)) Tbl.t; mutable comp_constrs: (string, (constructor_description * int)) Tbl.t; mutable comp_labels: (string, (label_description * int)) Tbl.t; mutable comp_types: (string, (type_declaration * int)) Tbl.t; @@ -86,7 +88,7 @@ and functor_components = { } let empty = { - values = Ident.empty; constrs = Ident.empty; + values = Ident.empty; annotations = Ident.empty; constrs = Ident.empty; labels = Ident.empty; types = Ident.empty; modules = Ident.empty; modtypes = Ident.empty; components = Ident.empty; classes = Ident.empty; @@ -261,11 +263,32 @@ and find_class = and find_cltype = find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) +(* Find the manifest type associated to a type when appropriate: + - the type should be public or should have a private row, + - the type should have an associated manifest type. *) let find_type_expansion path env = let decl = find_type path env in match decl.type_manifest with - None -> raise Not_found + | Some body when decl.type_private = Public + || decl.type_kind <> Type_abstract + || Btype.has_constr_row body -> (decl.type_params, body) + (* The manifest type of Private abstract data types without + private row are still considered unknown to the type system. + Hence, this case is caught by the following clause that also handles + purely abstract data types without manifest type definition. *) + | _ -> raise Not_found + +(* Find the manifest type information associated to a type, i.e. + the necessary information for the compiler's type-based optimisations. + In particular, the manifest type associated to a private abstract type + is revealed for the sake of compiler's type-based optimisations. *) +let find_type_expansion_opt path env = + let decl = find_type path env in + match decl.type_manifest with + (* The manifest type of Private abstract data types can still get + an approximation using their manifest type. *) | Some body -> (decl.type_params, body) + | _ -> raise Not_found let find_modtype_expansion path env = match find_modtype path env with @@ -392,6 +415,8 @@ let lookup_simple proj1 proj2 lid env = let lookup_value = lookup (fun env -> env.values) (fun sc -> sc.comp_values) +let lookup_annot id e = + lookup (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e and lookup_constructor = lookup_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs) and lookup_label = @@ -427,20 +452,20 @@ let rec scrape_modtype mty env = let constructors_of_type ty_path decl = match decl.type_kind with - Type_variant(cstrs, priv) -> + Type_variant cstrs -> Datarepr.constructor_descrs (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) - cstrs priv + cstrs decl.type_private | Type_record _ | Type_abstract -> [] (* Compute label descriptions *) let labels_of_type ty_path decl = match decl.type_kind with - Type_record(labels, rep, priv) -> + Type_record(labels, rep) -> Datarepr.label_descrs (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) - labels rep priv + labels rep decl.type_private | Type_variant _ | Type_abstract -> [] (* Given a signature and a root path, prefix all idents in the signature @@ -488,7 +513,8 @@ let rec components_of_module env sub path mty = lazy(match scrape_modtype mty env with Tmty_signature sg -> let c = - { comp_values = Tbl.empty; comp_constrs = Tbl.empty; + { comp_values = Tbl.empty; comp_annotations = Tbl.empty; + comp_constrs = Tbl.empty; comp_labels = Tbl.empty; comp_types = Tbl.empty; comp_modules = Tbl.empty; comp_modtypes = Tbl.empty; comp_components = Tbl.empty; comp_classes = Tbl.empty; @@ -502,6 +528,11 @@ let rec components_of_module env sub path mty = let decl' = Subst.value_description sub decl in c.comp_values <- Tbl.add (Ident.name id) (decl', !pos) c.comp_values; + if !Clflags.annotations then begin + c.comp_annotations <- + Tbl.add (Ident.name id) (Annot.Iref_external, !pos) + c.comp_annotations; + end; begin match decl.val_kind with Val_prim _ -> () | _ -> incr pos end @@ -516,7 +547,7 @@ let rec components_of_module env sub path mty = List.iter (fun (name, descr) -> c.comp_labels <- Tbl.add name (descr, nopos) c.comp_labels) - (labels_of_type path decl'); + (labels_of_type path decl'); env := store_type_infos id path decl !env | Tsig_exception(id, decl) -> let decl' = Subst.exception_declaration sub decl in @@ -562,7 +593,8 @@ let rec components_of_module env sub path mty = fcomp_cache = Hashtbl.create 17 } | Tmty_ident p -> Structure_comps { - comp_values = Tbl.empty; comp_constrs = Tbl.empty; + comp_values = Tbl.empty; comp_annotations = Tbl.empty; + comp_constrs = Tbl.empty; comp_labels = Tbl.empty; comp_types = Tbl.empty; comp_modules = Tbl.empty; comp_modtypes = Tbl.empty; comp_components = Tbl.empty; comp_classes = Tbl.empty; @@ -575,6 +607,12 @@ and store_value id path decl env = values = Ident.add id (path, decl) env.values; summary = Env_value(env.summary, id, decl) } +and store_annot id path annot env = + if !Clflags.annotations then + { env with + annotations = Ident.add id (path, annot) env.annotations } + else env + and store_type id path info env = { env with constrs = @@ -655,6 +693,9 @@ let _ = let add_value id desc env = store_value id (Pident id) desc env +let add_annot id annot env = + store_annot id (Pident id) annot env + and add_type id info env = store_type id (Pident id) info env @@ -724,8 +765,9 @@ let open_signature root sg env = (fun env item p -> match item with Tsig_value(id, decl) -> - store_value (Ident.hide id) p + let e1 = store_value (Ident.hide id) p (Subst.value_description sub decl) env + in store_annot (Ident.hide id) p (Annot.Iref_external) e1 | Tsig_type(id, decl, _) -> store_type (Ident.hide id) p (Subst.type_declaration sub decl) env diff --git a/typing/env.mli b/typing/env.mli index 80f3764693..69de5414e0 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -32,11 +32,15 @@ val find_class: Path.t -> t -> class_declaration val find_cltype: Path.t -> t -> cltype_declaration val find_type_expansion: Path.t -> t -> type_expr list * type_expr +val find_type_expansion_opt: Path.t -> t -> type_expr list * type_expr +(* Find the manifest type information associated to a type for the sake + of the compiler's type-based optimisations. *) val find_modtype_expansion: Path.t -> t -> Types.module_type (* Lookup by long identifiers *) val lookup_value: Longident.t -> t -> Path.t * value_description +val lookup_annot: Longident.t -> t -> Path.t * Annot.ident val lookup_constructor: Longident.t -> t -> constructor_description val lookup_label: Longident.t -> t -> label_description val lookup_type: Longident.t -> t -> Path.t * type_declaration @@ -51,6 +55,7 @@ val lookup_continuation: Longident.t -> t -> Path.t * continuation_description (* 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 @@ -97,7 +102,7 @@ val save_signature: signature -> string -> string -> unit (* Arguments: signature, module name, file name. *) val save_signature_with_imports: signature -> string -> string -> (string * Digest.t) list -> unit - (* Arguments: signature, module name, file name, + (* Arguments: signature, module name, file name, imported units with their CRCs. *) (* Return the CRC of the interface of the given compilation unit *) @@ -146,4 +151,3 @@ val report_error: formatter -> error -> unit (* Forward declaration to break mutual recursion with Includemod. *) val check_modtype_inclusion: (t -> module_type -> Path.t -> module_type -> unit) ref - diff --git a/typing/includecore.ml b/typing/includecore.ml index f66e068f7e..de0faaebb0 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -37,8 +37,11 @@ let value_descriptions env vd1 vd2 = (* Inclusion between "private" annotations *) -let private_flags priv1 priv2 = - match (priv1, priv2) with (Private, Public) -> false | (_, _) -> true +let private_flags decl1 decl2 = + match decl1.type_private, decl2.type_private with + | Private, Public -> + decl2.type_kind = Type_abstract && decl2.type_manifest = None + | _, _ -> true (* Inclusion between manifest types (particularly for private row types) *) @@ -57,7 +60,7 @@ let type_manifest env ty1 params1 ty2 params2 = Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) -> let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in Ctype.equal env true (ty1::params1) (row2.row_more::params2) && - (match row1.row_more with {desc=Tvar|Tconstr _} -> true | _ -> false) && + (match row1.row_more with {desc=Tvar|Tconstr _} -> true | _ -> false) && let r1, r2, pairs = Ctype.merge_row_fields row1.row_fields row2.row_fields in (not row2.row_closed || @@ -93,17 +96,17 @@ let type_manifest env ty1 params1 ty2 params2 = let tl1, tl2 = List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in Ctype.equal env true (params1 @ tl1) (params2 @ tl2) - | _ -> + | _ -> Ctype.equal env true (ty1 :: params1) (ty2 :: params2) (* Inclusion between type declarations *) let type_declarations env id decl1 decl2 = decl1.type_arity = decl2.type_arity && + private_flags decl1 decl2 && begin match (decl1.type_kind, decl2.type_kind) with (_, Type_abstract) -> true - | (Type_variant (cstrs1, priv1), Type_variant (cstrs2, priv2)) -> - private_flags priv1 priv2 && + | (Type_variant cstrs1, Type_variant cstrs2) -> Misc.for_all2 (fun (cstr1, arg1) (cstr2, arg2) -> cstr1 = cstr2 && @@ -113,8 +116,7 @@ let type_declarations env id decl1 decl2 = (ty2::decl2.type_params)) arg1 arg2) cstrs1 cstrs2 - | (Type_record(labels1,rep1,priv1), Type_record(labels2,rep2,priv2)) -> - private_flags priv1 priv2 && + | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> rep1 = rep2 && Misc.for_all2 (fun (lbl1, mut1, ty1) (lbl2, mut2, ty2) -> @@ -137,9 +139,10 @@ let type_declarations env id decl1 decl2 = Ctype.equal env false [ty1] [ty2] end && if match decl2.type_kind with - | Type_record(_,_,priv) | Type_variant(_,priv) -> priv = Private + | Type_record (_,_) | Type_variant _ -> decl2.type_private = Private | Type_abstract -> - match decl2.type_manifest with None -> true + match decl2.type_manifest with + | None -> true | Some ty -> Btype.has_constr_row (Ctype.expand_head env ty) then List.for_all2 diff --git a/typing/includemod.ml b/typing/includemod.ml index 3f75546ea6..610025e5d0 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -208,8 +208,9 @@ and signatures env subst sig1 sig2 = | item2 :: rem -> let (id2, name2) = item_ident_name item2 in let name2, report = - match name2 with - Field_type s when let l = String.length s in + match item2, name2 with + Tsig_type (_, {type_manifest=None}, _), Field_type s + when let l = String.length s in l >= 4 && String.sub s (l-4) 4 = "#row" -> (* Do not report in case of failure, as the main type will generate an error *) diff --git a/typing/mtype.ml b/typing/mtype.ml index ac5e2424a9..95c995dcde 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -14,6 +14,7 @@ (* Operations on module types *) +open Asttypes open Path open Types @@ -48,9 +49,11 @@ and strengthen_sig env sg p = | Tsig_type(id, decl, rs) :: rem -> let newdecl = match decl.type_manifest with - Some ty when not (Btype.has_constr_row ty) -> decl + Some ty when decl.type_private = Public -> decl | _ -> - { decl with type_manifest = + { decl with + type_private = Public; + type_manifest = Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos), decl.type_params, ref Mnil))) } in diff --git a/typing/oprint.ml b/typing/oprint.ml index 9159a6015e..0d5823de4c 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -75,7 +75,7 @@ let print_out_value ppf tree = fprintf ppf "@[<1>%a@ (%a)@]" print_ident name (print_tree_list print_tree_1 ",") params | Oval_variant (name, Some param) -> - fprintf ppf "@[<2>`%s@ %a@]" name print_simple_tree param + fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param | tree -> print_simple_tree ppf tree and print_constr_param ppf = function | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0) diff --git a/typing/parmatch.ml b/typing/parmatch.ml index ece3dfe3f0..1597e810b8 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -45,7 +45,7 @@ let zero = make_pat (Tpat_constant (Const_int 0)) Ctype.none Env.empty (* p and q compatible means, there exists V that matches both *) -let is_absent tag row = Btype.row_field tag row = Rabsent +let is_absent tag row = Btype.row_field tag !row = Rabsent let is_absent_pat p = match p.pat_desc with | Tpat_variant (tag, _, row) -> is_absent tag row @@ -83,6 +83,7 @@ let rec compat p q = | _,Tpat_or (q1,q2,_) -> compat p q1 || compat p q2 | Tpat_constant c1, Tpat_constant c2 -> c1=c2 | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs + | Tpat_lazy p, Tpat_lazy q -> compat p q | Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) -> c1.cstr_tag = c2.cstr_tag && compats ps1 ps2 | Tpat_variant(l1,Some p1, r1), Tpat_variant(l2,Some p2,_) -> @@ -125,7 +126,7 @@ let get_type_descr ty tenv = let rec get_constr tag ty tenv = match get_type_descr ty tenv with - | {type_kind=Type_variant(constr_list, priv)} -> + | {type_kind=Type_variant constr_list} -> Datarepr.find_constr_by_tag tag constr_list | {type_manifest = Some _} -> get_constr tag (Ctype.expand_head_once tenv ty) tenv @@ -139,7 +140,7 @@ let find_label lbl lbls = let rec get_record_labels ty tenv = match get_type_descr ty tenv with - | {type_kind = Type_record(lbls, rep, priv)} -> lbls + | {type_kind = Type_record(lbls, rep)} -> lbls | {type_manifest = Some _} -> get_record_labels (Ctype.expand_head_once tenv ty) tenv | _ -> fatal_error "Parmatch.get_record_labels" @@ -164,7 +165,7 @@ let is_cons tag v = match get_constr_name tag v.pat_type v.pat_env with | "::" -> true | _ -> false - + let rec pretty_val ppf v = match v.pat_desc with | Tpat_any -> fprintf ppf "_" | Tpat_var x -> Ident.print ppf x @@ -204,6 +205,8 @@ let rec pretty_val ppf v = match v.pat_desc with | _ -> true) lvs) | Tpat_array vs -> fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs + | Tpat_lazy v -> + fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v | Tpat_alias (v,x) -> fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x | Tpat_or (v,w,_) -> @@ -269,6 +272,7 @@ let simple_match p1 p2 = float_of_string s1 = float_of_string s2 | Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2 | Tpat_tuple _, Tpat_tuple _ -> true + | Tpat_lazy _, Tpat_lazy _ -> true | Tpat_record _ , Tpat_record _ -> true | Tpat_array p1s, Tpat_array p2s -> List.length p1s = List.length p2s | _, (Tpat_any | Tpat_var(_)) -> true @@ -329,6 +333,7 @@ let rec simple_match_args p1 p2 = match p2.pat_desc with | Tpat_tuple(args) -> args | Tpat_record(args) -> extract_fields (record_arg p1) args | Tpat_array(args) -> args +| Tpat_lazy arg -> [arg] | (Tpat_any | Tpat_var(_)) -> begin match p1.pat_desc with Tpat_construct(_, args) -> omega_list args @@ -336,6 +341,7 @@ let rec simple_match_args p1 p2 = match p2.pat_desc with | Tpat_tuple(args) -> omega_list args | Tpat_record(args) -> omega_list args | Tpat_array(args) -> omega_list args + | Tpat_lazy _ -> [omega] | _ -> [] end | _ -> [] @@ -361,6 +367,8 @@ let rec normalize_pat q = match q.pat_desc with | Tpat_record (largs) -> make_pat (Tpat_record (List.map (fun (lbl,_) -> lbl,omega) largs)) q.pat_type q.pat_env + | Tpat_lazy _ -> + make_pat (Tpat_lazy omega) q.pat_type q.pat_env | Tpat_or _ -> fatal_error "Parmatch.normalize_pat" @@ -379,6 +387,7 @@ let discr_pat q pss = | ({pat_desc = (Tpat_any | Tpat_var _)}::_)::pss -> acc_pat acc pss | (({pat_desc = Tpat_tuple _} as p)::_)::_ -> normalize_pat p + | (({pat_desc = Tpat_lazy _} as p)::_)::_ -> normalize_pat p | (({pat_desc = Tpat_record largs} as p)::_)::pss -> let new_omegas = List.fold_left @@ -448,6 +457,12 @@ let do_set_args erase_mutable q r = match q with make_pat (Tpat_variant (l, arg, row)) q.pat_type q.pat_env:: rest +| {pat_desc = Tpat_lazy omega} -> + begin match r with + arg::rest -> + make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest + | _ -> fatal_error "Parmatch.do_set_args (lazy)" + end | {pat_desc = Tpat_array omegas} -> let args,rest = read_args omegas r in make_pat @@ -541,7 +556,7 @@ let filter_all pat0 pss = filter_omega (filter_rec (match pat0.pat_desc with - (Tpat_record(_) | Tpat_tuple(_)) -> [pat0,[]] + (Tpat_record(_) | Tpat_tuple(_) | Tpat_lazy(_)) -> [pat0,[]] | _ -> []) pss) pss @@ -585,24 +600,29 @@ let close_variant env row = row_closed = true; row_name = nm})) end +let row_of_pat pat = + match Ctype.expand_head pat.pat_env pat.pat_type with + {desc = Tvariant row} -> Btype.row_repr row + | _ -> assert false + (* Check whether the first column of env makes up a complete signature or not. -*) +*) let full_match closing env = match env with | ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _},_)},_)::_ -> false | ({pat_desc = Tpat_construct(c,_)},_) :: _ -> List.length env = c.cstr_consts + c.cstr_nonconsts -| ({pat_desc = Tpat_variant(_,_,row)},_) :: _ -> +| ({pat_desc = Tpat_variant _} as p,_) :: _ -> let fields = List.map (function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag | _ -> assert false) env in - let row = Btype.row_repr row in + let row = row_of_pat p in if closing && not row.row_fixed then (* closing=true, we are considering the variant as closed *) List.for_all @@ -625,6 +645,7 @@ let full_match closing env = match env with | ({pat_desc = Tpat_tuple(_)},_) :: _ -> true | ({pat_desc = Tpat_record(_)},_) :: _ -> true | ({pat_desc = Tpat_array(_)},_) :: _ -> false +| ({pat_desc = Tpat_lazy(_)},_) :: _ -> true | _ -> fatal_error "Parmatch.full_match" let extendable_match env = match env with @@ -738,17 +759,17 @@ let build_other ext env = match env with let all_tags = List.map (fun (p,_) -> get_tag p) env in pat_of_constrs p (complete_constrs p all_tags) end -| ({pat_desc = Tpat_variant(_,_,row)} as p,_) :: _ -> +| ({pat_desc = Tpat_variant (_,_,r)} as p,_) :: _ -> let tags = List.map (function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag | _ -> assert false) env in - let row = Btype.row_repr row in + let row = row_of_pat p in let make_other_pat tag const = let arg = if const then None else Some omega in - make_pat (Tpat_variant(tag, arg, row)) p.pat_type p.pat_env in + make_pat (Tpat_variant(tag, arg, r)) p.pat_type p.pat_env in begin match List.fold_left (fun others (tag,f) -> @@ -862,6 +883,7 @@ let rec has_instance p = match p.pat_desc with | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2 | Tpat_construct (_,ps) | Tpat_tuple ps | Tpat_array ps -> has_instances ps | Tpat_record lps -> has_instances (List.map snd lps) + | Tpat_lazy p -> has_instance p and has_instances = function | [] -> true @@ -999,8 +1021,8 @@ let rec pressure_variants tdefs = function else try_non_omega (filter_all q0 (mark_partial pss)) in begin match constrs, tdefs with - ({pat_desc=Tpat_variant(_,_,row)},_):: _, Some env -> - let row = Btype.row_repr row in + ({pat_desc=Tpat_variant _} as p,_):: _, Some env -> + let row = row_of_pat p in if row.row_fixed || pressure_variants None (filter_extra pss) then () else close_variant env row @@ -1294,6 +1316,7 @@ let rec le_pat p q = l1 = l2 | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs + | Tpat_lazy p, Tpat_lazy q -> le_pat p q | Tpat_record l1, Tpat_record l2 -> let ps,qs = records_args l1 l2 in le_pats ps qs @@ -1332,6 +1355,9 @@ let rec lub p q = match p.pat_desc,q.pat_desc with | Tpat_tuple ps, Tpat_tuple qs -> let rs = lubs ps qs in make_pat (Tpat_tuple rs) p.pat_type p.pat_env +| Tpat_lazy p, Tpat_lazy q -> + let r = lub p q in + make_pat (Tpat_lazy r) p.pat_type p.pat_env | Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) when c1.cstr_tag = c2.cstr_tag -> let rs = lubs ps1 ps2 in @@ -1565,6 +1591,8 @@ let rec collect_paths_from_pat r p = match p.pat_desc with | Tpat_variant (_, Some p, _) | Tpat_alias (p,_) -> collect_paths_from_pat r p | Tpat_or (p1,p2,_) -> collect_paths_from_pat (collect_paths_from_pat r p1) p2 +| Tpat_lazy p -> + collect_paths_from_pat r p (* @@ -1654,6 +1682,7 @@ let check_unused tdefs casel = do_rec [] casel +(*>JOCAML*) (***********************************************************************) (* Take a list of patterns as argument, test if each pattern @@ -1691,5 +1720,39 @@ let rec remove_binders p = match p.pat_desc with | Tpat_or (p1, p2, patho) -> { p with pat_desc = Tpat_or (remove_binders p1, remove_binders p2, patho) } +| Tpat_lazy q -> + { p with pat_desc = Tpat_lazy (remove_binders q) } and remove_binders_list ps = List.map remove_binders ps + +(*<JOCAML*) + +(*********************************) +(* Exported irrefutability tests *) +(*********************************) + +let irrefutable pat = le_pat pat omega + +(* An inactive pattern is a pattern whose matching needs only + trivial computations (tag/equality tests). + Patterns containing (lazy _) subpatterns are active. *) + +let rec inactive pat = match pat with +| Tpat_lazy _ -> + false +| Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) -> + true +| Tpat_tuple ps | Tpat_construct (_, ps) | Tpat_array ps -> + List.for_all (fun p -> inactive p.pat_desc) ps +| Tpat_alias (p,_) | Tpat_variant (_, Some p, _) -> + inactive p.pat_desc +| Tpat_record ldps -> + List.exists (fun (_, p) -> inactive p.pat_desc) ldps +| Tpat_or (p,q,_) -> + inactive p.pat_desc && inactive q.pat_desc + + +(* A `fluid' pattern is both irrefutable and inactive *) + +let fluid pat = irrefutable pat && inactive pat.pat_desc + diff --git a/typing/parmatch.mli b/typing/parmatch.mli index b1eaa0ace0..83fd8d7c7e 100644 --- a/typing/parmatch.mli +++ b/typing/parmatch.mli @@ -61,3 +61,8 @@ val useful: pattern list -> bool list (* replace all variables by wildcards (and rewrite p as x into p) *) val remove_binders : pattern -> pattern (*<JOCAML*) + +(* Irrefutability tests *) +val irrefutable : pattern -> bool +val fluid : pattern -> bool + diff --git a/typing/predef.ml b/typing/predef.ml index 31098442c6..aee1f1742a 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -92,24 +92,28 @@ let build_initial_env add_type add_exception empty_env = {type_params = []; type_arity = 0; type_kind = Type_abstract; + type_private = Public; type_manifest = None; type_variance = []} and decl_bool = {type_params = []; type_arity = 0; - type_kind = Type_variant(["false",[]; "true",[]], Public); + type_kind = Type_variant(["false", []; "true", []]); + type_private = Public; type_manifest = None; type_variance = []} and decl_unit = {type_params = []; type_arity = 0; - type_kind = Type_variant(["()",[]], Public); + type_kind = Type_variant(["()", []]); + type_private = Public; type_manifest = None; type_variance = []} and decl_exn = {type_params = []; type_arity = 0; - type_kind = Type_variant([], Public); + type_kind = Type_variant []; + type_private = Public; type_manifest = None; type_variance = []} and decl_array = @@ -117,6 +121,7 @@ let build_initial_env add_type add_exception empty_env = {type_params = [tvar]; type_arity = 1; type_kind = Type_abstract; + type_private = Public; type_manifest = None; type_variance = [true, true, true]} and decl_list = @@ -124,7 +129,8 @@ let build_initial_env add_type add_exception empty_env = {type_params = [tvar]; type_arity = 1; type_kind = - Type_variant(["[]", []; "::", [tvar; type_list tvar]], Public); + Type_variant(["[]", []; "::", [tvar; type_list tvar]]); + type_private = Public; type_manifest = None; type_variance = [true, false, false]} and decl_format6 = @@ -134,6 +140,7 @@ let build_initial_env add_type add_exception empty_env = ]; type_arity = 6; type_kind = Type_abstract; + type_private = Public; type_manifest = None; type_variance = [ true, true, true; true, true, true; @@ -144,7 +151,8 @@ let build_initial_env add_type add_exception empty_env = let tvar = newgenvar() in {type_params = [tvar]; type_arity = 1; - type_kind = Type_variant(["None", []; "Some", [tvar]], Public); + type_kind = Type_variant(["None", []; "Some", [tvar]]); + type_private = Public; type_manifest = None; type_variance = [true, false, false]} and decl_lazy_t = @@ -152,6 +160,7 @@ let build_initial_env add_type add_exception empty_env = {type_params = [tvar]; type_arity = 1; type_kind = Type_abstract; + type_private = Public; type_manifest = None; type_variance = [true, false, false]} in diff --git a/typing/primitive.ml b/typing/primitive.ml index fbbdb05b11..3d7ab5f7cb 100644 --- a/typing/primitive.ml +++ b/typing/primitive.ml @@ -54,3 +54,11 @@ let description_list p = in let list = if p.prim_native_float then "float" :: list else list in List.rev list + +let native_name p = + if p.prim_native_name <> "" + then p.prim_native_name + else p.prim_name + +let byte_name p = + p.prim_name diff --git a/typing/primitive.mli b/typing/primitive.mli index e89678aec7..8446037f40 100644 --- a/typing/primitive.mli +++ b/typing/primitive.mli @@ -24,3 +24,6 @@ type description = val parse_declaration: int -> string list -> description val description_list: description -> string list + +val native_name: description -> string +val byte_name: description -> string diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 918fbfa86e..b495105a7c 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -96,7 +96,7 @@ let rec safe_repr v = function let rec list_of_memo = function Mnil -> [] - | Mcons (p, t1, t2, rem) -> p :: list_of_memo rem + | Mcons (priv, p, t1, t2, rem) -> p :: list_of_memo rem | Mlink rem -> list_of_memo !rem let visited = ref [] @@ -247,7 +247,7 @@ let rec mark_loops_rec visited ty = | Some(p, tyl) when namable_row row -> List.iter (mark_loops_rec visited) tyl | _ -> - iter_row (mark_loops_rec visited) {row with row_bound = []} + iter_row (mark_loops_rec visited) row end | Tobject (fi, nm) -> if List.memq px !visited_objects then add_alias px else @@ -521,10 +521,10 @@ let rec tree_of_type_decl id decl = in begin match decl.type_kind with | Type_abstract -> () - | Type_variant ([], _) -> () - | Type_variant (cstrs, priv) -> + | Type_variant [] -> () + | Type_variant cstrs -> List.iter (fun (_, args) -> List.iter mark_loops args) cstrs - | Type_record(l, rep, priv) -> + | Type_record(l, rep) -> List.iter (fun (_, _, ty) -> mark_loops ty) l end; @@ -541,8 +541,8 @@ let rec tree_of_type_decl id decl = None -> true | Some ty -> has_constr_row ty end - | Type_variant(_,p) | Type_record(_,_,p) -> - p = Private + | Type_variant _ | Type_record(_,_) -> + decl.type_private = Private in let vari = List.map2 @@ -567,13 +567,14 @@ let rec tree_of_type_decl id decl = begin match ty_manifest with | None -> (Otyp_abstract, Public) | Some ty -> - tree_of_typexp false ty, - (if has_constr_row ty then Private else Public) + tree_of_typexp false ty, decl.type_private end - | Type_variant(cstrs, priv) -> - tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)), priv - | Type_record(lbls, rep, priv) -> - tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), priv + | Type_variant cstrs -> + tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)), + decl.type_private + | Type_record(lbls, rep) -> + tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), + decl.type_private in (name, args, ty, priv, constraints) diff --git a/typing/stypes.ml b/typing/stypes.ml index d762b576cc..4d1166fe5b 100644 --- a/typing/stypes.ml +++ b/typing/stypes.ml @@ -21,16 +21,19 @@ interesting in case of errors. *) +open Annot;; open Format;; open Lexing;; open Location;; open Typedtree;; -type type_info = - Ti_pat of pattern +type annotation = + | Ti_pat of pattern | Ti_expr of expression | Ti_class of class_expr | Ti_mod of module_expr + | An_call of Location.t * Annot.call + | An_ident of Location.t * string * Annot.ident ;; let get_location ti = @@ -39,18 +42,20 @@ let get_location ti = | Ti_expr e -> e.exp_loc | Ti_class c -> c.cl_loc | Ti_mod m -> m.mod_loc + | An_call (l, k) -> l + | An_ident (l, s, k) -> l ;; -let type_info = ref ([] : type_info list);; +let annotations = ref ([] : annotation list);; let phrases = ref ([] : Location.t list);; let record ti = - if !Clflags.save_types && not (get_location ti).Location.loc_ghost then - type_info := ti :: !type_info + if !Clflags.annotations && not (get_location ti).Location.loc_ghost then + annotations := ti :: !annotations ;; let record_phrase loc = - if !Clflags.save_types then phrases := loc :: !phrases; + if !Clflags.annotations then phrases := loc :: !phrases; ;; (* comparison order: @@ -67,7 +72,17 @@ let cmp_ti_inner_first ti1 ti2 = ;; let print_position pp pos = - fprintf pp "%S %d %d %d" pos.pos_fname pos.pos_lnum pos.pos_bol pos.pos_cnum; + if pos = dummy_pos then + fprintf pp "--" + else + fprintf pp "%S %d %d %d" pos.pos_fname pos.pos_lnum pos.pos_bol + pos.pos_cnum; +;; + +let print_location pp loc = + print_position pp loc.loc_start; + fprintf pp " "; + print_position pp loc.loc_end; ;; let sort_filter_phrases () = @@ -93,38 +108,60 @@ let rec printtyp_reset_maybe loc = | _ -> () ;; +let call_kind_string k = + match k with + | Tail -> "tail" + | Stack -> "stack" + | Inline -> "inline" +;; + +let print_ident_annot pp str k = + match k with + | Idef l -> fprintf pp "def %s %a@." str print_location l; + | Iref_internal l -> fprintf pp "int_ref %s %a@." str print_location l; + | Iref_external -> fprintf pp "ext_ref %s@." str; +;; (* The format of the annotation file is documented in emacs/caml-types.el. *) -let print_info pp ti = +let print_info pp prev_loc ti = match ti with - | Ti_class _ | Ti_mod _ -> () + | Ti_class _ | Ti_mod _ -> prev_loc | Ti_pat {pat_loc = loc; pat_type = typ} | Ti_expr {exp_loc = loc; exp_type = typ} -> - print_position pp loc.loc_start; - fprintf pp " "; - print_position pp loc.loc_end; - fprintf pp "@.type(@. "; + if loc <> prev_loc then fprintf pp "%a@." print_location loc; + fprintf pp "type(@. "; printtyp_reset_maybe loc; Printtyp.mark_loops typ; Printtyp.type_sch pp typ; fprintf pp "@.)@."; + loc + | An_call (loc, k) -> + if loc <> prev_loc then fprintf pp "%a@." print_location loc; + fprintf pp "call(@. %s@.)@." (call_kind_string k); + loc + | An_ident (loc, str, k) -> + if loc <> prev_loc then fprintf pp "%a@." print_location loc; + fprintf pp "ident(@. "; + print_ident_annot pp str k; + fprintf pp ")@."; + loc ;; let get_info () = - let info = List.fast_sort cmp_ti_inner_first !type_info in - type_info := []; + let info = List.fast_sort cmp_ti_inner_first !annotations in + annotations := []; info ;; let dump filename = - if !Clflags.save_types then begin + if !Clflags.annotations then begin let info = get_info () in let pp = formatter_of_out_channel (open_out filename) in sort_filter_phrases (); - List.iter (print_info pp) info; + ignore (List.fold_left (print_info pp) Location.none info); phrases := []; end else begin - type_info := []; + annotations := []; end; ;; diff --git a/typing/stypes.mli b/typing/stypes.mli index ed5fa9149e..32f92c1d71 100644 --- a/typing/stypes.mli +++ b/typing/stypes.mli @@ -18,16 +18,18 @@ open Typedtree;; -type type_info = - Ti_pat of pattern +type annotation = + | Ti_pat of pattern | Ti_expr of expression | Ti_class of class_expr | Ti_mod of module_expr + | An_call of Location.t * Annot.call + | An_ident of Location.t * string * Annot.ident ;; -val record : type_info -> unit;; +val record : annotation -> unit;; val record_phrase : Location.t -> unit;; val dump : string -> unit;; -val get_location : type_info -> Location.t;; -val get_info : unit -> type_info list;; +val get_location : annotation -> Location.t;; +val get_info : unit -> annotation list;; diff --git a/typing/subst.ml b/typing/subst.ml index 25f557ec52..6b1282697a 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -124,8 +124,6 @@ let rec typexp s ty = (* Return a new copy *) let row = copy_row (typexp s) true row (not dup) more' in - let row = - if s.for_saving then {row with row_bound = []} else row in match row.row_name with Some (p, tl) -> Tvariant {row with row_name = Some (type_path s p, tl)} @@ -154,22 +152,22 @@ let type_declaration s decl = type_kind = begin match decl.type_kind with Type_abstract -> Type_abstract - | Type_variant (cstrs, priv) -> + | Type_variant cstrs -> Type_variant( List.map (fun (n, args) -> (n, List.map (typexp s) args)) - cstrs, - priv) - | Type_record(lbls, rep, priv) -> + cstrs) + | Type_record(lbls, rep) -> Type_record( List.map (fun (n, mut, arg) -> (n, mut, typexp s arg)) lbls, - rep, priv) + rep) end; type_manifest = begin match decl.type_manifest with None -> None | Some ty -> Some(typexp s ty) end; + type_private = decl.type_private; type_variance = decl.type_variance; } in diff --git a/typing/subst.mli b/typing/subst.mli index b2220bb49e..d313853251 100644 --- a/typing/subst.mli +++ b/typing/subst.mli @@ -38,6 +38,9 @@ val add_modtype: Ident.t -> module_type -> t -> t val for_saving: t -> t val reset_for_saving: unit -> unit +val module_path: t -> Path.t -> Path.t +val type_path: t -> Path.t -> Path.t + val type_expr: t -> type_expr -> type_expr val class_type: t -> class_type -> class_type val value_description: t -> value_description -> value_description diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 947f4271a3..03b3b62171 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -561,7 +561,7 @@ let rec class_field cl_num self_type meths vars | Pcf_let (rec_flag, sdefs, loc) -> let (defs, val_env) = try - Typecore.type_let val_env rec_flag sdefs + Typecore.type_let val_env rec_flag sdefs None with Ctype.Unify [(ty, _)] -> raise(Error(loc, Make_nongen_seltype ty)) in @@ -673,7 +673,8 @@ and class_structure cl_num final val_env met_env loc (spat, str) = Vars.fold (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l) sign.cty_vars [] in - if mets <> [] then raise(Error(loc, Virtual_class(true, mets, vals))); + if mets <> [] || vals <> [] then + raise(Error(loc, Virtual_class(true, mets, vals))); let self_methods = List.fold_right (fun (lab,kind,ty) rem -> @@ -782,7 +783,7 @@ and class_expr cl_num val_env met_env scl = class_expr cl_num val_env met_env sfun | Pcl_fun (l, None, spat, scl') -> if !Clflags.principal then Ctype.begin_def (); - let (pat, pv, val_env, met_env) = + let (pat, pv, val_env', met_env) = Typecore.type_class_arg_pattern cl_num val_env met_env l spat in if !Clflags.principal then begin @@ -793,7 +794,7 @@ and class_expr cl_num val_env met_env scl = List.map (function (id, id', ty) -> (id, - Typecore.type_exp val_env + Typecore.type_exp val_env' {pexp_desc = Pexp_ident (Longident.Lident (Ident.name id)); pexp_loc = Location.none})) pv @@ -810,7 +811,7 @@ and class_expr cl_num val_env met_env scl = exp_type = Ctype.none; exp_env = Env.empty }] in Ctype.raise_nongen_level (); - let cl = class_expr cl_num val_env met_env scl' in + let cl = class_expr cl_num val_env' met_env scl' in Ctype.end_def (); if Btype.is_optional l && not_function cl.cl_type then Location.prerr_warning pat.pat_loc @@ -910,7 +911,7 @@ and class_expr cl_num val_env met_env scl = | Pcl_let (rec_flag, sdefs, scl') -> let (defs, val_env) = try - Typecore.type_let val_env rec_flag sdefs + Typecore.type_let val_env rec_flag sdefs None with Ctype.Unify [(ty, _)] -> raise(Error(scl.pcl_loc, Make_nongen_seltype ty)) in @@ -1007,6 +1008,7 @@ let temp_abbrev env id arity = {type_params = !params; type_arity = arity; type_kind = Type_abstract; + type_private = Public; type_manifest = Some ty; type_variance = List.map (fun _ -> true, true, true) !params} env @@ -1217,6 +1219,7 @@ let class_infos define_class kind {type_params = obj_params; type_arity = List.length obj_params; type_kind = Type_abstract; + type_private = Public; type_manifest = Some obj_ty; type_variance = List.map (fun _ -> true, true, true) obj_params} in @@ -1229,6 +1232,7 @@ let class_infos define_class kind {type_params = cl_params; type_arity = List.length cl_params; type_kind = Type_abstract; + type_private = Public; type_manifest = Some cl_ty; type_variance = List.map (fun _ -> true, true, true) cl_params} in @@ -1475,16 +1479,16 @@ let report_error ppf = function "This pattern cannot match self: it only matches values of type" Printtyp.type_expr ty | Unbound_class cl -> - fprintf ppf "Unbound class@ %a" + fprintf ppf "@[Unbound class@ %a@]" Printtyp.longident cl | Unbound_class_2 cl -> - fprintf ppf "The class@ %a@ is not yet completely defined" + fprintf ppf "@[The class@ %a@ is not yet completely defined@]" Printtyp.longident cl | Unbound_class_type cl -> - fprintf ppf "Unbound class type@ %a" + fprintf ppf "@[Unbound class type@ %a@]" Printtyp.longident cl | Unbound_class_type_2 cl -> - fprintf ppf "The class type@ %a@ is not yet completely defined" + fprintf ppf "@[The class type@ %a@ is not yet completely defined@]" Printtyp.longident cl | Abbrev_type_clash (abbrev, actual, expected) -> (* XXX Afficher une trace ? *) diff --git a/typing/typecore.ml b/typing/typecore.ml index 6d8fbc4784..7d41c3277b 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -30,7 +30,7 @@ type error = | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * (type_expr * type_expr) list | Pattern_type_clash of (type_expr * type_expr) list - | Multiply_bound_variable + | Multiply_bound_variable of string | Orpat_vars of Ident.t | Expr_type_clash of (type_expr * type_expr) list | Apply_non_function of type_expr @@ -139,7 +139,7 @@ let rec extract_label_names sexp env ty = | Tconstr (path, _, _) -> let td = Env.find_type path env in begin match td.type_kind with - | Type_record (fields, _, _) -> + | Type_record (fields, _) -> List.map (fun (name, _, _) -> name) fields | Type_abstract when td.type_manifest <> None -> extract_label_names sexp env (expand_head env ty) @@ -163,10 +163,13 @@ let unify_pat env pat expected_ty = (* make all Reither present in open variants *) let finalize_variant pat = match pat.pat_desc with - Tpat_variant(tag, opat, row) -> - let row = row_repr row in - let field = row_field tag row in - begin match field with + Tpat_variant(tag, opat, r) -> + let row = + match expand_head pat.pat_env pat.pat_type with + {desc = Tvariant row} -> r := row; row_repr row + | _ -> assert false + in + begin match row_field tag row with | Rabsent -> assert false | Reither (true, [], _, e) when not row.row_closed -> set_row_field e (Rpresent None) @@ -179,10 +182,10 @@ let finalize_variant pat = set_row_field e (Reither (c, [], false, ref None)) | _ -> () end; - (* Force check of well-formedness *) - unify_pat pat.pat_env pat + (* Force check of well-formedness WHY? *) + (* unify_pat pat.pat_env pat (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false; - row_bound=[]; row_fixed=false; row_name=None})); + row_bound=(); row_fixed=false; row_name=None})); *) | _ -> () let rec iter_pattern f p = @@ -199,22 +202,30 @@ let has_variants p = (* pattern environment *) -let pattern_variables = ref ([]: (Ident.t * type_expr) list) +let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t) list) let pattern_force = ref ([] : (unit -> unit) list) -let reset_pattern () = +let pattern_scope = ref (None : Annot.ident option);; + +let reset_pattern scope = pattern_variables := []; - pattern_force := [] + pattern_force := []; + pattern_scope := scope; +;; let enter_variable loc name ty = - if List.exists (fun (id, _) -> Ident.name id = name) !pattern_variables - then raise(Error(loc, Multiply_bound_variable)); + 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 = @@ -224,7 +235,7 @@ let enter_orpat_variables loc env p1_vs p2_vs = and p2_vs = sort_pattern_variables p2_vs in let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with - | (x1,t1)::rem1, (x2,t2)::rem2 when Ident.equal x1 x2 -> + | (x1,t1,l1)::rem1, (x2,t2,l2)::rem2 when Ident.equal x1 x2 -> if x1==x2 then unify_vars rem1 rem2 else begin @@ -237,9 +248,9 @@ let enter_orpat_variables loc env p1_vs p2_vs = (x2,x1)::unify_vars rem1 rem2 end | [],[] -> [] - | (x,_)::_, [] -> raise (Error (loc, Orpat_vars x)) - | [],(x,_)::_ -> raise (Error (loc, Orpat_vars x)) - | (x,_)::_, (y,_)::_ -> + | (x,_,_)::_, [] -> raise (Error (loc, Orpat_vars x)) + | [],(x,_,_)::_ -> raise (Error (loc, Orpat_vars x)) + | (x,_,_)::_, (y,_,_)::_ -> let min_var = if Ident.name x < Ident.name y then x else y in @@ -263,7 +274,7 @@ let rec build_as_type env p = | Tpat_variant(l, p', _) -> let ty = may_map (build_as_type env) p' in newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar(); - row_bound=[]; row_name=None; + row_bound=(); row_name=None; row_fixed=false; row_closed=false}) | Tpat_record lpl -> let lbl = fst(List.hd lpl) in @@ -273,7 +284,10 @@ let rec build_as_type env p = let do_label lbl = let _, ty_arg, ty_res = instance_label false lbl in unify_pat env {p with pat_type = ty} ty_res; - if lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl then begin + let refinable = + lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl && + match (repr lbl.lbl_arg).desc with Tpoly _ -> false | _ -> true in + if refinable then begin let arg = List.assoc lbl.lbl_pos ppl in unify_pat env {arg with pat_type = build_as_type env arg} ty_arg end else begin @@ -283,21 +297,18 @@ let rec build_as_type env p = end in Array.iter do_label lbl.lbl_all; ty - | Tpat_or(p1, p2, path) -> - let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in - unify_pat env {p2 with pat_type = ty2} ty1; - begin match path with None -> () - | Some path -> - let td = try Env.find_type path env with Not_found -> assert false in - let params = List.map (fun _ -> newvar()) td.type_params in - match expand_head env (newty (Tconstr (path, params, ref Mnil))) - with {desc=Tvariant row} when static_row row -> - unify_pat env {p1 with pat_type = ty1} - (newty (Tvariant{row with row_closed=false; row_more=newvar()})) - | _ -> () - end; - ty1 - | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_array _ -> p.pat_type + | Tpat_or(p1, p2, row) -> + begin match row with + None -> + let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in + unify_pat env {p2 with pat_type = ty2} ty1; + ty1 + | Some row -> + 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 _ | Tpat_lazy _ -> p.pat_type let build_or_pat env loc lid = let path, decl = @@ -306,14 +317,12 @@ let build_or_pat env loc lid = raise(Typetexp.Error(loc, Typetexp.Unbound_type_constructor lid)) in let tyl = List.map (fun _ -> newvar()) decl.type_params in - let fields = + let row0 = let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in match ty.desc with - Tvariant row when static_row row -> - (row_repr row).row_fields + Tvariant row when static_row row -> row | _ -> raise(Error(loc, Not_a_variant_type lid)) in - let bound = ref [] in let pats, fields = List.fold_left (fun (pats,fields) (l,f) -> @@ -322,21 +331,21 @@ let build_or_pat env loc lid = (l,None) :: pats, (l, Reither(true,[], true, ref None)) :: fields | Rpresent (Some ty) -> - bound := ty :: !bound; (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; pat_type=ty}) :: pats, (l, Reither(false, [ty], true, ref None)) :: fields | _ -> pats, fields) - ([],[]) fields in + ([],[]) (row_repr row0).row_fields in let row = - { row_fields = List.rev fields; row_more = newvar(); row_bound = !bound; + { row_fields = List.rev fields; row_more = newvar(); row_bound = (); row_closed = false; row_fixed = false; row_name = Some (path, tyl) } in let ty = newty (Tvariant row) in let gloc = {loc with Location.loc_ghost=true} in + let row' = ref {row with row_more=newvar()} in let pats = - List.map (fun (l,p) -> {pat_desc=Tpat_variant(l,p,row); pat_loc=gloc; + List.map (fun (l,p) -> {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc; pat_env=env; pat_type=ty}) pats in @@ -345,7 +354,7 @@ let build_or_pat env loc lid = | pat :: pats -> let r = List.fold_left - (fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some path); + (fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some row0); pat_loc=gloc; pat_env=env; pat_type=ty}) pat pats in rp { r with pat_loc = loc } @@ -418,7 +427,7 @@ let rec type_pat env sp = None -> [] | Some {ppat_desc = Ppat_tuple spl} when explicit_arity -> spl | Some {ppat_desc = Ppat_tuple spl} when constr.cstr_arity > 1 -> spl - | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity > 1 -> + | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 -> replicate_list sp constr.cstr_arity | Some sp -> [sp] in if List.length sargs <> constr.cstr_arity then @@ -437,13 +446,13 @@ let rec type_pat env sp = let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type] in let row = { row_fields = [l, Reither(arg = None, arg_type, true, ref None)]; - row_bound = arg_type; + row_bound = (); row_closed = false; row_more = newvar (); row_fixed = false; row_name = None } in rp { - pat_desc = Tpat_variant(l, arg, row); + pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()}); pat_loc = sp.ppat_loc; pat_type = newty (Tvariant row); pat_env = env } @@ -514,6 +523,13 @@ let rec type_pat env sp = pat_loc = sp.ppat_loc; pat_type = p1.pat_type; pat_env = env } + | Ppat_lazy sp1 -> + let p1 = type_pat env sp1 in + rp { + pat_desc = Tpat_lazy p1; + pat_loc = sp.ppat_loc; + pat_type = instance (Predef.type_lazy_t p1.pat_type); + pat_env = env } | Ppat_constraint(sp, sty) -> let p = type_pat env sp in let ty, force = Typetexp.transl_simple_type_delayed env sty in @@ -529,18 +545,20 @@ let get_ref r = let add_pattern_variables env = let pv = get_ref pattern_variables in List.fold_right - (fun (id, ty) env -> - Env.add_value id {val_type = ty; val_kind = Val_reg} env) + (fun (id, ty, loc) env -> + let e1 = Env.add_value id {val_type = ty; val_kind = Val_reg} env in + Env.add_annot id (Annot.Iref_internal loc) e1; + ) pv env -let type_pattern env spat = - reset_pattern (); +let type_pattern env spat scope = + reset_pattern scope; let pat = type_pat env spat in let new_env = add_pattern_variables env in (pat, new_env, get_ref pattern_force) -let type_pattern_list env spatl = - reset_pattern (); +let type_pattern_list env spatl scope = + reset_pattern scope; let patl = List.map (type_pat env) spatl in let new_env = add_pattern_variables env in (patl, new_env, get_ref pattern_force) @@ -551,22 +569,25 @@ let type_pattern_list env spatl = (* + linearity is checked *) (**************************) -(* All identifiers created by a set of join defininitions *) +(* All identifiers created by a set of join definitions *) +let def_scope = ref (None : Annot.ident option);; let def_ids = ref [] -let reset_def () = def_ids := [] +let reset_def scp = + def_scope := scp ; + def_ids := [] (* All channels defined by a join definition *) -let auto_chans = ref ([] : (Ident.t * type_expr) list) +let auto_chans = ref ([] : (Ident.t * type_expr * Location.t) list) +let reset_auto () = auto_chans := [] -let reset_auto () = - auto_chans := [] -let reaction_chans = ref [] +(* All channels occuring in a join-pattern *) +let reaction_chans = ref ([] : string list) -let reset_reaction () = +let reset_reaction scp = reaction_chans := [] ; - reset_pattern () + reset_pattern scp (* get or create channel identifier *) let create_channel chan = @@ -576,13 +597,20 @@ let create_channel chan = (* Channels must differ from other ids in set of join definitions *) let p id = Ident.name id = name in if List.exists p !def_ids then - raise (Error (chan.pjident_loc, Multiply_bound_variable)) ; + raise (Error (chan.pjident_loc, Multiply_bound_variable name)) ; let id = Ident.create chan.pjident_desc - and ty = newvar() in + and ty = newvar() + and loc = chan.pjident_loc in def_ids := id :: !def_ids ; - auto_chans := (id, ty) :: !auto_chans ; + auto_chans := (id, ty, loc) :: !auto_chans ; + begin + let name = chan.pjident_desc in + match !def_scope with + | None -> () + | Some s -> Stypes.record (Stypes.An_ident (loc, name, s)); + end; (id, ty) - | (id, ty)::rem -> + | (id, ty, _)::rem -> if Ident.name id = name then (id, ty) else @@ -593,10 +621,8 @@ let enter_channel chan = (* Channels must differ from other channels in reaction rule *) let name = chan.pjident_desc in let p id = id = name in - if - List.exists p !reaction_chans - then - raise (Error (chan.pjident_loc, Multiply_bound_variable)) ; + if List.exists p !reaction_chans then + raise (Error (chan.pjident_loc, Multiply_bound_variable name)) ; reaction_chans := name :: !reaction_chans ; create_channel chan @@ -608,14 +634,20 @@ let mk_jident id loc ty env = jident_env = env; } -let type_auto_lhs env {pjauto_desc=sauto ; pjauto_loc=auto_loc} = +let rec get_type id env = match env with +| [] -> assert false +| (jd,ty,loc)::env -> + if Ident.same id jd then ty,loc + else get_type id env + +let type_auto_lhs env scope {pjauto_desc=sauto ; pjauto_loc=auto_loc} = (* Type patterns *) reset_auto () ; let auto = List.map (fun cl -> - reset_reaction () ; let sjpats, g = cl.pjclause_desc in + reset_reaction (Some (Annot.Idef g.pexp_loc)) ; let jpats = List.map (fun sjpat -> @@ -632,17 +664,15 @@ let type_auto_lhs env {pjauto_desc=sauto ; pjauto_loc=auto_loc} = sauto in (* get orginal channel names now *) let env = get_ref auto_chans in - let original = List.map fst env in + let original = List.map (fun (id,_,_) -> id) env in (* compile algebraic pattern in joinpatterns *) let (disps, reacs), new_names = Joinmatching.compile auto_loc auto in (* collect all names *) - let get_type id env = - try List.assoc id env with Not_found -> assert false in let env = List.fold_right (fun (id, ids) r -> - let ty = get_type id env in - List.fold_right (fun id r -> (id,ty)::r) ids r) + let ty,loc = get_type id env in + List.fold_right (fun id r -> (id,ty,loc)::r) ids r) new_names env in (* allocate names for guarded processes *) let disps = @@ -678,7 +708,7 @@ let type_auto_lhs env {pjauto_desc=sauto ; pjauto_loc=auto_loc} = let auto_count = ref 0 in let chan_names = List.map - (fun (id, ty) -> + (fun (id, ty, _) -> try let g = List.assoc id alone_env in id,(ty, Alone g) @@ -692,20 +722,20 @@ let type_auto_lhs env {pjauto_desc=sauto ; pjauto_loc=auto_loc} = (!auto_count, original, chan_names), (disps, reacs, fwds) -let rec do_type_autos_lhs env = function +let rec do_type_autos_lhs env scope = function | [] -> [] | sauto::rem -> - let r = type_auto_lhs env sauto in - r::do_type_autos_lhs env rem + let r = type_auto_lhs env scope sauto in + r::do_type_autos_lhs env scope rem -let type_autos_lhs env autos = - reset_def () ; - do_type_autos_lhs env autos +let type_autos_lhs env autos scope = + reset_def scope ; + do_type_autos_lhs env scope autos (*< JOCAML *) 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]; @@ -715,7 +745,7 @@ let type_class_arg_pattern cl_num val_env met_env l spat = if is_optional l then unify_pat val_env pat (type_option (newvar ())); let (pv, met_env) = List.fold_right - (fun (id, ty) (pv, env) -> + (fun (id, ty, loc) (pv, env) -> let id' = Ident.create (Ident.name id) in ((id', id, ty)::pv, Env.add_value id' {val_type = ty; @@ -733,7 +763,7 @@ let type_self_pattern cl_num privty val_env met_env par_env spat = mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")), "selfpat-" ^ cl_num)) in - reset_pattern (); + reset_pattern None; let pat = type_pat val_env spat in List.iter (fun f -> f()) (get_ref pattern_force); let meths = ref Meths.empty in @@ -742,7 +772,7 @@ let type_self_pattern cl_num privty val_env met_env par_env spat = pattern_variables := []; let (val_env, met_env, par_env) = List.fold_right - (fun (id, ty) (val_env, met_env, par_env) -> + (fun (id, ty, loc) (val_env, met_env, par_env) -> (Env.add_value id {val_type = ty; val_kind = Val_unbound} val_env, Env.add_value id {val_type = ty; val_kind = Val_self (meths, vars, cl_num, privty)} @@ -756,8 +786,11 @@ let delayed_checks = ref [] let reset_delayed_checks () = delayed_checks := [] let add_delayed_check f = delayed_checks := f :: !delayed_checks let force_delayed_checks () = + (* checks may change type levels *) + let snap = Btype.snapshot () in List.iter (fun f -> f ()) (List.rev !delayed_checks); - reset_delayed_checks () + reset_delayed_checks (); + Btype.backtrack snap (* Generalization criterion for expressions *) @@ -786,6 +819,7 @@ let rec is_nonexpansive exp = | Texp_array [] -> true | Texp_ifthenelse(cond, ifso, ifnot) -> is_nonexpansive ifso && is_nonexpansive_opt ifnot + | Texp_sequence (e1, e2) -> is_nonexpansive e2 (* PR#4354 *) | Texp_new (_, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 -> true | Texp_def (_,e) -> is_nonexpansive e @@ -1053,6 +1087,17 @@ let check_application_result env statement exp = if statement then Location.prerr_warning exp.exp_loc Warnings.Statement_type +(* Check that a type is generalizable at some level *) +let generalizable level ty = + let rec check ty = + let ty = repr ty in + if ty.level < lowest_level then () else + if ty.level <= level then raise Exit else + (mark_type_node ty; iter_type_expr check ty) + in + try check ty; unmark_type ty; true + with Exit -> unmark_type ty; false + (* Hack to allow coercion of self. Will clean-up later. *) let self_coercion = ref ([] : (Path.t * Location.t list ref) list) @@ -1116,6 +1161,12 @@ and do_type_exp ctx env sexp = | Pexp_ident lid -> check_expression ctx sexp ; 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 = @@ -1155,7 +1206,12 @@ and do_type_exp ctx env sexp = exp_type = type_constant cst; exp_env = env; } | Pexp_let(rec_flag, spat_sexp_list, sbody) -> - let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in + let scp = + match rec_flag with + | Recursive -> Some (Annot.Idef sexp.pexp_loc) + | Nonrecursive -> Some (Annot.Idef sbody.pexp_loc) + | Default -> None in + let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list scp in let body = do_type_exp ctx new_env sbody in re { exp_desc = Texp_let(rec_flag, pat_exp_list, body); @@ -1278,7 +1334,7 @@ and do_type_exp ctx env sexp = exp_loc = sexp.pexp_loc; exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type]; row_more = newvar (); - row_bound = []; + row_bound = (); row_closed = false; row_fixed = false; row_name = None}); @@ -1535,12 +1591,41 @@ and do_type_exp ctx env sexp = let (ty', force) = Typetexp.transl_simple_type_delayed env sty' in + if !Clflags.principal then begin_def (); let arg = type_exp env sarg in + let gen = + if !Clflags.principal then begin + end_def (); + let tv = newvar () in + let gen = generalizable tv.level arg.exp_type in + unify_var env tv arg.exp_type; + gen + end else true + in begin match arg.exp_desc, !self_coercion, (repr ty').desc with Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _, Tconstr(path',_,_) when Path.same path path' -> r := sexp.pexp_loc :: !r; force () + | _ when free_variables arg.exp_type = [] + && free_variables ty' = [] -> + if not gen && (* first try a single coercion *) + let snap = snapshot () in + let ty, b = enlarge_type env ty' in + try + force (); Ctype.unify env arg.exp_type ty; true + with Unify _ -> + backtrack snap; false + then () + else begin try + let force' = subtype env arg.exp_type ty' in + force (); force' (); + if not gen then + Location.prerr_warning sexp.pexp_loc + (Warnings.Not_principal "this ground coercion"); + with Subtype (tr1, tr2) -> + raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2))) + end; | _ -> let ty, b = enlarge_type env ty' in force (); @@ -1773,10 +1858,12 @@ and do_type_exp ctx env sexp = | Pexp_assertfalse -> check_expression ctx sexp ; re { - exp_desc = Texp_assertfalse; - exp_loc = sexp.pexp_loc; - exp_type = newvar (); - exp_env = env; } + exp_desc = Texp_assertfalse; + exp_loc = sexp.pexp_loc; + exp_type = newvar (); + exp_env = env; + } + | Pexp_spawn (sarg) -> check_expression ctx sexp ; (* @@ -1825,7 +1912,9 @@ and do_type_exp ctx env sexp = exp_type = Predef.type_process [kid, sexp.pexp_loc]; exp_env = env; } | Pexp_def (sautos, sbody) -> - let (autos, new_env) = type_def false env sautos in + (* À l'imitation du let *) + let scp = Some (Annot.Idef sexp.pexp_loc) in + let (autos, new_env) = type_def false env sautos scp in let body = do_type_exp ctx new_env sbody in re { exp_desc = Texp_def (autos, body); @@ -1835,12 +1924,12 @@ and do_type_exp ctx env sexp = (*< JOCAML *) | Pexp_lazy (e) -> check_expression ctx sexp ; - let arg = type_exp env e in - re { - exp_desc = Texp_lazy arg; - exp_loc = sexp.pexp_loc; - exp_type = instance (Predef.type_lazy_t arg.exp_type); - exp_env = env; + let arg = type_exp env e in + re { + exp_desc = Texp_lazy arg; + exp_loc = sexp.pexp_loc; + exp_type = instance (Predef.type_lazy_t arg.exp_type); + exp_env = env; } | Pexp_object s -> check_expression ctx sexp ; @@ -2152,7 +2241,7 @@ and type_expect ?in_function env sexp ty_expected = | Pexp_construct(lid, sarg, explicit_arity) -> type_construct env sexp.pexp_loc lid sarg explicit_arity ty_expected | Pexp_let(rec_flag, spat_sexp_list, sbody) -> - let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in + let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list None in let body = type_expect new_env sbody ty_expected in re { exp_desc = Texp_let(rec_flag, pat_exp_list, body); @@ -2303,7 +2392,8 @@ and type_cases ?in_function ctx env ty_arg ty_res partial_loc caselist = List.map (fun (spat, sexp) -> if !Clflags.principal then begin_def (); - let (pat, ext_env, force) = type_pattern env spat in + let scope = Some (Annot.Idef sexp.pexp_loc) in + let (pat, ext_env, force) = type_pattern env spat scope in pattern_force := force @ !pattern_force; let pat = if !Clflags.principal then begin @@ -2369,12 +2459,11 @@ and type_cases ?in_function ctx env ty_arg ty_res partial_loc caselist = (* Typing of let bindings *) -and type_let env rec_flag spat_sexp_list = +and type_let env rec_flag spat_sexp_list scope = begin_def(); if !Clflags.principal then begin_def (); - let (pat_list, new_env, force) = - type_pattern_list env (List.map (fun (spat, sexp) -> spat) spat_sexp_list) - in + let spatl = List.map (fun (spat, sexp) -> spat) spat_sexp_list in + let (pat_list, new_env, force) = type_pattern_list env spatl scope in if rec_flag = Recursive then List.iter2 (fun pat (_, sexp) -> unify_pat env pat (type_approx env sexp)) @@ -2448,8 +2537,9 @@ and type_clause env names reac = conts := kdesc :: !conts; Env.add_continuation kid kdesc env - and add_pat_var (id, ty) env = - Env.add_value id {val_type = ty; val_kind = Val_reg} env in + and add_pat_var (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 in let new_env = List.fold_right add_kont jpats env in let new_env = List.fold_right add_pat_var pat_vars new_env in @@ -2579,9 +2669,9 @@ and add_auto_names_as_regular p env names = (* Argument toplevel below characterize toplevel definitions *) -and type_def toplevel env sautos = +and type_def toplevel env sautos scope = begin_def (); - let names_lhs_list = type_autos_lhs env sautos in + let names_lhs_list = type_autos_lhs env sautos scope in let new_env = List.fold_left (fun env (_, _ , (_,_,names), _) -> @@ -2613,9 +2703,9 @@ and type_def toplevel env sautos = and type_loc toplevel env sdefs = assert false (* 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 *) @@ -2630,9 +2720,9 @@ let type_expression env sexp = (*> JOCAML *) (* Typing of toplevel join-definition *) -let type_joindefinition env d = +let type_joindefinition env d scope = Typetexp.reset_type_variables(); - type_def true env d + type_def true env d scope (*< JOCAML *) (* Error report *) @@ -2668,8 +2758,8 @@ let report_error ppf = function fprintf ppf "This pattern matches values of type") (function ppf -> fprintf ppf "but is here used to match values of type") - | Multiply_bound_variable -> - fprintf ppf "This variable is bound several times in this matching" + | Multiply_bound_variable name -> + fprintf ppf "Variable %s is bound several times in this matching" name | Orpat_vars id -> fprintf ppf "Variable %s must occur on both sides of this | pattern" (Ident.name id) diff --git a/typing/typecore.mli b/typing/typecore.mli index 718177baa7..222f95e567 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -23,16 +23,19 @@ val is_nonexpansive: Typedtree.expression -> bool val type_binding: Env.t -> rec_flag -> (Parsetree.pattern * Parsetree.expression) list -> + Annot.ident option -> (Typedtree.pattern * Typedtree.expression) list * Env.t val type_let: Env.t -> rec_flag -> - (Parsetree.pattern * Parsetree.expression) list -> + (Parsetree.pattern * Parsetree.expression) list -> + Annot.ident option -> (Typedtree.pattern * Typedtree.expression) list * Env.t val type_expression: Env.t -> Parsetree.expression -> Typedtree.expression (*> JOCAML *) val type_joindefinition: Env.t -> Parsetree.joinautomaton list -> + Annot.ident option -> (Typedtree.joinautomaton list * Env.t) (*< JOCAML *) @@ -74,7 +77,7 @@ type error = | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * (type_expr * type_expr) list | Pattern_type_clash of (type_expr * type_expr) list - | Multiply_bound_variable + | Multiply_bound_variable of string | Orpat_vars of Ident.t | Expr_type_clash of (type_expr * type_expr) list | Apply_non_function of type_expr diff --git a/typing/typedecl.ml b/typing/typedecl.ml index c3c60040f4..cdf77652ac 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -38,7 +38,7 @@ type error = | Unbound_type_var of type_expr * type_declaration | Unbound_exception of Longident.t | Not_an_exception of Longident.t - | Bad_variance of int * (bool*bool) * (bool*bool) + | Bad_variance of int * (bool * bool) * (bool * bool) | Unavailable_type_constructor of Path.t | Bad_fixed_type of string @@ -52,6 +52,7 @@ let enter_type env (name, sdecl) id = List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params; type_arity = List.length sdecl.ptype_params; type_kind = Type_abstract; + type_private = sdecl.ptype_private; type_manifest = begin match sdecl.ptype_manifest with None -> None | Some _ -> Some(Ctype.newvar ()) end; @@ -71,12 +72,23 @@ let update_type temp_env env id loc = raise (Error(loc, Type_clash trace)) (* Determine if a type is (an abbreviation for) the type "float" *) - +(* We use the Ctype.expand_head_opt version of expand_head to get access + to the manifest type of private abbreviations. *) let is_float env ty = - match Ctype.repr (Ctype.expand_head env ty) with + match Ctype.repr (Ctype.expand_head_opt env ty) with {desc = Tconstr(p, _, _)} -> Path.same p Predef.path_float | _ -> false +(* Determine if a type definition defines a fixed type. (PW) *) +let is_fixed_type sd = + (match sd.ptype_manifest with + | Some { ptyp_desc = + (Ptyp_variant _|Ptyp_object _|Ptyp_class _|Ptyp_alias + ({ptyp_desc = Ptyp_variant _|Ptyp_object _|Ptyp_class _},_)) } -> true + | _ -> false) && + sd.ptype_kind = Ptype_abstract && + sd.ptype_private = Private + (* Set the row variable in a fixed type *) let set_fixed_row env loc p decl = let tm = @@ -128,9 +140,8 @@ let transl_declaration env (name, sdecl) id = type_arity = List.length params; type_kind = begin match sdecl.ptype_kind with - Ptype_abstract | Ptype_private -> - Type_abstract - | Ptype_variant (cstrs, priv) -> + Ptype_abstract -> Type_abstract + | Ptype_variant cstrs -> let all_constrs = ref StringSet.empty in List.iter (fun (name, args, loc) -> @@ -141,11 +152,12 @@ let transl_declaration env (name, sdecl) id = if List.length (List.filter (fun (_, args, _) -> args <> []) cstrs) > (Config.max_tag + 1) then raise(Error(sdecl.ptype_loc, Too_many_constructors)); - Type_variant(List.map - (fun (name, args, loc) -> - (name, List.map (transl_simple_type env true) args)) - cstrs, priv) - | Ptype_record (lbls, priv) -> + Type_variant + (List.map + (fun (name, args, loc) -> + (name, List.map (transl_simple_type env true) args)) + cstrs) + | Ptype_record lbls -> let all_labels = ref StringSet.empty in List.iter (fun (name, mut, arg, loc) -> @@ -163,14 +175,16 @@ let transl_declaration env (name, sdecl) id = if List.for_all (fun (name, mut, arg) -> is_float env arg) lbls' then Record_float else Record_regular in - Type_record(lbls', rep, priv) + Type_record(lbls', rep) end; + type_private = sdecl.ptype_private; type_manifest = begin match sdecl.ptype_manifest with None -> None | Some sty -> + let no_row = not (is_fixed_type sdecl) in let ty = - transl_simple_type env (sdecl.ptype_kind <> Ptype_private) sty in + transl_simple_type env no_row sty in if Ctype.cyclic_abbrev env id ty then raise(Error(sdecl.ptype_loc, Recursive_abbrev name)); Some ty @@ -185,7 +199,7 @@ let transl_declaration env (name, sdecl) id = raise(Error(loc, Unconsistent_constraint tr))) cstrs; Ctype.end_def (); - if sdecl.ptype_kind = Ptype_private then begin + if is_fixed_type sdecl then begin let (p, _) = try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env with Not_found -> assert false in @@ -200,9 +214,9 @@ let generalize_decl decl = begin match decl.type_kind with Type_abstract -> () - | Type_variant (v, priv) -> + | Type_variant v -> List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v - | Type_record(r, rep, priv) -> + | Type_record(r, rep) -> List.iter (fun (_, _, ty) -> Ctype.generalize ty) r end; begin match decl.type_manifest with @@ -245,10 +259,10 @@ let check_constraints env (_, sdecl) (_, decl) = let visited = ref TypeSet.empty in begin match decl.type_kind with | Type_abstract -> () - | Type_variant (l, _) -> + | Type_variant l -> let rec find_pl = function - Ptype_variant(pl, _) -> pl - | Ptype_record _ | Ptype_abstract | Ptype_private -> assert false + Ptype_variant pl -> pl + | Ptype_record _ | Ptype_abstract -> assert false in let pl = find_pl sdecl.ptype_kind in List.iter @@ -261,10 +275,10 @@ let check_constraints env (_, sdecl) (_, decl) = check_constraints_rec env sty.ptyp_loc visited ty) styl tyl) l - | Type_record (l, _, _) -> + | Type_record (l, _) -> let rec find_pl = function - Ptype_record(pl, _) -> pl - | Ptype_variant _ | Ptype_abstract | Ptype_private -> assert false + Ptype_record pl -> pl + | Ptype_variant _ | Ptype_abstract -> assert false in let pl = find_pl sdecl.ptype_kind in let rec get_loc name = function @@ -455,10 +469,10 @@ let compute_variance env tvl nega posi cntr ty = let make_variance ty = (ty, ref false, ref false, ref false) let whole_type decl = match decl.type_kind with - Type_variant (tll,_) -> + Type_variant tll -> Btype.newgenty (Ttuple (List.map (fun (_, tl) -> Btype.newgenty (Ttuple tl)) tll)) - | Type_record (ftl, _, _) -> + | Type_record (ftl, _) -> Btype.newgenty (Ttuple (List.map (fun (_, _, ty) -> ty) ftl)) | Type_abstract -> @@ -484,26 +498,19 @@ let compute_variance_decl env check decl (required, loc) = None -> assert false | Some ty -> compute_variance env tvl true false false ty end - | Type_variant (tll, _) -> + | Type_variant tll -> List.iter (fun (_,tl) -> List.iter (compute_variance env tvl true false false) tl) tll - | Type_record (ftl, _, _) -> + | Type_record (ftl, _) -> List.iter (fun (_, mut, ty) -> let cn = (mut = Mutable) in compute_variance env tvl true cn cn ty) ftl end; - let priv = - match decl.type_kind with - Type_abstract -> - begin match decl.type_manifest with - Some ty when not (Btype.has_constr_row ty) -> Public - | _ -> Private - end - | Type_variant (_, priv) | Type_record (_, _, priv) -> priv + let priv = decl.type_private and required = List.map (fun (c,n as r) -> if c || n then r else (true,true)) required @@ -590,22 +597,23 @@ let compute_variance_decls env cldecls = (* Force recursion to go through id for private types*) let name_recursion sdecl id decl = match decl with - { type_kind = Type_abstract; type_manifest = Some ty } - when sdecl.ptype_kind = Ptype_private -> - let ty = Ctype.repr ty in - let ty' = Btype.newty2 ty.level ty.desc in - if Ctype.deep_occur ty ty' then - let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in - Btype.link_type ty (Btype.newty2 ty.level td); - {decl with type_manifest = Some ty'} - else decl + | { type_kind = Type_abstract; + type_manifest = Some ty; + type_private = Private; } when is_fixed_type sdecl -> + let ty = Ctype.repr ty in + let ty' = Btype.newty2 ty.level ty.desc in + if Ctype.deep_occur ty ty' then + let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in + Btype.link_type ty (Btype.newty2 ty.level td); + {decl with type_manifest = Some ty'} + else decl | _ -> decl (* Translate a set of mutually recursive type declarations *) let transl_type_decl env name_sdecl_list = (* Add dummy types for fixed rows *) let fixed_types = - List.filter (fun (_,sd) -> sd.ptype_kind = Ptype_private) name_sdecl_list + List.filter (fun (_, sd) -> is_fixed_type sd) name_sdecl_list in let name_sdecl_list = List.map @@ -744,11 +752,12 @@ let transl_with_constraint env id row_path sdecl = with Ctype.Unify tr -> raise(Error(loc, Unconsistent_constraint tr))) sdecl.ptype_cstrs; - let no_row = sdecl.ptype_kind <> Ptype_private in + let no_row = not (is_fixed_type sdecl) in let decl = { type_params = params; type_arity = List.length params; type_kind = Type_abstract; + type_private = sdecl.ptype_private; type_manifest = begin match sdecl.ptype_manifest with None -> None @@ -783,6 +792,7 @@ let abstract_type_decl arity = { type_params = make_params arity; type_arity = arity; type_kind = Type_abstract; + type_private = Public; type_manifest = None; type_variance = replicate_list (true, true, true) arity } in Ctype.end_def(); @@ -803,7 +813,7 @@ let check_recmod_typedecl env loc recmod_ids path decl = (* recmod_ids is the list of recursively-defined module idents. (path, decl) is the type declaration to be checked. *) check_recursion env loc path decl - (fun path -> List.mem (Path.head path) recmod_ids) + (fun path -> List.exists (fun id -> Path.isfree id path) recmod_ids) (**** Error report ****) @@ -870,10 +880,10 @@ let report_error ppf = function kwd (lab ti) Printtyp.type_expr (typ ti) Printtyp.type_expr ty in begin try match decl.type_kind, decl.type_manifest with - Type_variant (tl, _), _ -> + Type_variant tl, _ -> explain tl (fun (_,tl) -> Btype.newgenty (Ttuple tl)) "case" (fun (lab,_) -> lab ^ " of ") - | Type_record (tl, _, _), _ -> + | Type_record (tl, _), _ -> explain tl (fun (_,_,t) -> t) "field" (fun (lab,_,_) -> lab ^ ": ") | Type_abstract, Some ty' -> diff --git a/typing/typedecl.mli b/typing/typedecl.mli index c4605a9158..e23434c7f0 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -45,6 +45,9 @@ val approx_type_decl: val check_recmod_typedecl: Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit +(* for fixed types *) +val is_fixed_type : Parsetree.type_declaration -> bool + (* for typeclass.ml *) val compute_variance_decls: Env.t -> diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 491eae8310..10feb52e29 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -33,10 +33,11 @@ and pattern_desc = | Tpat_constant of constant | Tpat_tuple of pattern list | Tpat_construct of constructor_description * pattern list - | Tpat_variant of label * pattern option * row_desc + | Tpat_variant of label * pattern option * row_desc ref | Tpat_record of (label_description * pattern) list | Tpat_array of pattern list - | Tpat_or of pattern * pattern * Path.t option + | Tpat_or of pattern * pattern * row_desc option + | Tpat_lazy of pattern type partial = Partial | Total type optional = Required | Optional @@ -231,6 +232,7 @@ let iter_pattern_desc f = function List.iter (fun (lbl, pat) -> f pat) lbl_pat_list | Tpat_array patl -> List.iter f patl | Tpat_or(p1, p2, _) -> f p1; f p2 + | Tpat_lazy p -> f p | Tpat_any | Tpat_var _ | Tpat_constant _ -> () @@ -247,6 +249,7 @@ let map_pattern_desc f d = Tpat_construct (c, List.map f pats) | Tpat_array pats -> Tpat_array (List.map f pats) + | Tpat_lazy p1 -> Tpat_lazy (f p1) | Tpat_variant (x1, Some p1, x2) -> Tpat_variant (x1, Some (f p1), x2) | Tpat_or (p1,p2,path) -> diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 30f5a45949..85e6cc89a4 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -32,10 +32,11 @@ and pattern_desc = | Tpat_constant of constant | Tpat_tuple of pattern list | Tpat_construct of constructor_description * pattern list - | Tpat_variant of label * pattern option * row_desc + | Tpat_variant of label * pattern option * row_desc ref | Tpat_record of (label_description * pattern) list | Tpat_array of pattern list - | Tpat_or of pattern * pattern * Path.t option + | Tpat_or of pattern * pattern * row_desc option + | Tpat_lazy of pattern type partial = Partial | Total type optional = Required | Optional diff --git a/typing/typemod.ml b/typing/typemod.ml index c09cee175e..389e34381e 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -87,13 +87,14 @@ let merge_constraint initial_env loc sg lid constr = ([], _, _) -> raise(Error(loc, With_no_component lid)) | (Tsig_type(id, decl, rs) :: rem, [s], - Pwith_type ({ptype_kind = Ptype_private} as sdecl)) - when Ident.name id = s -> + Pwith_type ({ptype_kind = Ptype_abstract} as sdecl)) + when Ident.name id = s && Typedecl.is_fixed_type sdecl -> let decl_row = { type_params = List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params; type_arity = List.length sdecl.ptype_params; type_kind = Type_abstract; + type_private = Private; type_manifest = None; type_variance = List.map (fun (c,n) -> (not n, not c, not c)) @@ -152,87 +153,83 @@ let rec map_rec' fn decls rem = components of signatures. For types, retain only their arity, making them abstract otherwise. *) -let approx_modtype transl_mty init_env smty = +let rec approx_modtype env smty = + match smty.pmty_desc with + Pmty_ident lid -> + begin try + let (path, info) = Env.lookup_modtype lid env in + Tmty_ident path + with Not_found -> + raise(Error(smty.pmty_loc, Unbound_modtype lid)) + end + | Pmty_signature ssg -> + Tmty_signature(approx_sig env ssg) + | Pmty_functor(param, sarg, sres) -> + let arg = approx_modtype env sarg in + let (id, newenv) = Env.enter_module param arg env in + let res = approx_modtype newenv sres in + Tmty_functor(id, arg, res) + | Pmty_with(sbody, constraints) -> + approx_modtype env sbody - let rec approx_mty env smty = - match smty.pmty_desc with - Pmty_ident lid -> - begin try - let (path, info) = Env.lookup_modtype lid env in - Tmty_ident path - with Not_found -> - raise(Error(smty.pmty_loc, Unbound_modtype lid)) - end - | Pmty_signature ssg -> - Tmty_signature(approx_sig env ssg) - | Pmty_functor(param, sarg, sres) -> - let arg = approx_mty env sarg in - let (id, newenv) = Env.enter_module param arg env in - let res = approx_mty newenv sres in - Tmty_functor(id, arg, res) - | Pmty_with(sbody, constraints) -> - approx_mty env sbody - - and approx_sig env ssg = - match ssg with - [] -> [] - | item :: srem -> - match item.psig_desc with - | Psig_type sdecls -> - let decls = Typedecl.approx_type_decl env sdecls in - let rem = approx_sig env srem in - map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem - | Psig_module(name, smty) -> - let mty = approx_mty env smty in - let (id, newenv) = Env.enter_module name mty env in - Tsig_module(id, mty, Trec_not) :: approx_sig newenv srem - | Psig_recmodule sdecls -> - let decls = - List.map - (fun (name, smty) -> - (Ident.create name, approx_mty env smty)) - sdecls in - let newenv = - List.fold_left (fun env (id, mty) -> Env.add_module id mty env) - env decls in - map_rec (fun rs (id, mty) -> Tsig_module(id, mty, rs)) decls - (approx_sig newenv srem) - | Psig_modtype(name, sinfo) -> - let info = approx_mty_info env sinfo in - let (id, newenv) = Env.enter_modtype name info env in - Tsig_modtype(id, info) :: approx_sig newenv srem - | Psig_open lid -> - let (path, mty) = type_module_path env item.psig_loc lid in - let sg = extract_sig_open env item.psig_loc mty in - let newenv = Env.open_signature path sg env in - approx_sig newenv srem - | Psig_include smty -> - let mty = transl_mty init_env smty in - let sg = Subst.signature Subst.identity - (extract_sig env smty.pmty_loc mty) in - let newenv = Env.add_signature sg env in - sg @ approx_sig newenv srem - | Psig_class sdecls | Psig_class_type sdecls -> - let decls = Typeclass.approx_class_declarations env sdecls in - let rem = approx_sig env srem in - List.flatten - (map_rec - (fun rs (i1, d1, i2, d2, i3, d3) -> - [Tsig_cltype(i1, d1, rs); - Tsig_type(i2, d2, rs); - Tsig_type(i3, d3, rs)]) - decls [rem]) - | _ -> - approx_sig env srem - - and approx_mty_info env sinfo = - match sinfo with - Pmodtype_abstract -> - Tmodtype_abstract - | Pmodtype_manifest smty -> - Tmodtype_manifest(approx_mty env smty) - - in approx_mty init_env smty +and approx_sig env ssg = + match ssg with + [] -> [] + | item :: srem -> + match item.psig_desc with + | Psig_type sdecls -> + let decls = Typedecl.approx_type_decl env sdecls in + let rem = approx_sig env srem in + map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem + | Psig_module(name, smty) -> + let mty = approx_modtype env smty in + let (id, newenv) = Env.enter_module name mty env in + Tsig_module(id, mty, Trec_not) :: approx_sig newenv srem + | Psig_recmodule sdecls -> + let decls = + List.map + (fun (name, smty) -> + (Ident.create name, approx_modtype env smty)) + sdecls in + let newenv = + List.fold_left (fun env (id, mty) -> Env.add_module id mty env) + env decls in + map_rec (fun rs (id, mty) -> Tsig_module(id, mty, rs)) decls + (approx_sig newenv srem) + | Psig_modtype(name, sinfo) -> + let info = approx_modtype_info env sinfo in + let (id, newenv) = Env.enter_modtype name info env in + Tsig_modtype(id, info) :: approx_sig newenv srem + | Psig_open lid -> + let (path, mty) = type_module_path env item.psig_loc lid in + let sg = extract_sig_open env item.psig_loc mty in + let newenv = Env.open_signature path sg env in + approx_sig newenv srem + | Psig_include smty -> + let mty = approx_modtype env smty in + let sg = Subst.signature Subst.identity + (extract_sig env smty.pmty_loc mty) in + let newenv = Env.add_signature sg env in + sg @ approx_sig newenv srem + | Psig_class sdecls | Psig_class_type sdecls -> + let decls = Typeclass.approx_class_declarations env sdecls in + let rem = approx_sig env srem in + List.flatten + (map_rec + (fun rs (i1, d1, i2, d2, i3, d3) -> + [Tsig_cltype(i1, d1, rs); + Tsig_type(i2, d2, rs); + Tsig_type(i3, d3, rs)]) + decls [rem]) + | _ -> + approx_sig env srem + +and approx_modtype_info env sinfo = + match sinfo with + Pmodtype_abstract -> + Tmodtype_abstract + | Pmodtype_manifest smty -> + Tmodtype_manifest(approx_modtype env smty) (* Additional validity checks on type definitions arising from recursive modules *) @@ -408,13 +405,22 @@ and transl_recmodule_modtypes loc env sdecls = let init = List.map (fun (name, smty) -> - (Ident.create name, approx_modtype transl_modtype env smty)) + (Ident.create name, approx_modtype env smty)) sdecls in - let first = transition (make_env init) init in - let final_env = make_env first in - let final_decl = transition final_env init in - check_recmod_typedecls final_env sdecls final_decl; - (final_decl, final_env) + 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 +(* + 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. *) @@ -503,6 +509,79 @@ let enrich_module_type anchor name mty env = None -> mty | Some p -> Mtype.enrich_modtype env (Pdot(p, name, nopos)) mty +let check_recmodule_inclusion env bindings = + (* PR#4450, PR#4470: consider + module rec X : DECL = MOD where MOD has inferred type ACTUAL + The "natural" typing condition + E, X: ACTUAL |- ACTUAL <: DECL + leads to circularities through manifest types. + Instead, we "unroll away" the potential circularities a finite number + of times. The (weaker) condition we implement is: + E, X: DECL, + X1: ACTUAL, + X2: ACTUAL{X <- X1}/X1 + ... + Xn: ACTUAL{X <- X(n-1)}/X(n-1) + |- ACTUAL{X <- Xn}/Xn <: DECL{X <- Xn} + so that manifest types rooted at X(n+1) are expanded in terms of X(n), + avoiding circularities. The strengthenings ensure that + Xn.t = X(n-1).t = ... = X2.t = X1.t. + N can be chosen arbitrarily; larger values of N result in more + recursive definitions being accepted. A good choice appears to be + the number of mutually recursive declarations. *) + + let subst_and_strengthen env s id mty = + Mtype.strengthen env (Subst.modtype s mty) + (Subst.module_path s (Pident id)) in + + let rec check_incl first_time n env s = + if n > 0 then begin + (* Generate fresh names Y_i for the rec. bound module idents X_i *) + let bindings1 = + List.map + (fun (id, mty_decl, modl, mty_actual) -> + (id, Ident.rename id, mty_actual)) + bindings in + (* Enter the Y_i in the environment with their actual types substituted + by the input substitution s *) + let env' = + List.fold_left + (fun env (id, id', mty_actual) -> + let mty_actual' = + if first_time + then mty_actual + else subst_and_strengthen env s id mty_actual in + Env.add_module id' mty_actual' env) + env bindings1 in + (* Build the output substitution Y_i <- X_i *) + let s' = + List.fold_left + (fun s (id, id', mty_actual) -> + Subst.add_module id (Pident id') s) + Subst.identity bindings1 in + (* Recurse with env' and s' *) + check_incl false (n-1) env' s' + end else begin + (* Base case: check inclusion of s(mty_actual) in s(mty_decl) + and insert coercion if needed *) + let check_inclusion (id, mty_decl, modl, mty_actual) = + let mty_decl' = Subst.modtype s mty_decl + and mty_actual' = subst_and_strengthen env s id mty_actual in + let coercion = + try + Includemod.modtypes env mty_actual' mty_decl' + with Includemod.Error msg -> + raise(Error(modl.mod_loc, Not_included msg)) in + let modl' = + { mod_desc = Tmod_constraint(modl, mty_decl, coercion); + mod_type = mty_decl; + mod_env = env; + mod_loc = modl.mod_loc } in + (id, modl') in + List.map check_inclusion bindings + end + in check_incl true (List.length bindings) env Subst.identity + (* Type a module value expression *) let rec type_module anchor env smod = @@ -514,7 +593,7 @@ let rec type_module anchor env smod = mod_env = env; mod_loc = smod.pmod_loc } | Pmod_structure sstr -> - let (str, sg, finalenv) = type_structure anchor env sstr in + let (str, sg, finalenv) = type_structure anchor env sstr smod.pmod_loc in rm { mod_desc = Tmod_structure str; mod_type = Tmty_signature sg; mod_env = env; @@ -569,7 +648,7 @@ let rec type_module anchor env smod = mod_env = env; mod_loc = smod.pmod_loc } -and type_structure anchor env sstr = +and type_structure anchor env sstr scope = let type_names = ref StringSet.empty and module_names = ref StringSet.empty and modtype_names = ref StringSet.empty in @@ -582,9 +661,20 @@ and type_structure anchor env sstr = let expr = Typecore.type_expression env sexpr in let (str_rem, sig_rem, final_env) = type_struct env srem in (Tstr_eval expr :: str_rem, sig_rem, final_env) - | {pstr_desc = Pstr_value(rec_flag, sdefs)} :: srem -> + | {pstr_desc = Pstr_value(rec_flag, sdefs); pstr_loc = loc} :: srem -> + let scope = + match rec_flag with + | Recursive -> Some (Annot.Idef {scope with + Location.loc_start = loc.Location.loc_start}) + | Nonrecursive -> + let start = match srem with + | [] -> loc.Location.loc_end + | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start + in Some (Annot.Idef {scope with Location.loc_start = start}) + | Default -> None + in let (defs, newenv) = - Typecore.type_binding env rec_flag sdefs in + Typecore.type_binding env rec_flag sdefs scope in let (str_rem, sig_rem, final_env) = type_struct newenv srem in let bound_idents = let_bound_idents defs in let make_sig_value id = @@ -593,9 +683,14 @@ and type_structure anchor env sstr = map_end make_sig_value bound_idents sig_rem, final_env) (*> JOCAML *) - | {pstr_desc = Pstr_def (sdefs)} :: srem -> + | {pstr_desc = Pstr_def (sdefs) ; pstr_loc = loc} :: srem -> + let scope = + 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}) in let (defs, newenv) = - Typecore.type_joindefinition env sdefs in + Typecore.type_joindefinition env sdefs scope in let (str_rem, sig_rem, final_env) = type_struct newenv srem in let bound_idents = Typedtree.def_bound_idents defs in (Tstr_def (defs) :: str_rem, @@ -656,27 +751,21 @@ and type_structure anchor env sstr = let (decls, newenv) = transl_recmodule_modtypes loc env (List.map (fun (name, smty, smodl) -> (name, smty)) sbind) in - let type_recmodule_binding (id, mty) (name, smty, smodl) = - let modl = - type_module (anchor_recmodule id anchor) newenv smodl in - let coercion = - try - Includemod.modtypes newenv - (Mtype.strengthen env modl.mod_type (Pident id)) - mty - with Includemod.Error msg -> - raise(Error(smodl.pmod_loc, Not_included msg)) in - let modl' = - { mod_desc = Tmod_constraint(modl, mty, coercion); - mod_type = mty; - mod_env = newenv; - mod_loc = smodl.pmod_loc } in - (id, modl') in - let bind = List.map2 type_recmodule_binding decls sbind in + let bindings1 = + List.map2 + (fun (id, mty) (name, smty, smodl) -> + let modl = + type_module (anchor_recmodule id anchor) newenv smodl in + let mty' = + enrich_module_type anchor (Ident.name id) modl.mod_type newenv in + (id, mty, modl, mty')) + decls sbind in + let bindings2 = + check_recmodule_inclusion newenv bindings1 in let (str_rem, sig_rem, final_env) = type_struct newenv srem in - (Tstr_recmodule bind :: str_rem, + (Tstr_recmodule bindings2 :: str_rem, map_rec (fun rs (id, modl) -> Tsig_module(id, modl.mod_type, rs)) - bind sig_rem, + bindings2 sig_rem, final_env) | {pstr_desc = Pstr_modtype(name, smty); pstr_loc = loc} :: srem -> check "module type" loc modtype_names name; @@ -750,7 +839,7 @@ and type_structure anchor env sstr = sg @ sig_rem, final_env) in - if !Clflags.save_types + if !Clflags.annotations then List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr; type_struct env sstr @@ -811,10 +900,7 @@ and simplify_signature sg = let type_implementation sourcefile outputprefix modulename initial_env ast = Typecore.reset_delayed_checks (); - let (str, sg, finalenv) = - Misc.try_finally (fun () -> type_structure initial_env ast) - (fun () -> Stypes.dump (outputprefix ^ ".annot")) - in + let (str, sg, finalenv) = type_structure initial_env ast Location.none in let simple_sg = simplify_signature sg in Typecore.force_delayed_checks (); if !Clflags.print_types then begin diff --git a/typing/typemod.mli b/typing/typemod.mli index 72823ac082..2f452d3ea3 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -20,7 +20,8 @@ open Format val type_module: Env.t -> Parsetree.module_expr -> Typedtree.module_expr val type_structure: - Env.t -> Parsetree.structure -> Typedtree.structure * signature * Env.t + Env.t -> Parsetree.structure -> Location.t -> + Typedtree.structure * signature * Env.t val type_implementation: string -> string -> string -> Env.t -> Parsetree.structure -> Typedtree.structure * Typedtree.module_coercion diff --git a/typing/types.ml b/typing/types.ml index 614d81a317..b9aaf98576 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -20,7 +20,7 @@ open Asttypes (* Type expressions for the core language *) type type_expr = - { mutable desc: type_desc; + { mutable desc: type_desc; mutable level: int; mutable id: int } @@ -33,7 +33,7 @@ and type_desc = | Tfield of string * field_kind * type_expr * type_expr | Tnil | Tlink of type_expr - | Tsubst of type_expr + | Tsubst of type_expr (* for copying *) | Tvariant of row_desc | Tunivar | Tpoly of type_expr * type_expr list @@ -47,7 +47,7 @@ and kont_locs = (Ident.t * Location.t) list and row_desc = { row_fields: (label * row_field) list; row_more: type_expr; - row_bound: type_expr list; + row_bound: unit; row_closed: bool; row_fixed: bool; row_name: (Path.t * type_expr list) option } @@ -55,11 +55,14 @@ and row_desc = and row_field = Rpresent of type_expr option | Reither of bool * type_expr list * bool * row_field option ref + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) | Rabsent and abbrev_memo = Mnil - | Mcons of Path.t * type_expr * type_expr * abbrev_memo + | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo | Mlink of abbrev_memo ref and field_kind = @@ -153,14 +156,16 @@ type type_declaration = { type_params: type_expr list; type_arity: int; type_kind: type_kind; + type_private: private_flag; type_manifest: type_expr option; type_variance: (bool * bool * bool) list } + (* covariant, contravariant, weakly contravariant *) and type_kind = Type_abstract - | Type_variant of (string * type_expr list) list * private_flag - | Type_record of (string * mutable_flag * type_expr) list - * record_representation * private_flag + | Type_variant of (string * type_expr list) list + | Type_record of + (string * mutable_flag * type_expr) list * record_representation type exception_declaration = type_expr list @@ -216,6 +221,6 @@ and modtype_declaration = | Tmodtype_manifest of module_type and rec_status = - Trec_not - | Trec_first - | Trec_next + Trec_not (* not recursive *) + | Trec_first (* first in a recursive group *) + | Trec_next (* not first in a recursive group *) diff --git a/typing/types.mli b/typing/types.mli index 57a736f2d8..6ec58ae8f9 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -19,7 +19,7 @@ open Asttypes (* Type expressions for the core language *) type type_expr = - { mutable desc: type_desc; + { mutable desc: type_desc; mutable level: int; mutable id: int } @@ -45,7 +45,7 @@ and kont_locs = (Ident.t * Location.t) list and row_desc = { row_fields: (label * row_field) list; row_more: type_expr; - row_bound: type_expr list; + row_bound: unit; (* kept for compatibility *) row_closed: bool; row_fixed: bool; row_name: (Path.t * type_expr list) option } @@ -60,7 +60,7 @@ and row_field = and abbrev_memo = Mnil - | Mcons of Path.t * type_expr * type_expr * abbrev_memo + | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo | Mlink of abbrev_memo ref and field_kind = @@ -153,15 +153,16 @@ type type_declaration = { type_params: type_expr list; type_arity: int; type_kind: type_kind; + type_private: private_flag; type_manifest: type_expr option; type_variance: (bool * bool * bool) list } (* covariant, contravariant, weakly contravariant *) and type_kind = Type_abstract - | Type_variant of (string * type_expr list) list * private_flag - | Type_record of (string * mutable_flag * type_expr) list - * record_representation * private_flag + | Type_variant of (string * type_expr list) list + | Type_record of + (string * mutable_flag * type_expr) list * record_representation type exception_declaration = type_expr list diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 4f615abbdf..fa3f0c895a 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -122,6 +122,12 @@ let rec transl_type env policy styp = newty (Ttuple(List.map (transl_type env policy) stl)) | Ptyp_constr(lid, stl) -> let (path, decl) = + let lid, env = + match lid with + | Longident.Ldot (Longident.Lident "*predef*", lid) -> + Longident.Lident lid, Env.initial + | _ -> lid, env + in try Env.lookup_type lid env with Not_found -> @@ -202,14 +208,12 @@ let rec transl_type env policy styp = (fun l -> if not (List.mem_assoc l row.row_fields) then raise(Error(styp.ptyp_loc, Present_has_no_type l))) present; - let bound = ref row.row_bound in let fields = List.map (fun (l,f) -> l, if List.mem l present then f else match Btype.row_field_repr f with | Rpresent (Some ty) -> - bound := ty :: !bound; Reither(false, [ty], false, ref None) | Rpresent None -> Reither (true, [], false, ref None) @@ -217,7 +221,7 @@ let rec transl_type env policy styp = row.row_fields in let row = { row_closed = true; row_fields = fields; - row_bound = !bound; row_name = Some (path, args); + row_bound = (); row_name = Some (path, args); row_fixed = false; row_more = newvar () } in let static = Btype.static_row row in let row = @@ -262,28 +266,31 @@ let rec transl_type env policy styp = instance t end | Ptyp_variant(fields, closed, present) -> - let bound = ref [] and name = ref None in + let name = ref None in let mkfield l f = newty (Tvariant {row_fields=[l,f]; row_more=newvar(); - row_bound=[]; row_closed=true; + row_bound=(); row_closed=true; row_fixed=false; row_name=None}) in - let add_typed_field loc l f fields = + let hfields = Hashtbl.create 17 in + let add_typed_field loc l f = + let h = Btype.hash_variant l in try - let f' = List.assoc l fields in + let (l',f') = Hashtbl.find hfields h in + (* Check for tag conflicts *) + if l <> l' then raise(Error(styp.ptyp_loc, Variant_tags(l, l'))); let ty = mkfield l f and ty' = mkfield l f' in - if equal env false [ty] [ty'] then fields else - try unify env ty ty'; fields + if equal env false [ty] [ty'] then () else + try unify env ty ty' with Unify trace -> raise(Error(loc, Constructor_mismatch (ty,ty'))) with Not_found -> - (l, f) :: fields + Hashtbl.add hfields h (l,f) in - let rec add_field fields = function + let rec add_field = function Rtag (l, c, stl) -> name := None; let f = match present with Some present when not (List.mem l present) -> let tl = List.map (transl_type env policy) stl in - bound := tl @ !bound; Reither(c, tl, false, ref None) | _ -> if List.length stl > 1 || c && stl <> [] then @@ -291,7 +298,7 @@ let rec transl_type env policy styp = match stl with [] -> Rpresent None | st :: _ -> Rpresent (Some(transl_type env policy st)) in - add_typed_field styp.ptyp_loc l f fields + add_typed_field styp.ptyp_loc l f | Rinherit sty -> let ty = transl_type env policy sty in let nm = @@ -299,7 +306,14 @@ let rec transl_type env policy styp = {desc=Tconstr(p, tl, _)} -> Some(p, tl) | _ -> None in - name := if fields = [] then nm else None; + begin try + (* Set name if there are no fields yet *) + Hashtbl.iter (fun _ _ -> raise Exit) hfields; + name := nm + with Exit -> + (* Unset it otherwise *) + name := None + end; let fl = match expand_head env ty, nm with {desc=Tvariant row}, _ when Btype.static_row row -> let row = Btype.row_repr row in @@ -309,13 +323,12 @@ let rec transl_type env policy styp = | _ -> raise(Error(sty.ptyp_loc, Not_a_variant ty)) in - List.fold_left - (fun fields (l, f) -> + List.iter + (fun (l, f) -> let f = match present with Some present when not (List.mem l present) -> begin match f with Rpresent(Some ty) -> - bound := ty :: !bound; Reither(false, [ty], false, ref None) | Rpresent None -> Reither(true, [], false, ref None) @@ -324,10 +337,11 @@ let rec transl_type env policy styp = end | _ -> f in - add_typed_field sty.ptyp_loc l f fields) - fields fl + add_typed_field sty.ptyp_loc l f) + fl in - let fields = List.fold_left add_field [] fields in + List.iter add_field fields; + let fields = Hashtbl.fold (fun _ p l -> p :: l) hfields [] in begin match present with None -> () | Some present -> List.iter @@ -335,25 +349,18 @@ let rec transl_type env policy styp = raise(Error(styp.ptyp_loc, Present_has_no_type l))) present end; - (* Check for tag conflicts *) - let ht = Hashtbl.create (List.length fields + 1) in - List.iter - (fun (l,_) -> - let h = Btype.hash_variant l in - try - let l' = Hashtbl.find ht h in - if l <> l' then raise(Error(styp.ptyp_loc, Variant_tags(l, l'))) - with Not_found -> - Hashtbl.add ht h l) - fields; let row = { row_fields = List.rev fields; row_more = newvar (); - row_bound = !bound; row_closed = closed; + row_bound = (); row_closed = closed; row_fixed = false; row_name = !name } in let static = Btype.static_row row in let row = - if static || policy <> Univars then row - else { row with row_more = new_pre_univar () } + if static then row else + match policy with + Fixed -> + raise (Error (styp.ptyp_loc, Unbound_type_variable "..")) + | Extensible -> row + | Univars -> { row with row_more = new_pre_univar () } in newty (Tvariant row) | Ptyp_poly(vars, st) -> @@ -385,8 +392,12 @@ and transl_fields env policy = function [] -> newty Tnil - | {pfield_desc = Pfield_var}::_ -> - if policy = Univars then new_pre_univar () else newvar () + | ({pfield_desc = Pfield_var} as pf)::_ -> + begin match policy with + Fixed -> raise (Error (pf.pfield_loc, Unbound_type_variable "..")) + | Extensible -> newvar () + | Univars -> new_pre_univar () + end | {pfield_desc = Pfield(s, e)}::l -> let ty1 = transl_type env policy e in let ty2 = transl_fields env policy l in diff --git a/typing/unused_var.ml b/typing/unused_var.ml index ad0e58d941..2c77dfa0a6 100644 --- a/typing/unused_var.ml +++ b/typing/unused_var.ml @@ -73,6 +73,7 @@ let rec get_vars ((vacc, asacc) as acc) p = List.fold_left (fun a (_, p) -> get_vars a p) acc ipl | Ppat_array pl -> List.fold_left get_vars acc pl | Ppat_or (p1, _p2) -> get_vars acc p1 + | Ppat_lazy p -> get_vars acc p | Ppat_constraint (pp, _) -> get_vars acc pp | Ppat_type _ -> acc diff --git a/utils/ccomp.ml b/utils/ccomp.ml index c44bb64c3f..3cb192e318 100644 --- a/utils/ccomp.ml +++ b/utils/ccomp.ml @@ -28,34 +28,37 @@ let run_command cmdline = ignore(command cmdline) command-line length *) let build_diversion lst = let (responsefile, oc) = Filename.open_temp_file "camlresp" "" in - List.iter - (fun f -> - if f <> "" then begin - output_string oc (Filename.quote f); output_char oc '\n' - end) - lst; + List.iter (fun f -> Printf.fprintf oc "%s\n" f) lst; close_out oc; at_exit (fun () -> Misc.remove_file responsefile); "@" ^ responsefile let quote_files lst = - let s = - String.concat " " - (List.map (fun f -> if f = "" then f else Filename.quote f) lst) in - if Sys.os_type = "Win32" && String.length s >= 256 - then build_diversion lst + let lst = List.filter (fun f -> f <> "") lst in + let quoted = List.map Filename.quote lst in + let s = String.concat " " quoted in + if String.length s >= 4096 && Sys.os_type = "Win32" + then build_diversion quoted else s +let quote_prefixed pr lst = + let lst = List.filter (fun f -> f <> "") lst in + let lst = List.map (fun f -> pr ^ f) lst in + quote_files lst + +let quote_optfile = function + | None -> "" + | Some f -> Filename.quote f + let compile_file name = - command - (Printf.sprintf - "%s -c %s %s %s %s" - !Clflags.c_compiler - (String.concat " " (List.rev !Clflags.ccopts)) - (quote_files - (List.rev_map (fun dir -> "-I" ^ dir) !Clflags.include_dirs)) - (Clflags.std_include_flag "-I") - (Filename.quote name)) + command + (Printf.sprintf + "%s -c %s %s %s %s" + !Clflags.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; @@ -84,29 +87,35 @@ let expand_libname name = libname end -(* Handling of msvc's /link options *) - -let make_link_options optlist = - let rec split linkopts otheropts = function - | [] -> String.concat " " otheropts - ^ " /link /subsystem:console " - ^ String.concat " " linkopts - | opt :: rem -> - if String.length opt >= 5 && String.sub opt 0 5 = "/link" - then split (String.sub opt 5 (String.length opt - 5) :: linkopts) - otheropts rem - else split linkopts (opt :: otheropts) rem - in split [] [] optlist +type link_mode = + | Exe + | Dll + | MainDll + | Partial -(* Handling of Visual C++ 2005 manifest files *) - -let merge_manifest exefile = - let manfile = exefile ^ ".manifest" in - if not (Sys.file_exists manfile) then 0 else begin - let retcode = - command (Printf.sprintf "mt -nologo -outputresource:%s -manifest %s" - (Filename.quote exefile) - (Filename.quote manfile)) in - Misc.remove_file manfile; - retcode - end +let call_linker mode output_name files extra = + let files = quote_files files in + let cmd = + if mode = Partial then + Printf.sprintf "%s%s %s %s" + Config.native_pack_linker + (Filename.quote output_name) + files + extra + else + Printf.sprintf "%s -o %s %s %s %s %s %s %s" + (match mode with + | Exe -> Config.mkexe + | Dll -> Config.mkdll + | MainDll -> Config.mkmaindll + | Partial -> assert false + ) + (Filename.quote output_name) + (if !Clflags.gprofile then Config.cc_profile else "") + (Clflags.std_include_flag "-I") + (quote_prefixed "-L" !Config.load_path) + files + extra + (String.concat " " (List.rev !Clflags.ccopts)) + in + command cmd = 0 diff --git a/utils/ccomp.mli b/utils/ccomp.mli index 22bc2e8d69..72ae713145 100644 --- a/utils/ccomp.mli +++ b/utils/ccomp.mli @@ -20,5 +20,13 @@ val compile_file: string -> int val create_archive: string -> string list -> int val expand_libname: string -> string val quote_files: string list -> string -val make_link_options: string list -> string -val merge_manifest: string -> int +val quote_optfile: string option -> string +(*val make_link_options: string list -> string*) + +type link_mode = + | Exe + | Dll + | MainDll + | Partial + +val call_linker: link_mode -> string -> string list -> string -> bool diff --git a/utils/clflags.ml b/utils/clflags.ml index 93bfa24d58..f3248a264a 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -33,7 +33,7 @@ and ccopts = ref ([] : string list) (* -ccopt *) and classic = ref false (* -nolabels *) and nopervasives = ref false (* -nopervasives *) and preprocessor = ref(None : string option) (* -pp *) -let save_types = ref false (* -stypes *) +let annotations = ref false (* -annot *) (*> JOCAML *) and nojoin = ref false (* -nojoin *) (*< JOCAML *) @@ -50,7 +50,6 @@ 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 no_auto_link = ref false (* -noautolink *) and dllpaths = ref ([] : string list) (* -dllpath *) and make_package = ref false (* -pack *) @@ -94,3 +93,7 @@ let std_include_dir () = | None -> [Config.standard_library] | Some s -> [Config.standard_library; s] ;; + +let shared = ref false (* -shared *) +let dlcode = ref true (* not -nodynlink *) + diff --git a/utils/clflags.mli b/utils/clflags.mli index 665363a8cd..3463c27768 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -30,7 +30,7 @@ val ccopts : string list ref val classic : bool ref val nopervasives : bool ref val preprocessor : string option ref -val save_types : bool ref +val annotations : bool ref val nojoin : bool ref val use_threads : bool ref val use_vmthreads : bool ref @@ -45,7 +45,6 @@ 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 no_auto_link : bool ref val dllpaths : string list ref val make_package : bool ref @@ -74,3 +73,5 @@ val inline_threshold : int ref val dont_write_files : bool ref val std_include_flag : string -> string val std_include_dir : unit -> string list +val shared : bool ref +val dlcode : bool ref diff --git a/utils/config.mlbuild b/utils/config.mlbuild index 7b4d4d1a42..18dbbf32ff 100644 --- a/utils/config.mlbuild +++ b/utils/config.mlbuild @@ -40,28 +40,26 @@ let standard_runtime = else C.bindir^"/ocamlrun" let ccomp_type = C.ccomptype let bytecomp_c_compiler = sf "%s %s %s" C.bytecc C.bytecccompopts C.sharedcccompopts -let bytecomp_c_linker = sf "%s %s" C.bytecc C.bytecclinkopts +let bytecomp_c_linker = if windows then "flexlink" else sf "%s %s" C.bytecc C.bytecclinkopts let bytecomp_c_libraries = C.bytecclibs let native_c_compiler = sf "%s %s" C.nativecc C.nativecccompopts -let native_c_linker = sf "%s %s" C.nativecc C.nativecclinkopts +let native_c_linker = if windows then "flexlink" else sf "%s %s" C.nativecc C.nativecclinkopts let native_c_libraries = C.nativecclibs -let native_partial_linker = - if ccomp_type = "msvc" then "link /lib /nologo" - else sf "%s %s" C.partialld C.nativecclinkopts -let native_pack_linker = - if ccomp_type = "msvc" then "link /lib /nologo /out:" - else sf "%s %s -o " C.partialld C.nativecclinkopts +let native_pack_linker = C.packld let ranlib = C.ranlibcmd let cc_profile = C.cc_profile +let mkdll = C.mkdll +let mkexe = C.mkexe +let mkmaindll = C.mkmaindll let exec_magic_number = "Caml1999X008" -and cmi_magic_number = "Caml1999I010" +and cmi_magic_number = "Caml1999I011" and cmo_magic_number = "Caml1999O006" and cma_magic_number = "Caml1999A007" and cmx_magic_number = "Caml1999Y011" and cmxa_magic_number = "Caml1999Z010" -and ast_impl_magic_number = "Caml1999M011" -and ast_intf_magic_number = "Caml1999N010" +and ast_impl_magic_number = "Caml1999M012" +and ast_intf_magic_number = "Caml1999N011" let load_path = ref ([] : string list) @@ -80,6 +78,8 @@ let architecture = C.arch let model = C.model let system = C.system +let asm = C.asm + let ext_obj = C.ext_obj let ext_asm = C.ext_asm let ext_lib = C.ext_lib @@ -107,12 +107,13 @@ let print_config oc = p "native_c_compiler" native_c_compiler; p "native_c_linker" native_c_linker; p "native_c_libraries" native_c_libraries; - p "native_partial_linker" native_partial_linker; + p "native_pack_linker" native_pack_linker; p "ranlib" ranlib; p "cc_profile" cc_profile; p "architecture" architecture; p "model" model; p "system" system; + p "asm" asm; p "ext_obj" ext_obj; p "ext_asm" ext_asm; p "ext_lib" ext_lib; diff --git a/utils/config.mli b/utils/config.mli index cce05f8b2b..cdd05bddeb 100644 --- a/utils/config.mli +++ b/utils/config.mli @@ -33,23 +33,22 @@ val ccomp_type: string val bytecomp_c_compiler: string (* The C compiler to use for compiling C files with the bytecode compiler *) -val bytecomp_c_linker: string - (* The C compiler to use for building custom runtime systems - with the bytecode compiler *) val bytecomp_c_libraries: string (* The C libraries to link with custom runtimes *) val native_c_compiler: string (* The C compiler to use for compiling C files with the native-code compiler *) -val native_c_linker: string - (* The C compiler to use for the final linking step - in the native code compiler *) val native_c_libraries: string (* The C libraries to link with native-code programs *) -val native_partial_linker: string - (* The linker to use for partial links (ocamlopt -output-obj) *) val native_pack_linker: string - (* The linker to use for packaging (ocamlopt -pack) *) + (* The linker to use for packaging (ocamlopt -pack) and for partial links + (ocamlopt -output-obj). *) +val mkdll: string + (* The linker command line to build dynamic libraries. *) +val mkexe: string + (* The linker command line to build executables. *) +val mkmaindll: string + (* The linker command line to build main programs as dlls. *) val ranlib: string (* Command to randomize a library, or "" if not needed *) val cc_profile : string @@ -97,6 +96,10 @@ val model: string val system: string (* Name of operating system for the native-code compiler *) +val asm: string + (* The assembler (and flags) to use for assembling + ocamlopt-generated code. *) + val ext_obj: string (* Extension for object files, e.g. [.o] under Unix. *) val ext_asm: string diff --git a/utils/config.mlp b/utils/config.mlp index dac34216b4..90e8390b6f 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -33,24 +33,24 @@ let standard_library = let standard_runtime = "%%BYTERUN%%" let ccomp_type = "%%CCOMPTYPE%%" let bytecomp_c_compiler = "%%BYTECC%%" -let bytecomp_c_linker = "%%BYTELINK%%" let bytecomp_c_libraries = "%%BYTECCLIBS%%" let native_c_compiler = "%%NATIVECC%%" -let native_c_linker = "%%NATIVELINK%%" let native_c_libraries = "%%NATIVECCLIBS%%" -let native_partial_linker = "%%PARTIALLD%%" let native_pack_linker = "%%PACKLD%%" let ranlib = "%%RANLIBCMD%%" let cc_profile = "%%CC_PROFILE%%" +let mkdll = "%%MKDLL%%" +let mkexe = "%%MKEXE%%" +let mkmaindll = "%%MKMAINDLL%%" let exec_magic_number = "Caml1999X008" -and cmi_magic_number = "Caml1999I010" +and cmi_magic_number = "Caml1999I011" and cmo_magic_number = "Caml1999O006" and cma_magic_number = "Caml1999A007" and cmx_magic_number = "Caml1999Y011" and cmxa_magic_number = "Caml1999Z010" -and ast_impl_magic_number = "Caml1999M011" -and ast_intf_magic_number = "Caml1999N010" +and ast_impl_magic_number = "Caml1999M012" +and ast_intf_magic_number = "Caml1999N011" let load_path = ref ([] : string list) @@ -69,6 +69,8 @@ let architecture = "%%ARCH%%" let model = "%%MODEL%%" let system = "%%SYSTEM%%" +let asm = "%%ASM%%" + let ext_obj = "%%EXT_OBJ%%" let ext_asm = "%%EXT_ASM%%" let ext_lib = "%%EXT_LIB%%" @@ -91,17 +93,16 @@ let print_config oc = p "standard_runtime" standard_runtime; p "ccomp_type" ccomp_type; p "bytecomp_c_compiler" bytecomp_c_compiler; - p "bytecomp_c_linker" bytecomp_c_linker; p "bytecomp_c_libraries" bytecomp_c_libraries; p "native_c_compiler" native_c_compiler; - p "native_c_linker" native_c_linker; p "native_c_libraries" native_c_libraries; - p "native_partial_linker" native_partial_linker; + p "native_pack_linker" native_pack_linker; p "ranlib" ranlib; p "cc_profile" cc_profile; p "architecture" architecture; p "model" model; p "system" system; + p "asm" asm; p "ext_obj" ext_obj; p "ext_asm" ext_asm; p "ext_lib" ext_lib; diff --git a/utils/warnings.ml b/utils/warnings.ml index 74bb4b9189..858bd1172a 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -38,6 +38,7 @@ type t = (* A is all *) | Camlp4 of string | All_clauses_guarded | Useless_record_with + | Bad_module_name of string | Unused_var of string (* Y *) | Unused_var_strict of string (* Z *) ;; @@ -65,6 +66,7 @@ let letter = function (* 'a' is all *) | Nonreturning_statement | Camlp4 _ | Useless_record_with + | Bad_module_name _ | All_clauses_guarded -> 'x' | Unused_var _ -> 'y' | Unused_var_strict _ -> 'z' @@ -156,6 +158,8 @@ let message = function | Useless_record_with -> "this record is defined by a `with' expression,\n\ but no fields are borrowed from the original." + | Bad_module_name (modname) -> + "bad source file name: \"" ^ modname ^ "\" is not a valid module name." ;; let nerrors = ref 0;; diff --git a/utils/warnings.mli b/utils/warnings.mli index cb55f8c60f..1610b3c3a6 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -38,6 +38,7 @@ type t = (* A is all *) | Camlp4 of string | All_clauses_guarded | Useless_record_with + | Bad_module_name of string | Unused_var of string (* Y *) | Unused_var_strict of string (* Z *) ;; diff --git a/yacc/Makefile.nt b/yacc/Makefile.nt index a4b59e6c05..ec1cbfb44a 100644 --- a/yacc/Makefile.nt +++ b/yacc/Makefile.nt @@ -23,7 +23,7 @@ OBJS= closure.$(O) error.$(O) lalr.$(O) lr0.$(O) main.$(O) \ all: ocamlyacc.exe ocamlyacc.exe: $(OBJS) - $(call MKEXE,ocamlyacc.exe,$(BYTECCLINKOPTS) $(OBJS) $(EXTRALIBS)) + $(MKEXE) -o ocamlyacc.exe $(OBJS) $(EXTRALIBS) version.h : ../VERSION echo "#define OCAML_VERSION \"`head -1 ../VERSION`\"" >version.h |