-utils/ccomp.cmo: utils/misc.cmi utils/config.cmi utils/clflags.cmo \
+utils/ccomp.cmo: utils/misc.cmi utils/config.cmi utils/clflags.cmi \
utils/ccomp.cmi
utils/ccomp.cmx: utils/misc.cmx utils/config.cmx utils/clflags.cmx \
utils/ccomp.cmi
-utils/clflags.cmo: utils/config.cmi
-utils/clflags.cmx: utils/config.cmx
+utils/clflags.cmo: utils/config.cmi utils/clflags.cmi
+utils/clflags.cmx: utils/config.cmx utils/clflags.cmi
utils/config.cmo: utils/config.cmi
utils/config.cmx: utils/config.cmi
utils/consistbl.cmo: utils/consistbl.cmi
parsing/parse.cmx: parsing/syntaxerr.cmx parsing/parser.cmx \
parsing/location.cmx parsing/lexer.cmx parsing/parse.cmi
parsing/parser.cmo: parsing/syntaxerr.cmi parsing/parsetree.cmi \
- parsing/longident.cmi parsing/location.cmi utils/clflags.cmo \
+ parsing/longident.cmi parsing/location.cmi utils/clflags.cmi \
parsing/asttypes.cmi parsing/parser.cmi
parsing/parser.cmx: parsing/syntaxerr.cmx parsing/parsetree.cmi \
parsing/longident.cmx parsing/location.cmx utils/clflags.cmx \
parsing/asttypes.cmi
typing/typetexp.cmi: typing/types.cmi typing/path.cmi parsing/parsetree.cmi \
parsing/longident.cmi parsing/location.cmi typing/env.cmi
+typing/unused_var.cmi: parsing/parsetree.cmi
typing/btype.cmo: typing/types.cmi typing/path.cmi utils/misc.cmi \
typing/btype.cmi
typing/btype.cmx: typing/types.cmx typing/path.cmx utils/misc.cmx \
typing/btype.cmi
typing/ctype.cmo: typing/types.cmi typing/subst.cmi typing/path.cmi \
utils/misc.cmi parsing/longident.cmi typing/ident.cmi typing/env.cmi \
- utils/clflags.cmo typing/btype.cmi parsing/asttypes.cmi typing/ctype.cmi
+ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/ctype.cmi
typing/ctype.cmx: typing/types.cmx typing/subst.cmx typing/path.cmx \
utils/misc.cmx parsing/longident.cmx typing/ident.cmx typing/env.cmx \
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/ctype.cmi
typing/printtyp.cmo: typing/types.cmi typing/primitive.cmi typing/predef.cmi \
typing/path.cmi typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi \
parsing/longident.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
- utils/clflags.cmo typing/btype.cmi parsing/asttypes.cmi \
+ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
typing/printtyp.cmi
typing/printtyp.cmx: typing/types.cmx typing/primitive.cmx typing/predef.cmx \
typing/path.cmx typing/outcometree.cmi typing/oprint.cmx utils/misc.cmx \
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.cmo typing/stypes.cmi
+ parsing/location.cmi utils/clflags.cmi typing/stypes.cmi
typing/stypes.cmx: typing/typedtree.cmx typing/printtyp.cmx \
parsing/location.cmx utils/clflags.cmx typing/stypes.cmi
typing/subst.cmo: typing/types.cmi utils/tbl.cmi typing/path.cmi \
typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi typing/predef.cmi \
typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi typing/includeclass.cmi \
- typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmo \
+ typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \
typing/btype.cmi parsing/asttypes.cmi typing/typeclass.cmi
typing/typeclass.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
typing/typedtree.cmx typing/typedecl.cmx typing/typecore.cmx \
typing/primitive.cmi typing/predef.cmi typing/path.cmi \
parsing/parsetree.cmi typing/parmatch.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
- typing/env.cmi typing/ctype.cmi utils/clflags.cmo typing/btype.cmi \
+ typing/env.cmi typing/ctype.cmi utils/clflags.cmi typing/btype.cmi \
parsing/asttypes.cmi typing/typecore.cmi
typing/typecore.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
typing/typedtree.cmx typing/stypes.cmx typing/printtyp.cmx \
typing/primitive.cmi typing/predef.cmi typing/path.cmi \
parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
parsing/location.cmi typing/includecore.cmi typing/ident.cmi \
- typing/env.cmi typing/ctype.cmi utils/config.cmi utils/clflags.cmo \
+ typing/env.cmi typing/ctype.cmi utils/config.cmi utils/clflags.cmi \
typing/btype.cmi parsing/asttypes.cmi typing/typedecl.cmi
typing/typedecl.cmx: typing/typetexp.cmx typing/types.cmx \
typing/typedtree.cmx typing/subst.cmx typing/printtyp.cmx \
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.cmo typing/typemod.cmi
+ utils/clflags.cmi typing/btype.cmi typing/typemod.cmi
typing/typemod.cmx: typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \
typing/typecore.cmx typing/typeclass.cmx typing/subst.cmx \
typing/stypes.cmx typing/printtyp.cmx typing/path.cmx \
parsing/parsetree.cmi typing/mtype.cmx utils/misc.cmx \
parsing/longident.cmx parsing/location.cmx typing/includemod.cmx \
typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
- utils/clflags.cmx typing/typemod.cmi
+ utils/clflags.cmx typing/btype.cmx typing/typemod.cmi
typing/types.cmo: typing/primitive.cmi typing/path.cmi utils/misc.cmi \
typing/ident.cmi parsing/asttypes.cmi typing/types.cmi
typing/types.cmx: typing/primitive.cmx typing/path.cmx utils/misc.cmx \
typing/printtyp.cmx typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \
parsing/longident.cmx parsing/location.cmx typing/env.cmx \
typing/ctype.cmx typing/btype.cmx typing/typetexp.cmi
+typing/unused_var.cmo: utils/warnings.cmi parsing/parsetree.cmi \
+ parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \
+ typing/unused_var.cmi
+typing/unused_var.cmx: utils/warnings.cmx parsing/parsetree.cmi \
+ parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \
+ typing/unused_var.cmi
bytecomp/bytegen.cmi: bytecomp/lambda.cmi bytecomp/instruct.cmi
bytecomp/bytelink.cmi: bytecomp/symtable.cmi bytecomp/emitcode.cmi
bytecomp/bytepackager.cmi: typing/ident.cmi
bytecomp/emitcode.cmi: bytecomp/lambda.cmi bytecomp/instruct.cmi \
typing/ident.cmi
-bytecomp/instruct.cmi: typing/types.cmi bytecomp/lambda.cmi typing/ident.cmi \
- typing/env.cmi
+bytecomp/instruct.cmi: typing/types.cmi parsing/location.cmi \
+ bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
bytecomp/lambda.cmi: typing/types.cmi typing/primitive.cmi typing/path.cmi \
- typing/ident.cmi typing/env.cmi parsing/asttypes.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/printinstr.cmi: bytecomp/instruct.cmi
bytecomp/instruct.cmx typing/ident.cmx utils/config.cmx \
parsing/asttypes.cmi bytecomp/bytegen.cmi
bytecomp/bytelibrarian.cmo: utils/misc.cmi bytecomp/emitcode.cmi \
- utils/config.cmi utils/clflags.cmo bytecomp/bytelink.cmi \
+ utils/config.cmi utils/clflags.cmi bytecomp/bytelink.cmi \
bytecomp/bytelibrarian.cmi
bytecomp/bytelibrarian.cmx: utils/misc.cmx bytecomp/emitcode.cmx \
utils/config.cmx utils/clflags.cmx bytecomp/bytelink.cmx \
bytecomp/bytelink.cmo: bytecomp/symtable.cmi bytecomp/opcodes.cmo \
utils/misc.cmi bytecomp/instruct.cmi typing/ident.cmi \
bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \
- utils/config.cmi utils/clflags.cmo utils/ccomp.cmi \
+ utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \
bytecomp/bytesections.cmi bytecomp/bytelink.cmi
bytecomp/bytelink.cmx: bytecomp/symtable.cmx bytecomp/opcodes.cmx \
utils/misc.cmx bytecomp/instruct.cmx typing/ident.cmx \
bytecomp/bytesections.cmx bytecomp/bytelink.cmi
bytecomp/bytepackager.cmo: typing/typemod.cmi bytecomp/translmod.cmi \
utils/misc.cmi bytecomp/instruct.cmi typing/ident.cmi typing/env.cmi \
- bytecomp/emitcode.cmi utils/config.cmi utils/clflags.cmo \
+ bytecomp/emitcode.cmi utils/config.cmi utils/clflags.cmi \
bytecomp/bytelink.cmi bytecomp/bytegen.cmi bytecomp/bytepackager.cmi
bytecomp/bytepackager.cmx: typing/typemod.cmx bytecomp/translmod.cmx \
utils/misc.cmx bytecomp/instruct.cmx typing/ident.cmx typing/env.cmx \
bytecomp/emitcode.cmo: bytecomp/translmod.cmi bytecomp/opcodes.cmo \
utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \
bytecomp/instruct.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \
- utils/clflags.cmo typing/btype.cmi parsing/asttypes.cmi \
+ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
bytecomp/emitcode.cmi
bytecomp/emitcode.cmx: bytecomp/translmod.cmx bytecomp/opcodes.cmx \
utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \
bytecomp/instruct.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
bytecomp/emitcode.cmi
-bytecomp/instruct.cmo: typing/types.cmi bytecomp/lambda.cmi typing/ident.cmi \
- typing/env.cmi bytecomp/instruct.cmi
-bytecomp/instruct.cmx: typing/types.cmx bytecomp/lambda.cmx typing/ident.cmx \
- typing/env.cmx bytecomp/instruct.cmi
+bytecomp/instruct.cmo: typing/types.cmi parsing/location.cmi \
+ bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi bytecomp/instruct.cmi
+bytecomp/instruct.cmx: typing/types.cmx parsing/location.cmx \
+ bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx bytecomp/instruct.cmi
bytecomp/lambda.cmo: typing/types.cmi typing/primitive.cmi typing/path.cmi \
- utils/misc.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi \
- bytecomp/lambda.cmi
+ utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \
+ parsing/asttypes.cmi bytecomp/lambda.cmi
bytecomp/lambda.cmx: typing/types.cmx typing/primitive.cmx typing/path.cmx \
- utils/misc.cmx typing/ident.cmx typing/env.cmx parsing/asttypes.cmi \
- bytecomp/lambda.cmi
+ utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \
+ parsing/asttypes.cmi bytecomp/lambda.cmi
bytecomp/matching.cmo: typing/types.cmi bytecomp/typeopt.cmi \
typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \
typing/primitive.cmi typing/predef.cmi typing/parmatch.cmi utils/misc.cmi \
typing/btype.cmx parsing/asttypes.cmi bytecomp/matching.cmi
bytecomp/meta.cmo: bytecomp/meta.cmi
bytecomp/meta.cmx: bytecomp/meta.cmi
-bytecomp/printinstr.cmo: bytecomp/printlambda.cmi bytecomp/lambda.cmi \
- bytecomp/instruct.cmi typing/ident.cmi bytecomp/printinstr.cmi
-bytecomp/printinstr.cmx: bytecomp/printlambda.cmx bytecomp/lambda.cmx \
- bytecomp/instruct.cmx typing/ident.cmx bytecomp/printinstr.cmi
+bytecomp/printinstr.cmo: bytecomp/printlambda.cmi parsing/location.cmi \
+ bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \
+ bytecomp/printinstr.cmi
+bytecomp/printinstr.cmx: bytecomp/printlambda.cmx parsing/location.cmx \
+ bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx \
+ bytecomp/printinstr.cmi
bytecomp/printlambda.cmo: typing/types.cmi typing/primitive.cmi \
- bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi \
- bytecomp/printlambda.cmi
+ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \
+ parsing/asttypes.cmi bytecomp/printlambda.cmi
bytecomp/printlambda.cmx: typing/types.cmx typing/primitive.cmx \
- bytecomp/lambda.cmx typing/ident.cmx parsing/asttypes.cmi \
- bytecomp/printlambda.cmi
+ parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \
+ parsing/asttypes.cmi bytecomp/printlambda.cmi
bytecomp/runtimedef.cmo: bytecomp/runtimedef.cmi
bytecomp/runtimedef.cmx: bytecomp/runtimedef.cmi
-bytecomp/simplif.cmo: bytecomp/lambda.cmi typing/ident.cmi utils/clflags.cmo \
+bytecomp/simplif.cmo: bytecomp/lambda.cmi typing/ident.cmi utils/clflags.cmi \
parsing/asttypes.cmi bytecomp/simplif.cmi
bytecomp/simplif.cmx: bytecomp/lambda.cmx typing/ident.cmx utils/clflags.cmx \
parsing/asttypes.cmi bytecomp/simplif.cmi
bytecomp/switch.cmx: bytecomp/switch.cmi
bytecomp/symtable.cmo: utils/tbl.cmi bytecomp/runtimedef.cmi \
typing/predef.cmi utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \
- typing/ident.cmi bytecomp/emitcode.cmi bytecomp/dll.cmi utils/clflags.cmo \
+ typing/ident.cmi bytecomp/emitcode.cmi bytecomp/dll.cmi utils/clflags.cmi \
bytecomp/bytesections.cmi parsing/asttypes.cmi bytecomp/symtable.cmi
bytecomp/symtable.cmx: utils/tbl.cmx bytecomp/runtimedef.cmx \
typing/predef.cmx utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \
typing/typedtree.cmi typing/typeclass.cmi bytecomp/translobj.cmi \
bytecomp/translcore.cmi typing/path.cmi utils/misc.cmi \
bytecomp/matching.cmi parsing/location.cmi bytecomp/lambda.cmi \
- typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmo \
+ typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \
typing/btype.cmi parsing/asttypes.cmi bytecomp/translclass.cmi
bytecomp/translclass.cmx: typing/types.cmx bytecomp/typeopt.cmx \
typing/typedtree.cmx typing/typeclass.cmx bytecomp/translobj.cmx \
typing/typedtree.cmi bytecomp/translobj.cmi typing/primitive.cmi \
typing/predef.cmi typing/path.cmi utils/misc.cmi bytecomp/matching.cmi \
parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
- utils/config.cmi utils/clflags.cmo typing/btype.cmi parsing/asttypes.cmi \
+ utils/config.cmi utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
bytecomp/translcore.cmi
bytecomp/translcore.cmx: typing/types.cmx bytecomp/typeopt.cmx \
typing/typedtree.cmx bytecomp/translobj.cmx typing/primitive.cmx \
bytecomp/translmod.cmo: typing/types.cmi typing/typedtree.cmi \
bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \
typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
- typing/path.cmi typing/mtype.cmi utils/misc.cmi parsing/location.cmi \
- bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
- utils/config.cmi parsing/asttypes.cmi bytecomp/translmod.cmi
+ typing/path.cmi typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \
+ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
+ typing/ctype.cmi parsing/asttypes.cmi bytecomp/translmod.cmi
bytecomp/translmod.cmx: typing/types.cmx typing/typedtree.cmx \
bytecomp/translobj.cmx bytecomp/translcore.cmx bytecomp/translclass.cmx \
typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \
- typing/path.cmx typing/mtype.cmx utils/misc.cmx parsing/location.cmx \
- bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
- utils/config.cmx parsing/asttypes.cmi bytecomp/translmod.cmi
+ typing/path.cmx typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \
+ parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
+ typing/ctype.cmx parsing/asttypes.cmi bytecomp/translmod.cmi
bytecomp/translobj.cmo: typing/primitive.cmi utils/misc.cmi \
parsing/longident.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
- utils/clflags.cmo typing/btype.cmi parsing/asttypes.cmi \
+ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
bytecomp/translobj.cmi
bytecomp/translobj.cmx: typing/primitive.cmx utils/misc.cmx \
parsing/longident.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
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.cmo asmcomp/asmgen.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/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.cmo asmcomp/clambda.cmi \
+ asmcomp/compilenv.cmi utils/clflags.cmi asmcomp/clambda.cmi \
utils/ccomp.cmi asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi
asmcomp/asmlibrarian.cmx: utils/misc.cmx utils/config.cmx \
asmcomp/compilenv.cmx utils/clflags.cmx asmcomp/clambda.cmx \
asmcomp/asmlink.cmo: bytecomp/runtimedef.cmi asmcomp/proc.cmi utils/misc.cmi \
parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \
utils/consistbl.cmi utils/config.cmi asmcomp/compilenv.cmi \
- asmcomp/cmmgen.cmi utils/clflags.cmo utils/ccomp.cmi asmcomp/asmgen.cmi \
+ asmcomp/cmmgen.cmi utils/clflags.cmi utils/ccomp.cmi asmcomp/asmgen.cmi \
asmcomp/asmlink.cmi
asmcomp/asmlink.cmx: bytecomp/runtimedef.cmx asmcomp/proc.cmx utils/misc.cmx \
parsing/location.cmx asmcomp/emitaux.cmx asmcomp/emit.cmx \
asmcomp/cmmgen.cmx utils/clflags.cmx utils/ccomp.cmx asmcomp/asmgen.cmx \
asmcomp/asmlink.cmi
asmcomp/asmpackager.cmo: typing/typemod.cmi bytecomp/translmod.cmi \
- utils/tbl.cmi utils/misc.cmi parsing/location.cmi bytecomp/lambda.cmi \
- typing/ident.cmi typing/env.cmi utils/config.cmi asmcomp/compilenv.cmi \
+ utils/misc.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \
+ typing/env.cmi utils/config.cmi asmcomp/compilenv.cmi utils/clflags.cmi \
asmcomp/clambda.cmi utils/ccomp.cmi asmcomp/asmlink.cmi \
asmcomp/asmgen.cmi asmcomp/asmpackager.cmi
asmcomp/asmpackager.cmx: typing/typemod.cmx bytecomp/translmod.cmx \
- utils/tbl.cmx utils/misc.cmx parsing/location.cmx bytecomp/lambda.cmx \
- typing/ident.cmx typing/env.cmx utils/config.cmx asmcomp/compilenv.cmx \
+ utils/misc.cmx parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \
+ typing/env.cmx utils/config.cmx asmcomp/compilenv.cmx utils/clflags.cmx \
asmcomp/clambda.cmx utils/ccomp.cmx asmcomp/asmlink.cmx \
asmcomp/asmgen.cmx asmcomp/asmpackager.cmi
asmcomp/clambda.cmo: bytecomp/lambda.cmi typing/ident.cmi \
parsing/asttypes.cmi asmcomp/clambda.cmi
asmcomp/closure.cmo: utils/tbl.cmi bytecomp/switch.cmi typing/primitive.cmi \
utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi asmcomp/compilenv.cmi \
- utils/clflags.cmo asmcomp/clambda.cmi parsing/asttypes.cmi \
+ utils/clflags.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \
asmcomp/closure.cmi
asmcomp/closure.cmx: utils/tbl.cmx bytecomp/switch.cmx typing/primitive.cmx \
utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/compilenv.cmx \
asmcomp/cmm.cmx: typing/ident.cmx asmcomp/arch.cmx asmcomp/cmm.cmi
asmcomp/cmmgen.cmo: typing/types.cmi bytecomp/switch.cmi asmcomp/proc.cmi \
typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \
- utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmm.cmi utils/clflags.cmo \
+ utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmm.cmi utils/clflags.cmi \
asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \
asmcomp/cmmgen.cmi
asmcomp/cmmgen.cmx: typing/types.cmx bytecomp/switch.cmx asmcomp/proc.cmx \
asmcomp/printmach.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printcmm.cmx \
asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/printmach.cmi
asmcomp/proc.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
- utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmo utils/ccomp.cmi \
+ utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi utils/ccomp.cmi \
asmcomp/arch.cmo asmcomp/proc.cmi
asmcomp/proc.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx utils/ccomp.cmx \
asmcomp/split.cmi
driver/compile.cmi: typing/env.cmi
driver/optcompile.cmi: typing/env.cmi
-driver/compile.cmo: utils/warnings.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.cmo utils/ccomp.cmi bytecomp/bytegen.cmi driver/compile.cmi
-driver/compile.cmx: utils/warnings.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
+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
+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
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 \
typing/env.cmx typing/ctype.cmx bytecomp/bytepackager.cmx \
bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/errors.cmi
driver/main.cmo: utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \
- driver/errors.cmi utils/config.cmi driver/compile.cmi utils/clflags.cmo \
+ driver/errors.cmi utils/config.cmi driver/compile.cmi utils/clflags.cmi \
bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \
bytecomp/bytelibrarian.cmi driver/main.cmi
driver/main.cmx: utils/warnings.cmx utils/misc.cmx driver/main_args.cmx \
bytecomp/bytelibrarian.cmx driver/main.cmi
driver/main_args.cmo: driver/main_args.cmi
driver/main_args.cmx: driver/main_args.cmi
-driver/optcompile.cmo: utils/warnings.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.cmo \
- utils/ccomp.cmi asmcomp/asmgen.cmi driver/optcompile.cmi
-driver/optcompile.cmx: utils/warnings.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
+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
+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
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 \
asmcomp/asmgen.cmx driver/opterrors.cmi
driver/optmain.cmo: utils/warnings.cmi asmcomp/printmach.cmi \
driver/opterrors.cmi driver/optcompile.cmi utils/misc.cmi \
- utils/config.cmi utils/clflags.cmo asmcomp/asmpackager.cmi \
+ utils/config.cmi utils/clflags.cmi asmcomp/asmpackager.cmi \
asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi asmcomp/arch.cmo \
driver/optmain.cmi
driver/optmain.cmx: utils/warnings.cmx asmcomp/printmach.cmx \
utils/config.cmx utils/clflags.cmx asmcomp/asmpackager.cmx \
asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx asmcomp/arch.cmx \
driver/optmain.cmi
-driver/pparse.cmo: utils/misc.cmi parsing/location.cmi utils/clflags.cmo \
+driver/pparse.cmo: utils/misc.cmi parsing/location.cmi utils/clflags.cmi \
utils/ccomp.cmi driver/pparse.cmi
driver/pparse.cmx: utils/misc.cmx parsing/location.cmx utils/clflags.cmx \
utils/ccomp.cmx driver/pparse.cmi
typing/path.cmi bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi \
parsing/longident.cmi typing/ident.cmi typing/env.cmi \
bytecomp/emitcode.cmi bytecomp/dll.cmi typing/ctype.cmi \
- utils/consistbl.cmi utils/config.cmi utils/clflags.cmo \
+ utils/consistbl.cmi utils/config.cmi utils/clflags.cmi \
toplevel/topdirs.cmi
toplevel/topdirs.cmx: utils/warnings.cmx typing/types.cmx toplevel/trace.cmx \
toplevel/toploop.cmx bytecomp/symtable.cmx typing/printtyp.cmx \
parsing/longident.cmi parsing/location.cmi parsing/lexer.cmi \
typing/ident.cmi toplevel/genprintval.cmi driver/errors.cmi \
typing/env.cmi bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \
- utils/config.cmi driver/compile.cmi utils/clflags.cmo \
+ utils/config.cmi driver/compile.cmi utils/clflags.cmi \
bytecomp/bytegen.cmi typing/btype.cmi toplevel/toploop.cmi
toplevel/toploop.cmx: utils/warnings.cmx typing/types.cmx typing/typemod.cmx \
typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \
bytecomp/bytegen.cmx typing/btype.cmx toplevel/toploop.cmi
toplevel/topmain.cmo: utils/warnings.cmi toplevel/toploop.cmi \
toplevel/topdirs.cmi utils/misc.cmi driver/errors.cmi utils/config.cmi \
- utils/clflags.cmo toplevel/topmain.cmi
+ utils/clflags.cmi toplevel/topmain.cmi
toplevel/topmain.cmx: utils/warnings.cmx toplevel/toploop.cmx \
toplevel/topdirs.cmx utils/misc.cmx driver/errors.cmx utils/config.cmx \
utils/clflags.cmx toplevel/topmain.cmi
+Objective Caml 3.09.0:
+----------------------
+
+(Changes that can break existing programs are marked with a "*" )
+
+Language features:
+- Introduction of private row types, for abstracting the row in object
+ and variant types.
+
+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.
+
+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).
+
+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.
+
+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.
+
+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:
----------------------
- ocamldoc: (**/**) can be canceled with another (**/**) PR#3665
- graphics: added resize_window
- graphics: check for invalid arguments to drawing primitives PR#3595
-- lablbrowser: use windows subsystem on mingw
+- ocamlbrowser: use windows subsystem on mingw
Bug fixes:
- ocamlopt: code generation problem on AMD64 PR#3640
- camlp4: install argl.* files (PR#3439)
- ocamldoc: add -man-section option
- labltk: add the "solid" relief option (PR#3343)
-- compiler: ocamlc -i now prints variance annotations
Bug fixes:
- typing: fix unsoundness in type declaration variance inference.
* First public release.
-$Id: Changes,v 1.140.2.10 2005/08/11 16:59:53 doligez Exp $
+$Id: Changes,v 1.156 2005/10/26 15:11:29 xleroy Exp $
make opt > log.opt 2>&1 # in sh
make opt >& log.opt # in csh
-5- (Optional) If you want to give the native-code compiler a serious
-test, you can try to compile the Objective Caml compilers with the
-native-code compiler (they are compiled to bytecode by default).
-Just do:
+5- (Optional) If you want to compile fast versions of the Objective
+Caml compilers, you can compile them with the native-code compiler
+(they are compiled to bytecode by default). Just do:
make opt.opt
# #
#########################################################################
-# $Id: Makefile,v 1.186.2.7 2005/01/31 10:30:47 doligez Exp $
+# $Id: Makefile,v 1.199 2005/09/24 16:20:36 xleroy Exp $
# The main Makefile
parsing/syntaxerr.cmo parsing/parser.cmo \
parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo
-TYPING=typing/ident.cmo typing/path.cmo \
+TYPING=typing/unused_var.cmo typing/ident.cmo typing/path.cmo \
typing/primitive.cmo typing/types.cmo \
typing/btype.cmo typing/oprint.cmo \
typing/subst.cmo typing/predef.cmo \
ln -s ../byterun stdlib/caml; fi
# Build the core system: the minimum needed to make depend and bootstrap
-core : runtime ocamlc ocamllex ocamlyacc ocamltools library
+core : coldstart ocamlc ocamllex ocamlyacc ocamltools library
# Save the current bootstrap compiler
MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev
cd camlp4; $(MAKE) install BINDIR=$(BINDIR) LIBDIR=$(LIBDIR) MANDIR=$(MANDIR)
if test -f debugger/ocamldebug; then (cd debugger; $(MAKE) install); \
else :; fi
+ cp config/Makefile $(LIBDIR)/Makefile.config
# Installation of the native-code compiler
installopt:
-e 's|%%BYTECCLIBS%%|$(BYTECCLIBS)|' \
-e 's|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|' \
-e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \
- -e 's|%%BINUTILS_NM%%|$(BINUTILS_NM)|' \
-e 's|%%CC_PROFILE%%|$(CC_PROFILE)|' \
- -e 's|%%BINUTILS_OBJCOPY%%|$(BINUTILS_OBJCOPY)|' \
-e 's|%%ARCH%%|$(ARCH)|' \
-e 's|%%MODEL%%|$(MODEL)|' \
-e 's|%%SYSTEM%%|$(SYSTEM)|' \
-e 's|%%EXT_ASM%%|.s|' \
-e 's|%%EXT_LIB%%|.a|' \
-e 's|%%EXT_DLL%%|.so|' \
+ -e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \
utils/config.mlp > utils/config.ml
@chmod -w utils/config.ml
beforedepend:: asmcomp/emit.ml
tools/cvt_emit: tools/cvt_emit.mll
- cd tools; $(MAKE) CAMLC="../$(CAMLRUN) ../ocamlc -I ../stdlib" cvt_emit
+ cd tools; \
+ $(MAKE) CAMLC="../$(CAMLRUN) ../boot/ocamlc -I ../stdlib" cvt_emit
# The "expunge" utility
# #
#########################################################################
-# $Id: Makefile.nt,v 1.94.4.1 2004/11/29 08:50:45 xleroy Exp $
+# $Id: Makefile.nt,v 1.98 2005/09/24 16:20:36 xleroy Exp $
# The main Makefile
parsing/syntaxerr.cmo parsing/parser.cmo \
parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo
-TYPING=typing/ident.cmo typing/path.cmo \
+TYPING=typing/unused_var.cmo typing/ident.cmo typing/path.cmo \
typing/primitive.cmo typing/types.cmo \
typing/btype.cmo typing/oprint.cmo \
typing/subst.cmo typing/predef.cmo \
for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done
cd win32caml ; $(MAKE) install
cd camlp4 ; make install
+ cp config/Makefile $(LIBDIR)/Makefile.config
cp README $(DISTRIB)/Readme.general.txt
cp README.win32 $(DISTRIB)/Readme.windows.txt
cp LICENSE $(DISTRIB)/License.txt
-e "s|%%EXT_ASM%%|.$(S)|" \
-e "s|%%EXT_LIB%%|.$(A)|" \
-e "s|%%EXT_DLL%%|.dll|" \
+ -e "s|%%SYSTHREAD_SUPPORT%%|true|" \
utils/config.mlp > utils/config.ml
@chmod -w utils/config.ml
COPYRIGHT:
All files marked "Copyright INRIA" in this distribution are copyright
-1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 Institut National de
-Recherche en Informatique et en Automatique (INRIA) and distributed
-under the conditions stated in file LICENSE.
+1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005
+Institut National de Recherche en Informatique et en Automatique
+(INRIA) and distributed under the conditions stated in file LICENSE.
INSTALLATION:
Caml bytecode with C code (ocamlc -custom), require
the Cygwin development tools, available at
http://sources.redhat.com/cygwin/
+You will need to install at least the following Cygwin packages:
+binutils, gcc-core, gcc-mingw-core, mingw-runtime, w32-api.
+
+Do *not* install the Mingw/MSYS development tools from www.mingw.org:
+these are not compatible with this Caml port (@responsefile not
+recognized on the command line).
The LablTk GUI requires Tcl/Tk 8.3. Windows binaries are
available from http://prdownloads.sourceforge.net/tcl/tcl832.exe.
(* *)
(***********************************************************************)
-(* $Id: emit.mlp,v 1.40 2004/05/03 12:46:50 xleroy Exp $ *)
+(* $Id: emit.mlp,v 1.41 2005/10/14 16:41:06 xleroy Exp $ *)
module LabelSet =
Set.Make(struct type t = Linearize.label let compare = compare end)
end
| Lop(Iintop_imm(Imod, n)) ->
if n = 1 lsl (Misc.log2 n) then begin
- let l = Misc.log2 n in
if is_immediate n then
` and {emit_reg i.arg.(0)}, {emit_int(n-1)}, $25\n`
else begin
(* *)
(***********************************************************************)
-(* $Id: arch.ml,v 1.1 2003/06/30 08:28:44 xleroy Exp $ *)
+(* $Id: arch.ml,v 1.2 2005/10/13 03:53:52 xleroy Exp $ *)
(* Machine-specific command-line options *)
-let command_line_options = []
+let pic_code = ref false
+
+let command_line_options =
+ [ "-fPIC", Arg.Set pic_code,
+ " Generate position-independent machine code" ]
(* Specific operations for the AMD64 processor *)
(* *)
(***********************************************************************)
-(* $Id: emit.mlp,v 1.6.6.2 2005/06/12 13:35:56 xleroy Exp $ *)
+(* $Id: emit.mlp,v 1.10 2005/10/13 03:53:52 xleroy Exp $ *)
-(* Emission of Intel 386 assembly code *)
+(* Emission of x86-64 (AMD 64) assembly code *)
open Misc
open Cmm
` movlpd {emit_label lbl}(%rip), {emit_reg i.res.(0)}\n`
end
| Lop(Iconst_symbol s) ->
- ` movq ${emit_symbol s}, {emit_reg i.res.(0)}\n`
+ 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`
| Lop(Icall_ind) ->
` call *{emit_reg i.arg.(0)}\n`;
record_frame i.live
end
| Lop(Iextcall(s, alloc)) ->
if alloc then begin
- ` movq ${emit_symbol s}, %rax\n`;
+ ` leaq {emit_symbol s}(%rip), %rax\n`;
` call {emit_symbol "caml_c_call"}\n`;
record_frame i.live
end else begin
` sarq ${emit_int l}, {emit_reg i.res.(0)}\n`
| Lop(Iintop_imm(Imod, n)) ->
(* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *)
- let l = Misc.log2 n in
` movq {emit_reg i.arg.(0)}, %rax\n`;
` testq %rax, %rax\n`;
` leaq {emit_int(n-1)}(%rax), %rax\n`;
| 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);
` 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`
(* *)
(***********************************************************************)
-(* $Id: reload.ml,v 1.1 2003/06/30 08:28:44 xleroy Exp $ *)
+(* $Id: reload.ml,v 1.2 2005/10/13 03:53:52 xleroy Exp $ *)
open Cmm
open Arch
or S R
Iconst_int S
Iconst_float R
- Iconst_symbol S
+ Iconst_symbol (not PIC) S
+ Iconst_symbol (PIC) R
Icall_ind R
Itailcall_ind R
Iload R R R
(* This add will be turned into a lea; args and results must be
in registers *)
super#reload_operation op arg res
- | Iconst_int _ | Iconst_symbol _
+ | Iconst_symbol _ ->
+ if !pic_code
+ then super#reload_operation op arg res
+ else (arg, res)
+ | Iconst_int _
| Iintop(Idiv | Imod | Ilsl | Ilsr | Iasr)
| Iintop_imm(_, _) ->
(* The argument(s) and results can be either in register or on stack *)
(* *)
(***********************************************************************)
-(* $Id: selection.ml,v 1.2 2003/06/30 11:29:26 xleroy Exp $ *)
+(* $Id: selection.ml,v 1.3 2005/10/13 03:53:52 xleroy Exp $ *)
(* Instruction selection for the AMD64 *)
(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 ->
+ | Cconst_symbol s when not !pic_code ->
(Ispecific(Istore_symbol(s, addr)), Ctuple [])
| _ ->
super#select_store addr exp
(* *)
(***********************************************************************)
-(* $Id: asmlibrarian.ml,v 1.13 2002/04/04 09:00:16 garrigue Exp $ *)
+(* $Id: asmlibrarian.ml,v 1.14 2005/09/24 16:45:56 xleroy Exp $ *)
(* Build libraries of .cmx files *)
(Filename.chop_suffix filename ".cmx" ^ ext_obj, (info, crc))
let create_archive file_list lib_name =
- let archive_name = Filename.chop_suffix lib_name ".cmxa" ^ ext_lib in
+ let archive_name = chop_extension_if_any lib_name ^ ext_lib in
let outchan = open_out_bin lib_name in
try
output_string outchan cmxa_magic_number;
(* *)
(***********************************************************************)
-(* $Id: asmpackager.ml,v 1.14.4.2 2005/01/24 15:22:46 doligez Exp $ *)
+(* $Id: asmpackager.ml,v 1.19 2005/08/01 15:51:09 xleroy Exp $ *)
(* "Package" a set of .cmx/.o files into one .cmx/.o file having the
original compilation units as sub-modules. *)
type error =
Illegal_renaming of string * string
| Forward_reference of string * string
+ | Wrong_for_pack of string * string
| Linking_error
| Assembler_error of string
| File_not_found of string
- | No_binutils
+
exception Error of error
pm_name: string;
pm_kind: pack_member_kind }
-let read_member_info file =
+let read_member_info pack_path file =
let name =
String.capitalize(Filename.basename(chop_extension_if_any file)) in
let kind =
let (info, crc) = Compilenv.read_unit_info file in
if info.ui_name <> name
then raise(Error(Illegal_renaming(file, info.ui_name)));
+ if info.ui_symbol <>
+ (Compilenv.current_unit_infos()).ui_symbol ^ "__" ^ info.ui_name
+ then raise(Error(Wrong_for_pack(file, pack_path)));
Asmlink.check_consistency file info crc;
PM_impl info
end else
check (list_remove mb.pm_name forbidden) tl in
check (List.map (fun mb -> mb.pm_name) members) members
-(* Rename symbols in an object file. All defined symbols of the form
- caml[T] or caml[T]__xxx, where [T] belongs to the list [units], are
- replaced by caml[pref]__[T]__xxx . Return the list of renamed symbols. *)
-
-let extract_symbols units symbolfile =
- let symbs = ref [] in
- let ic = open_in symbolfile in
- begin try
- while true do
- let l = input_line ic in
- try
- let i = 3 + (try search_substring " T " l 0 with Not_found ->
- try search_substring " D " l 0 with Not_found ->
- try search_substring " R " l 0 with Not_found ->
- search_substring " S " l 0) in
- let j = try search_substring "__" l i
- with Not_found -> String.length l in
- let k = if l.[i] = '_' then i + 1 else i in
- if j - k > 4 && String.sub l k 4 = "caml"
- && List.mem (String.sub l (k + 4) (j - k - 4)) units then
- symbs := (String.sub l i (String.length l - i)) :: !symbs
- with Not_found ->
- ()
- done
- with End_of_file -> close_in ic
- | x -> close_in ic; raise x
- end;
- !symbs
-
-let max_cmdline_length = 3500 (* safe approximation *)
-
-(* Turn a low-level ident (with leading "caml" or "_caml") back into
- a high-level ident.
-*)
-let remove_leading_caml s =
- if String.length s > 0 && s.[0] = '_'
- then String.sub s 5 (String.length s - 5)
- else String.sub s 4 (String.length s - 4)
-
-(* Insert prefix [p] in a low-level ident (after the "caml" or "_caml"
- prefix).
-*)
-let prefix_symbol p s =
- if String.length s > 0 && s.[0] = '_' then begin
- assert (String.length s > 5 && String.sub s 0 5 = "_caml");
- "_caml" ^ p ^ "__" ^ String.sub s 5 (String.length s - 5)
- end else begin
- assert (String.length s > 4 && String.sub s 0 4 = "caml");
- "caml" ^ p ^ "__" ^ String.sub s 4 (String.length s - 4)
- end
-
-(* Strip leading _ from a low-level ident *)
-
-let strip_underscore s =
- if String.length s > 0 && s.[0] = '_'
- then String.sub s 1 (String.length s - 1)
- else s
-
-(* return the list of symbols to rename in low-level form
- (with the leading "_caml" or "caml")
-*)
-let rename_in_object_file members pref objfile =
- let units = List.map (fun m -> m.pm_name) members in
- let symbolfile = Filename.temp_file "camlsymbols" "" in
- try
- let nm_cmdline =
- sprintf "%s %s > %s"
- Config.binutils_nm
- (Filename.quote objfile) (Filename.quote symbolfile) in
- if Ccomp.command nm_cmdline <> 0 then raise(Error Linking_error);
- let symbols_to_rename =
- extract_symbols units symbolfile in
- let cmdline =
- Buffer.create max_cmdline_length in
- let rec call_objcopy = function
- [] ->
- Buffer.add_char cmdline ' ';
- Buffer.add_string cmdline (Filename.quote objfile);
- if Ccomp.command (Buffer.contents cmdline) <> 0
- then raise(Error Linking_error)
- | s :: rem ->
- if Buffer.length cmdline >= max_cmdline_length then begin
- Buffer.add_char cmdline ' ';
- Buffer.add_string cmdline (Filename.quote objfile);
- if Ccomp.command (Buffer.contents cmdline) <> 0
- then raise(Error Linking_error);
- Buffer.reset cmdline;
- Buffer.add_string cmdline Config.binutils_objcopy
- end;
- bprintf cmdline " --redefine-sym '%s=%s'" s (prefix_symbol pref s);
- call_objcopy rem in
- Buffer.add_string cmdline Config.binutils_objcopy;
- call_objcopy symbols_to_rename;
- remove_file symbolfile;
- symbols_to_rename
- with x ->
- remove_file symbolfile;
- raise x
-
-(* Rename function symbols and global symbols in value approximations *)
-
-let rename_approx mapping_lbl mapping_id approx =
-
- let ren_label lbl =
- try Tbl.find lbl mapping_lbl with Not_found -> lbl in
- let ren_ident id =
- if Ident.persistent id
- then
- let lbl = Ident.name id in
- let newlbl = try Tbl.find lbl mapping_id with Not_found -> lbl in
- Ident.create_persistent newlbl
- else id in
-
- let rec ren_ulambda = function
- Uvar id ->
- Uvar(ren_ident id)
- | Uconst cst ->
- Uconst cst
- | Udirect_apply(lbl, args) ->
- Udirect_apply(ren_label lbl, List.map ren_ulambda args)
- | Ugeneric_apply(fn, args) ->
- Ugeneric_apply(ren_ulambda fn, List.map ren_ulambda args)
- | Uclosure(fns, env) ->
- (* never present in an inlined function body *)
- assert false
- | Uoffset(lam, ofs) -> Uoffset(ren_ulambda lam, ofs)
- | Ulet(id, u, body) -> Ulet(id, ren_ulambda u, ren_ulambda body)
- | Uletrec(defs, body) ->
- (* never present in an inlined function body *)
- assert false
- | Uprim(prim, args) ->
- let prim' =
- match prim with
- Pgetglobal id -> Pgetglobal(ren_ident id)
- | Psetglobal id -> assert false (* never present in inlined fn body *)
- | _ -> prim in
- Uprim(prim', List.map ren_ulambda args)
- | Uswitch(u, cases) ->
- Uswitch(ren_ulambda u,
- {cases with
- us_actions_consts = Array.map ren_ulambda cases.us_actions_consts;
- us_actions_blocks = Array.map ren_ulambda cases.us_actions_blocks})
- | Ustaticfail(tag, args) ->
- Ustaticfail(tag, List.map ren_ulambda args)
- | Ucatch(nfail, ids, u1, u2) ->
- Ucatch(nfail, ids, ren_ulambda u1, ren_ulambda u2)
- | Utrywith(u1, id, u2) ->
- Utrywith(ren_ulambda u1, id, ren_ulambda u2)
- | Uifthenelse(u1, u2, u3) ->
- Uifthenelse(ren_ulambda u1, ren_ulambda u2, ren_ulambda u3)
- | Usequence(u1, u2) ->
- Usequence(ren_ulambda u1, ren_ulambda u2)
- | Uwhile(u1, u2) ->
- Uwhile(ren_ulambda u1, ren_ulambda u2)
- | Ufor(id, u1, u2, dir, u3) ->
- Ufor(id, ren_ulambda u1, ren_ulambda u2, dir, ren_ulambda u3)
- | Uassign(id, u) ->
- Uassign(id, ren_ulambda u)
- | Usend(k, u1, u2, ul) ->
- Usend(k, ren_ulambda u1, ren_ulambda u2, List.map ren_ulambda ul) in
-
- let rec ren_approx = function
- Value_closure(fd, res) ->
- let fd' =
- {fd with
- fun_label = ren_label fd.fun_label;
- fun_inline =
- match fd.fun_inline with
- None -> None
- | Some(params, body) -> Some(params, ren_ulambda body)} in
- Value_closure(fd', ren_approx res)
- | Value_tuple comps ->
- Value_tuple (Array.map ren_approx comps)
- | app -> app
-
- in ren_approx approx
-
-(* Make the .cmx file for the package *)
-
-let build_package_cmx members target symbols_to_rename cmxfile =
- let unit_names =
- List.map (fun m -> m.pm_name) members in
- let filter lst =
- List.filter (fun (name, crc) -> not (List.mem name unit_names)) lst in
- let union lst =
- List.fold_left
- (List.fold_left
- (fun accu n -> if List.mem n accu then accu else n :: accu))
- [] lst in
- let mapping_id =
- let map_id tbl s =
- let high_s = remove_leading_caml s in
- Tbl.add high_s (target ^ "__" ^ high_s) tbl
- in
- List.fold_left map_id Tbl.empty symbols_to_rename
- in
- let mapping_lbl =
- List.fold_left
- (fun tbl s ->
- let s = strip_underscore s in Tbl.add s (prefix_symbol target s) tbl)
- Tbl.empty symbols_to_rename in
- let member_defines m =
- match m.pm_kind with PM_intf -> [] | PM_impl info -> info.ui_defines in
- let defines =
- map_end (fun s -> target ^ "__" ^ s)
- (List.concat (List.map member_defines members))
- [target] in
- let units =
- List.fold_left
- (fun accu m ->
- match m.pm_kind with PM_intf -> accu | PM_impl info -> info :: accu)
- [] members in
- let approx =
- Compilenv.global_approx (Ident.create_persistent target) in
- let pkg_infos =
- { ui_name = target;
- ui_defines = defines;
- ui_imports_cmi = (target, Env.crc_of_unit target) ::
- filter(Asmlink.extract_crc_interfaces());
- ui_imports_cmx = filter(Asmlink.extract_crc_implementations());
- ui_approx = rename_approx mapping_lbl mapping_id approx;
- ui_curry_fun = union(List.map (fun info -> info.ui_curry_fun) units);
- ui_apply_fun = union(List.map (fun info -> info.ui_apply_fun) units);
- 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
- } in
- Compilenv.write_unit_info pkg_infos cmxfile
-
-(* Make the .o file for the package (not renamed yet) *)
+(* Make the .o file for the package *)
let make_package_object ppf members targetobj targetname coercion =
let objtemp = Filename.temp_file "camlpackage" Config.ext_obj in
- Location.input_name := targetname; (* set the name of the "current" input *)
- Compilenv.reset targetname; (* set the name of the "current" compunit *)
let components =
List.map
(fun m ->
remove_file objtemp;
if retcode <> 0 then raise(Error Linking_error)
+(* Make the .cmx file for the package *)
+
+let build_package_cmx members cmxfile =
+ let unit_names =
+ List.map (fun m -> m.pm_name) members in
+ let filter lst =
+ List.filter (fun (name, crc) -> not (List.mem name unit_names)) lst in
+ let union lst =
+ List.fold_left
+ (List.fold_left
+ (fun accu n -> if List.mem n accu then accu else n :: accu))
+ [] lst in
+ let units =
+ List.fold_left
+ (fun accu m ->
+ match m.pm_kind with PM_intf -> accu | PM_impl info -> info :: accu)
+ [] members in
+ let ui = Compilenv.current_unit_infos() in
+ let pkg_infos =
+ { ui_name = ui.ui_name;
+ ui_symbol = ui.ui_symbol;
+ ui_defines =
+ ui.ui_symbol ::
+ union (List.map (fun info -> info.ui_defines) units);
+ ui_imports_cmi =
+ (ui.ui_name, Env.crc_of_unit ui.ui_name) ::
+ filter(Asmlink.extract_crc_interfaces());
+ ui_imports_cmx =
+ filter(Asmlink.extract_crc_implementations());
+ ui_approx = ui.ui_approx;
+ ui_curry_fun =
+ union(List.map (fun info -> info.ui_curry_fun) units);
+ ui_apply_fun =
+ union(List.map (fun info -> info.ui_apply_fun) units);
+ 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
+ } in
+ Compilenv.write_unit_info pkg_infos cmxfile
+
(* Make the .cmx and the .o for the package *)
let package_object_files ppf files targetcmx
targetobj targetname coercion =
- let members = map_left_right read_member_info files in
+ let pack_path =
+ match !Clflags.for_package with
+ | None -> targetname
+ | Some p -> p ^ "." ^ targetname in
+ let members = map_left_right (read_member_info pack_path) files in
check_units members;
make_package_object ppf members targetobj targetname coercion;
- let symbols = rename_in_object_file members targetname targetobj in
- build_package_cmx members targetname symbols targetcmx
+ build_package_cmx members targetcmx
(* The entry point *)
let package_files ppf files targetcmx =
- if Config.binutils_objcopy = "" || Config.binutils_nm = ""
- then raise (Error No_binutils);
let files =
List.map
(fun f ->
let targetcmi = prefix ^ ".cmi" in
let targetobj = prefix ^ Config.ext_obj in
let targetname = String.capitalize(Filename.basename prefix) in
+ (* Set the name of the current "input" *)
+ Location.input_name := targetcmx;
+ (* Set the name of the current compunit *)
+ Compilenv.reset ?packname:!Clflags.for_package targetname;
try
let coercion = Typemod.package_units files targetcmi targetname in
package_object_files ppf files targetcmx targetobj targetname coercion
file id
| Forward_reference(file, ident) ->
fprintf ppf "Forward reference to %s in file %s" ident file
+ | Wrong_for_pack(file, path) ->
+ fprintf ppf "File %s@ was not compiled with the `-pack %s' option"
+ file path
| File_not_found file ->
fprintf ppf "File %s not found" file
| Assembler_error file ->
fprintf ppf "Error while assembling %s" file
| Linking_error ->
fprintf ppf "Error during partial linking"
- | No_binutils ->
- fprintf ppf "ocamlopt -pack is not supported on this platform.@ \
- Reason: the GNU `binutils' tools are not available"
(* *)
(***********************************************************************)
-(* $Id: asmpackager.mli,v 1.1 2002/02/08 16:55:30 xleroy Exp $ *)
+(* $Id: asmpackager.mli,v 1.2 2005/08/01 15:51:09 xleroy Exp $ *)
(* "Package" a set of .cmx/.o files into one .cmx/.o file having the
original compilation units as sub-modules. *)
type error =
Illegal_renaming of string * string
| Forward_reference of string * string
+ | Wrong_for_pack of string * string
| Linking_error
| Assembler_error of string
| File_not_found of string
- | No_binutils
exception Error of error
(* *)
(***********************************************************************)
-(* $Id: closure.ml,v 1.44 2004/05/26 11:10:27 garrigue Exp $ *)
+(* $Id: closure.ml,v 1.48 2005/10/24 09:05:27 xleroy Exp $ *)
(* Introduction of closures, uncurrying, recognition of direct calls *)
clashes with locally-generated identifiers.
The variables must not be assigned in the term.
This is used to substitute "trivial" arguments for parameters
- during inline expansion. *)
+ during inline expansion, and also for the translation of let rec
+ over functions. *)
let approx_ulam = function
Uconst(Const_base(Const_int n)) -> Value_integer n
| Ugeneric_apply(fn, args) ->
Ugeneric_apply(substitute sb fn, List.map (substitute sb) args)
| Uclosure(defs, env) ->
- (* never present in an inlined function body; painful to get right *)
- assert false
+ (* Question: should we rename function labels as well? Otherwise,
+ there is a risk that function labels are not globally unique.
+ This should not happen in the current system because:
+ - Inlined function bodies contain no Uclosure nodes
+ (cf. function [lambda_smaller])
+ - When we substitute offsets for idents bound by let rec
+ in [close], case [Lletrec], we discard the original
+ let rec body and use only the substituted term. *)
+ Uclosure(defs, List.map (substitute sb) env)
| Uoffset(u, ofs) -> Uoffset(substitute sb u, ofs)
| Ulet(id, u1, u2) ->
let id' = Ident.rename id in
Ulet(id', substitute sb u1, substitute (Tbl.add id (Uvar id') sb) u2)
| Uletrec(bindings, body) ->
- (* never present in an inlined function body; painful to get right *)
- assert false
+ let bindings1 =
+ List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in
+ let sb' =
+ List.fold_right
+ (fun (id, id', _) s -> Tbl.add id (Uvar id') s)
+ bindings1 sb in
+ Uletrec(
+ List.map (fun (id, id', rhs) -> (id', substitute sb' rhs)) bindings1,
+ substitute sb' body)
| Uprim(p, args) ->
let sargs = List.map (substitute sb) args in
let (res, _) = simplif_prim p (sargs, List.map approx_ulam sargs) in
| Uconst(Const_base(Const_string _)) -> true
| u -> is_simple_argument u
-let rec bind_params subst params args body =
+let rec bind_params_rec subst params args body =
match (params, args) with
([], []) -> substitute subst body
| (p1 :: pl, a1 :: al) ->
if is_simple_argument a1 then
- bind_params (Tbl.add p1 a1 subst) pl al body
+ bind_params_rec (Tbl.add p1 a1 subst) pl al body
else begin
let p1' = Ident.rename p1 in
- let body' = bind_params (Tbl.add p1 (Uvar p1') subst) pl al body in
+ let body' =
+ bind_params_rec (Tbl.add p1 (Uvar p1') subst) pl al body in
if occurs_var p1 body then Ulet(p1', a1, body')
else if no_effects a1 then body'
else Usequence(a1, body')
end
| (_, _) -> assert false
+let bind_params params args body =
+ (* Reverse parameters and arguments to preserve right-to-left
+ evaluation order (PR#2910). *)
+ bind_params_rec Tbl.empty (List.rev params) (List.rev args) body
+
(* Check if a lambda term is ``pure'',
that is without side-effects *and* not containing function definitions *)
let app =
match fundesc.fun_inline with
None -> Udirect_apply(fundesc.fun_label, app_args)
- | Some(params, body) -> bind_params Tbl.empty params app_args body in
+ | Some(params, body) -> bind_params params app_args body in
(* If ufunct can contain side-effects or function definitions,
we must make sure that it is evaluated exactly once.
If the function is not closed, we evaluate ufunct as part of the
(fun (id, pos, approx) fenv -> Tbl.add id approx fenv)
infos fenv in
let (ubody, approx) = close fenv_body cenv body in
- (Ulet(clos_ident, clos,
- List.fold_right
- (fun (id, pos, approx) body ->
- Ulet(id, Uoffset(Uvar clos_ident, pos), body))
- infos ubody),
+ let sb =
+ List.fold_right
+ (fun (id, pos, approx) sb ->
+ Tbl.add id (Uoffset(Uvar clos_ident, pos)) sb)
+ infos Tbl.empty in
+ (Ulet(clos_ident, clos, substitute sb ubody),
approx)
end else begin
(* General case: recursive definition of values *)
Value_unknown)
| Lprim(p, args) ->
simplif_prim p (close_list_approx fenv cenv args)
- | Lswitch(arg, sw) as l ->
+ | Lswitch(arg, sw) ->
(* NB: failaction might get copied, thus it should be some Lstaticraise *)
let (uarg, _) = close fenv cenv arg in
let const_index, const_actions =
let uncurried_defs =
List.map
(function
- (id, (Lfunction(kind, params, body) as def)) ->
+ (id, Lfunction(kind, params, body)) ->
let label = Compilenv.make_symbol (Some (Ident.unique_name id)) in
let arity = List.length params in
let fundesc =
(* *)
(***********************************************************************)
-(* $Id: cmmgen.ml,v 1.100 2004/05/26 11:10:27 garrigue Exp $ *)
+(* $Id: cmmgen.ml,v 1.103 2005/08/01 15:51:09 xleroy Exp $ *)
(* Translation from closed lambda to C-- *)
else arg in
Cop(Calloc, [alloc_boxedint_header;
Cconst_symbol(operations_boxed_int bi);
- arg])
+ arg'])
let unbox_int bi arg =
match arg with
| Uprim(prim, args) ->
begin match (simplif_primitive prim, args) with
(Pgetglobal id, []) ->
- if Ident.is_predef_exn id
- then Cconst_symbol ("caml_exn_" ^ (Ident.name id))
- else Cconst_symbol (Compilenv.make_symbol ~unitname:(Ident.name id)
- None)
+ Cconst_symbol (Compilenv.symbol_for_global id)
| (Pmakeblock(tag, mut), []) ->
transl_constant(Const_block(tag, []))
| (Pmakeblock(tag, mut), args) ->
(* Boolean operations *)
| Psequand ->
Cifthenelse(test_bool(transl arg1), transl arg2, Cconst_int 1)
+ (* let id = Ident.create "res1" in
+ Clet(id, transl arg1,
+ Cifthenelse(test_bool(Cvar id), transl arg2, Cvar id)) *)
| Psequor ->
Cifthenelse(test_bool(transl arg1), Cconst_int 3, transl arg2)
(* Emit structured constants *)
+let immstrings = Hashtbl.create 17
+
let rec emit_constant symb cst cont =
match cst with
Const_base(Const_float s) ->
Cint(float_header) :: Cdefine_symbol symb :: Cdouble s :: cont
- | Const_base(Const_string s) ->
+ | Const_base(Const_string s) | Const_immstring s ->
Cint(string_header (String.length s)) ::
Cdefine_symbol symb ::
emit_string_constant s cont
(Clabel_address lbl,
Cint(string_header (String.length s)) :: Cdefine_label lbl ::
emit_string_constant s cont)
+ | Const_immstring s ->
+ begin try
+ (Clabel_address (Hashtbl.find immstrings s), cont)
+ with Not_found ->
+ let lbl = new_const_label() in
+ Hashtbl.add immstrings s lbl;
+ (Clabel_address lbl,
+ Cint(string_header (String.length s)) :: Cdefine_label lbl ::
+ emit_string_constant s cont)
+ end
| Const_base(Const_int32 n) ->
let lbl = new_const_label() in
(Clabel_address lbl,
(* *)
(***********************************************************************)
-(* $Id: coloring.ml,v 1.12 2000/12/28 13:02:49 weis Exp $ *)
+(* $Id: coloring.ml,v 1.13 2004/08/12 13:34:42 xleroy Exp $ *)
(* Register allocation by coloring of the interference graph *)
start_register.(cl) <- (if start+1 >= num_regs then 0 else start+1)
end else begin
(* Sorry, we must put the pseudoreg in a stack location *)
- (* First, check if we have a preference for an incoming location
- we do not conflict with. *)
- let best_score = ref 0 and best_incoming_loc = ref (-1) in
+ let nslots = Proc.num_stack_slots.(cl) in
+ let score = Array.create nslots 0 in
+ (* Compute the scores as for registers *)
List.iter
(fun (r, w) ->
match r.loc with
- Stack(Incoming n) ->
- if w > !best_score
- && List.for_all (fun neighbour -> neighbour.loc <> r.loc)
- reg.interf
- then begin
- best_score := w;
- best_incoming_loc := n
- end
+ Stack(Local n) -> if Proc.register_class r = cl then
+ score.(n) <- score.(n) + w
+ | Unknown ->
+ List.iter
+ (fun neighbour ->
+ match neighbour.loc with
+ Stack(Local n) ->
+ if Proc.register_class neighbour = cl
+ then score.(n) <- score.(n) - w
+ | _ -> ())
+ r.interf
| _ -> ())
reg.prefer;
- if !best_incoming_loc >= 0 then
- reg.loc <- Stack(Incoming !best_incoming_loc)
- else begin
- (* Now, look for a location in the local area *)
- let nslots = Proc.num_stack_slots.(cl) in
- let score = Array.create nslots 0 in
- (* Compute the scores as for registers *)
- List.iter
- (fun (r, w) ->
- match r.loc with
- Stack(Local n) -> if Proc.register_class r = cl then
- score.(n) <- score.(n) + w
- | Unknown ->
- List.iter
- (fun neighbour ->
- match neighbour.loc with
- Stack(Local n) ->
- if Proc.register_class neighbour = cl
- then score.(n) <- score.(n) - w
- | _ -> ())
- r.interf
- | _ -> ())
- reg.prefer;
- List.iter
- (fun neighbour ->
- begin match neighbour.loc with
- Stack(Local n) ->
- if Proc.register_class neighbour = cl then
- score.(n) <- (-1000000)
- | _ -> ()
- end;
- List.iter
- (fun (r, w) ->
- match r.loc with
- Stack(Local n) -> if Proc.register_class r = cl then
- score.(n) <- score.(n) - w
- | _ -> ())
- neighbour.prefer)
- reg.interf;
- (* Pick the location with the best score *)
- let best_score = ref (-1000000) and best_slot = ref (-1) in
- for n = 0 to nslots - 1 do
- if score.(n) > !best_score then begin
- best_score := score.(n);
- best_slot := n
- end
- done;
- (* Found one? *)
- if !best_slot >= 0 then
- reg.loc <- Stack(Local !best_slot)
- else begin
- (* Allocate a new stack slot *)
- reg.loc <- Stack(Local nslots);
- Proc.num_stack_slots.(cl) <- nslots + 1
+ List.iter
+ (fun neighbour ->
+ begin match neighbour.loc with
+ Stack(Local n) ->
+ if Proc.register_class neighbour = cl then
+ score.(n) <- (-1000000)
+ | _ -> ()
+ end;
+ List.iter
+ (fun (r, w) ->
+ match r.loc with
+ Stack(Local n) -> if Proc.register_class r = cl then
+ score.(n) <- score.(n) - w
+ | _ -> ())
+ neighbour.prefer)
+ reg.interf;
+ (* Pick the location with the best score *)
+ let best_score = ref (-1000000) and best_slot = ref (-1) in
+ for n = 0 to nslots - 1 do
+ if score.(n) > !best_score then begin
+ best_score := score.(n);
+ best_slot := n
end
+ done;
+ (* Found one? *)
+ if !best_slot >= 0 then
+ reg.loc <- Stack(Local !best_slot)
+ else begin
+ (* Allocate a new stack slot *)
+ reg.loc <- Stack(Local nslots);
+ Proc.num_stack_slots.(cl) <- nslots + 1
end
end;
(* Cancel the preferences of this register so that they don't influence
(* *)
(***********************************************************************)
-(* $Id: compilenv.ml,v 1.21 2004/05/26 11:10:28 garrigue Exp $ *)
+(* $Id: compilenv.ml,v 1.22 2005/08/01 15:51:09 xleroy Exp $ *)
(* Compilation environments for compilation units *)
type unit_infos =
{ mutable ui_name: string; (* Name of unit implemented *)
+ mutable ui_symbol: string; (* Prefix for symbols *)
mutable ui_defines: string list; (* Unit and sub-units implemented *)
mutable ui_imports_cmi: (string * Digest.t) list; (* Interfaces imported *)
mutable ui_imports_cmx: (string * Digest.t) list; (* Infos imported *)
lib_ccobjs: string list; (* C object files needed *)
lib_ccopts: string list } (* Extra opts to C compiler *)
-let global_approx_table =
- (Hashtbl.create 17 : (string, value_approximation) Hashtbl.t)
+let global_infos_table =
+ (Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t)
let current_unit =
{ ui_name = "";
+ ui_symbol = "";
ui_defines = [];
ui_imports_cmi = [];
ui_imports_cmx = [];
ui_send_fun = [];
ui_force_link = false }
-let reset name =
- Hashtbl.clear global_approx_table;
+let symbolname_for_pack pack name =
+ match pack with
+ | None -> name
+ | Some p ->
+ let b = Buffer.create 64 in
+ for i = 0 to String.length p - 1 do
+ match p.[i] with
+ | '.' -> Buffer.add_string b "__"
+ | c -> Buffer.add_char b c
+ done;
+ Buffer.add_string b "__";
+ Buffer.add_string b name;
+ Buffer.contents b
+
+let reset ?packname name =
+ Hashtbl.clear global_infos_table;
+ let symbol = symbolname_for_pack packname name in
current_unit.ui_name <- name;
- current_unit.ui_defines <- [name];
+ current_unit.ui_symbol <- symbol;
+ current_unit.ui_defines <- [symbol];
current_unit.ui_imports_cmi <- [];
current_unit.ui_imports_cmx <- [];
current_unit.ui_curry_fun <- [];
current_unit.ui_send_fun <- [];
current_unit.ui_force_link <- false
+let current_unit_infos () =
+ current_unit
+
let current_unit_name () =
current_unit.ui_name
-let make_symbol ?(unitname = current_unit.ui_name) idopt =
+let make_symbol ?(unitname = current_unit.ui_symbol) idopt =
let prefix = "caml" ^ unitname in
match idopt with
| None -> prefix
close_in ic;
raise(Error(Corrupted_unit_info(filename)))
-(* Return the approximation of a global identifier *)
+(* Read and cache info on global identifiers *)
let cmx_not_found_crc =
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
-let global_approx global_ident =
+let get_global_info global_ident =
let modname = Ident.name global_ident in
if modname = current_unit.ui_name then
- current_unit.ui_approx
+ Some current_unit
else begin
try
- Hashtbl.find global_approx_table modname
+ Hashtbl.find global_infos_table modname
with Not_found ->
- let (approx, crc) =
+ let (infos, crc) =
try
let filename =
find_in_path_uncap !load_path (modname ^ ".cmx") in
let (ui, crc) = read_unit_info filename in
if ui.ui_name <> modname then
raise(Error(Illegal_renaming(ui.ui_name, filename)));
- (ui.ui_approx, crc)
+ (Some ui, crc)
with Not_found ->
- (Value_unknown, cmx_not_found_crc) in
+ (None, cmx_not_found_crc) in
current_unit.ui_imports_cmx <-
(modname, crc) :: current_unit.ui_imports_cmx;
- Hashtbl.add global_approx_table modname approx;
- approx
+ Hashtbl.add global_infos_table modname infos;
+ infos
+ end
+
+(* Return the approximation of a global identifier *)
+
+let global_approx id =
+ match get_global_info id with
+ | None -> Value_unknown
+ | Some ui -> ui.ui_approx
+
+(* Return the symbol used to refer to a global identifier *)
+
+let symbol_for_global id =
+ if Ident.is_predef_exn id then
+ "caml_exn_" ^ Ident.name id
+ else begin
+ match get_global_info id with
+ | None -> make_symbol ~unitname:(Ident.name id) None
+ | Some ui -> make_symbol ~unitname:ui.ui_symbol None
end
(* Register the approximation of the module being compiled *)
(* *)
(***********************************************************************)
-(* $Id: compilenv.mli,v 1.14 2004/05/26 11:10:28 garrigue Exp $ *)
+(* $Id: compilenv.mli,v 1.15 2005/08/01 15:51:09 xleroy Exp $ *)
(* Compilation environments for compilation units *)
type unit_infos =
{ mutable ui_name: string; (* Name of unit implemented *)
+ mutable ui_symbol: string; (* Prefix for symbols *)
mutable ui_defines: string list; (* Unit and sub-units implemented *)
mutable ui_imports_cmi: (string * Digest.t) list; (* Interfaces imported *)
mutable ui_imports_cmx: (string * Digest.t) list; (* Infos imported *)
lib_ccobjs: string list; (* C object files needed *)
lib_ccopts: string list } (* Extra opts to C compiler *)
-val reset: string -> unit
+val reset: ?packname:string -> string -> unit
(* Reset the environment and record the name of the unit being
- compiled (arg). *)
+ compiled (arg). Optional argument is [-for-pack] prefix. *)
+
+val current_unit_infos: unit -> unit_infos
+ (* Return the infos for the unit being compiled *)
val current_unit_name: unit -> string
(* Return the name of the unit being compiled *)
corresponds to symbol [id] in the compilation unit [u]
(or the current unit). *)
+val symbol_for_global: Ident.t -> string
+ (* Return the asm symbol that refers to the given global identifier *)
+
val global_approx: Ident.t -> Clambda.value_approximation
(* Return the approximation for the given global identifier *)
val set_global_approx: Clambda.value_approximation -> unit
(* *)
(***********************************************************************)
-(* $Id: emit.mlp,v 1.32 2004/05/03 12:46:50 xleroy Exp $ *)
+(* $Id: emit.mlp,v 1.35 2004/11/30 17:07:11 xleroy Exp $ *)
(* Emission of Intel 386 assembly code *)
let slot_offset loc cl =
match loc with
- Incoming n -> frame_size() + n
+ Incoming n ->
+ assert (n >= 0);
+ frame_size() + n
| Local n ->
if cl = 0
then !stack_offset + n * 4
else !stack_offset + num_stack_slots.(0) * 4 + n * 8
- | Outgoing n -> n
+ | Outgoing n ->
+ assert (n >= 0);
+ n
(* Prefixing of symbols with "_" *)
let emit_reg = function
{ loc = Reg r } ->
emit_string (register_name r)
+ | { loc = Stack(Incoming n | Outgoing n) } when n < 0 ->
+ `{emit_symbol "caml_extra_params"} + {emit_int (n + 64)}`
| { loc = Stack s } as r ->
let ofs = slot_offset s (register_class r) in
`{emit_int ofs}(%esp)`
` addl ${emit_int(n-1)}, {emit_reg i.arg.(0)}\n`;
`{emit_label lbl}: sarl ${emit_int l}, {emit_reg i.arg.(0)}\n`
| Lop(Iintop_imm(Imod, n)) ->
- let l = Misc.log2 n in
let lbl = new_label() in
` movl {emit_reg i.arg.(0)}, %eax\n`;
` testl %eax, %eax\n`;
(* *)
(***********************************************************************)
-(* $Id: emit_nt.mlp,v 1.24 2004/05/03 12:46:50 xleroy Exp $ *)
+(* $Id: emit_nt.mlp,v 1.25 2004/08/12 14:29:25 xleroy Exp $ *)
(* Emission of Intel 386 assembly code, MASM syntax. *)
let slot_offset loc cl =
match loc with
- Incoming n -> frame_size() + n
+ Incoming n ->
+ assert (n >= 0);
+ frame_size() + n
| Local n ->
if cl = 0
then !stack_offset + n * 4
else !stack_offset + num_stack_slots.(0) * 4 + n * 8
- | Outgoing n -> n
-
+ | Outgoing n ->
+ assert (n >= 0);
+ n
(* Record symbols used and defined - at the end generate extern for those
used but not defined *)
let emit_reg = function
{ loc = Reg r } ->
emit_string (register_name r)
+ | { loc = Stack(Incoming n | Outgoing n) } when n < 0 ->
+ `{emit_symbol "caml_extra_params"} + {emit_int (n + 64)}`
| { loc = Stack s; typ = Float } as r ->
let ofs = slot_offset s (register_class r) in
`REAL8 PTR {emit_int ofs}[esp]`
` EXTERN _caml_young_ptr: DWORD\n`;
` EXTERN _caml_young_limit: DWORD\n`;
` EXTERN _caml_exception_pointer: DWORD\n`;
+ ` EXTERN _caml_extra_params: DWORD\n`;
` EXTERN _caml_call_gc: PROC\n`;
` EXTERN _caml_c_call: PROC\n`;
` EXTERN _caml_allocN: PROC\n`;
(* *)
(***********************************************************************)
-(* $Id: proc.ml,v 1.8 2003/06/15 09:58:31 xleroy Exp $ *)
+(* $Id: proc.ml,v 1.9 2004/08/12 13:37:12 xleroy Exp $ *)
(* Description of the Intel 386 processor *)
(* 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 ->
ofs := !ofs + size_float
end
done;
- (loc, !ofs)
+ (loc, max 0 !ofs)
let incoming ofs = Incoming ofs
let outgoing ofs = Outgoing ofs
(* *)
(***********************************************************************)
-(* $Id: emit.mlp,v 1.16.4.1 2004/07/12 15:03:19 xleroy Exp $ *)
+(* $Id: emit.mlp,v 1.17 2004/07/13 12:18:53 xleroy Exp $ *)
(* Emission of IA64 assembly code *)
(* *)
(***********************************************************************)
-(* $Id: schedgen.ml,v 1.10 2000/12/28 13:02:54 weis Exp $ *)
+(* $Id: schedgen.ml,v 1.11 2004/11/29 14:49:22 doligez Exp $ *)
(* Instruction scheduling *)
| Lop(Icall_imm _ | Itailcall_imm _ | Iextcall(_, _)) -> [||]
| Lreturn -> [||]
| _ -> i.arg in
- List.iter (fun x -> let len = longest_path critical_outputs x in ())
- ready_queue;
+ List.iter (fun x -> ignore (longest_path critical_outputs x)) ready_queue;
self#reschedule ready_queue 0 (schedule i)
end in
(* *)
(***********************************************************************)
-(* $Id: emit.mlp,v 1.21 2004/01/05 20:25:56 doligez Exp $ *)
+(* $Id: emit.mlp,v 1.23 2005/10/07 09:34:19 garrigue Exp $ *)
(* Emission of Sparc assembly code *)
open Linearize
open Emitaux
+(* Solaris vs. the other ports *)
+
+let solaris = Config.system = "solaris"
+
(* Tradeoff between code size and code speed *)
let fastcode_flag = ref true
let function_name = ref ""
let tailrec_entry_point = ref 0
+let range_check_trap = ref 0
let rec emit_instr i dslot =
match i.desc with
end
| Lop(Ialloc n) ->
if !fastcode_flag then begin
- let indirect = Config.system <> "solaris" in
let lbl_cont = new_label() in
- if indirect then
+ if solaris then begin
+ ` sub %l6, {emit_int n}, %l6\n`;
+ ` cmp %l6, %l7\n`
+ end else begin
` ld [%l7], %g1\n`;
- ` sub %l6, {emit_int n}, %l6\n`;
- if indirect then
+ ` sub %l6, {emit_int n}, %l6\n`;
` cmp %l6, %g1\n`
- else
- ` cmp %l6, %l7\n`;
+ end;
` bgeu {emit_label lbl_cont}\n`;
` add %l6, 4, {emit_reg i.res.(0)}\n`; (* in delay slot *)
`{record_frame i.live} call {emit_symbol "caml_call_gc"}\n`;
end
| Lop(Iintop Icheckbound) ->
` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
- ` tleu 5\n` (* 5 = ST_RANGE_CHECK *)
+ if solaris then
+ ` tleu 5\n` (* 5 = ST_RANGE_CHECK *)
+ else begin
+ if !range_check_trap = 0 then range_check_trap := new_label();
+ ` bleu {emit_label !range_check_trap}\n`;
+ ` nop\n` (* delay slot *)
+ end
| Lop(Iintop Idiv) ->
` sra {emit_reg i.arg.(0)}, 31, %g1\n`;
` wr %g1, %y\n`;
` sdiv {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`
end
| Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *)
- let log = Misc.log2 n in
let lbl = new_label() in
` tst {emit_reg i.arg.(0)}\n`;
` bge {emit_label lbl}\n`;
end
| Lop(Iintop_imm(Icheckbound, n)) ->
` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`;
- ` tleu 5\n` (* 5 = ST_RANGE_CHECK *)
+ if solaris then
+ ` tleu 5\n` (* 5 = ST_RANGE_CHECK *)
+ else begin
+ if !range_check_trap = 0 then range_check_trap := new_label();
+ ` bleu {emit_label !range_check_trap}\n`;
+ ` nop\n` (* delay slot *)
+ end
| Lop(Iintop_imm(op, n)) ->
let instr = name_for_int_operation op in
` {emit_string instr} {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`
function_name := fundecl.fun_name;
fastcode_flag := fundecl.fun_fast;
tailrec_entry_point := new_label();
+ range_check_trap := 0;
stack_offset := 0;
float_constants := [];
` .text\n`;
` st %o7, [%sp + {emit_int(n - 4 + 96)}]\n`;
`{emit_label !tailrec_entry_point}:\n`;
emit_all fundecl.fun_body;
+ if !range_check_trap > 0 then begin
+ `{emit_label !range_check_trap}:\n`;
+ ` call {emit_symbol "caml_ml_array_bound_error"}\n`;
+ ` nop\n`
+ end;
emit_size fundecl.fun_name;
List.iter emit_float_constant !float_constants
../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
../byterun/callback.h ../byterun/memory.h ../byterun/gc.h \
../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/fail.h ../byterun/signals.h stack.h ../byterun/sys.h
+ ../byterun/fail.h ../byterun/osdeps.h ../byterun/signals.h \
+ ../byterun/signals_machdep.h signals_osdep.h stack.h ../byterun/sys.h
startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \
../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \
../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
../byterun/callback.h ../byterun/memory.h ../byterun/gc.h \
../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/fail.h ../byterun/signals.h stack.h ../byterun/sys.h
+ ../byterun/fail.h ../byterun/osdeps.h ../byterun/signals.h \
+ ../byterun/signals_machdep.h signals_osdep.h stack.h ../byterun/sys.h
startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \
../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \
../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \
../byterun/callback.h ../byterun/memory.h ../byterun/gc.h \
../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
- ../byterun/fail.h ../byterun/signals.h stack.h ../byterun/sys.h
+ ../byterun/fail.h ../byterun/osdeps.h ../byterun/signals.h \
+ ../byterun/signals_machdep.h signals_osdep.h stack.h ../byterun/sys.h
startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \
../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \
../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \
/* */
/***********************************************************************/
-/* $Id: amd64.S,v 1.8.4.1 2004/07/01 16:09:03 xleroy Exp $ */
+/* $Id: amd64.S,v 1.9 2004/07/13 12:18:53 xleroy Exp $ */
/* Asm part of the runtime system, AMD64 processor */
/* Must be preprocessed by cpp */
/* */
/***********************************************************************/
-/* $Id: i386.S,v 1.42 2004/01/03 12:51:19 doligez Exp $ */
+/* $Id: i386.S,v 1.43 2004/08/12 13:37:12 xleroy Exp $ */
/* Asm part of the runtime system, Intel 386 processor */
/* Must be preprocessed by cpp */
.value -1 /* negative frame size => use callback link */
.value 0 /* no roots here */
#endif
+
+ .globl G(caml_extra_params)
+G(caml_extra_params):
+#ifndef SYS_solaris
+ .space 64
+#else
+ .zero 64
+#endif
;
;*********************************************************************
-; $Id: i386nt.asm,v 1.17 2004/05/04 09:02:47 xleroy Exp $
+; $Id: i386nt.asm,v 1.19 2005/10/12 12:56:53 xleroy Exp $
; Asm part of the runtime system, Intel 386 processor, Intel syntax
WORD -1 ; negative frame size => use callback link
WORD 0 ; no roots here
+ PUBLIC _caml_extra_params
+_caml_extra_params LABEL DWORD
+ BYTE 64 DUP (?)
+
END
+
/* */
/***********************************************************************/
-/* $Id: mips.s,v 1.11.4.1 2004/07/13 08:01:59 xleroy Exp $ */
+/* $Id: mips.s,v 1.12 2004/07/13 12:18:53 xleroy Exp $ */
/* Asm part of the runtime system, Mips processor, IRIX n32 conventions */
/* */
/***********************************************************************/
-/* $Id: roots.c,v 1.37 2004/01/02 19:22:19 doligez Exp $ */
+/* $Id: roots.c,v 1.38 2005/09/22 14:21:47 xleroy Exp $ */
/* To walk the memory roots for garbage collection */
/* The hashtable of frame descriptors */
typedef struct {
- unsigned long retaddr;
+ uintnat retaddr;
short frame_size;
short num_live;
short live_ofs[1];
static int frame_descriptors_mask;
#define Hash_retaddr(addr) \
- (((unsigned long)(addr) >> 3) & frame_descriptors_mask)
+ (((uintnat)(addr) >> 3) & frame_descriptors_mask)
static void init_frame_descriptors(void)
{
- long num_descr, tblsize, i, j, len;
- long * tbl;
+ intnat num_descr, tblsize, i, j, len;
+ intnat * tbl;
frame_descr * d;
- unsigned long h;
+ uintnat h;
/* Count the frame descriptors */
num_descr = 0;
}
frame_descriptors[h] = d;
d = (frame_descr *)
- (((unsigned long)d +
+ (((uintnat)d +
sizeof(char *) + sizeof(short) + sizeof(short) +
sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
& -sizeof(frame_descr *));
/* Communication with [caml_start_program] and [caml_call_gc]. */
char * caml_bottom_of_stack = NULL; /* no stack initially */
-unsigned long caml_last_return_address = 1; /* not in Caml code initially */
+uintnat caml_last_return_address = 1; /* not in Caml code initially */
value * caml_gc_regs;
-long caml_globals_inited = 0;
-static long caml_globals_scanned = 0;
+intnat caml_globals_inited = 0;
+static intnat caml_globals_scanned = 0;
/* Call [caml_oldify_one] on (at least) all the roots that point to the minor
heap. */
void caml_oldify_local_roots (void)
{
char * sp;
- unsigned long retaddr;
+ uintnat retaddr;
value * regs;
frame_descr * d;
- unsigned long h;
+ uintnat h;
int i, j, n, ofs;
short * p;
value glob;
}
void caml_do_local_roots(scanning_action f, char * bottom_of_stack,
- unsigned long last_retaddr, value * gc_regs,
+ uintnat last_retaddr, value * gc_regs,
struct caml__roots_block * local_roots)
{
char * sp;
- unsigned long retaddr;
+ uintnat retaddr;
value * regs;
frame_descr * d;
- unsigned long h;
+ uintnat h;
int i, j, n, ofs;
short * p;
value * root;
/* */
/***********************************************************************/
-/* $Id: signals.c,v 1.81 2004/06/19 16:13:32 xleroy Exp $ */
+/* $Id: signals.c,v 1.93 2005/10/13 07:41:34 xleroy Exp $ */
+#if defined(TARGET_amd64) && defined (SYS_linux)
+#define _GNU_SOURCE
+#endif
#include <signal.h>
#include <stdio.h>
-#if defined(TARGET_sparc) && defined(SYS_solaris)
-#include <ucontext.h>
-#endif
#include "alloc.h"
#include "callback.h"
#include "memory.h"
#include "misc.h"
#include "mlvalues.h"
#include "fail.h"
+#include "osdeps.h"
#include "signals.h"
+#include "signals_machdep.h"
+#include "signals_osdep.h"
#include "stack.h"
#include "sys.h"
#ifdef HAS_STACK_OVERFLOW_DETECTION
#include <sys/resource.h>
#endif
-extern char * caml_code_area_start, * caml_code_area_end;
-
-#define In_code_area(pc) \
- ((char *)(pc) >= caml_code_area_start && (char *)(pc) <= caml_code_area_end)
+#ifndef NSIG
+#define NSIG 64
+#endif
#ifdef _WIN32
typedef void (*sighandler)(int sig);
#define signal(sig,act) caml_win32_signal(sig,act)
#endif
-#if defined(TARGET_power) && defined(SYS_rhapsody)
+extern char * caml_code_area_start, * caml_code_area_end;
- #include <sys/utsname.h>
+#define In_code_area(pc) \
+ ((char *)(pc) >= caml_code_area_start && \
+ (char *)(pc) <= caml_code_area_end)
- #define STRUCT_SIGCONTEXT void
- #define CONTEXT_GPR(ctx, regno) (*context_gpr_p ((ctx), (regno)))
- #define CONTEXT_PC(ctx) CONTEXT_GPR ((ctx), -2)
- 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");
- }
+volatile intnat caml_pending_signals[NSIG];
+volatile int caml_force_major_slice = 0;
+value caml_signal_handlers = 0;
+
+static void caml_process_pending_signals(void)
+{
+ int signal_num;
+ intnat signal_state;
+
+ for (signal_num = 0; signal_num < NSIG; signal_num++) {
+ Read_and_clear(signal_state, caml_pending_signals[signal_num]);
+ if (signal_state) caml_execute_signal(signal_num, 0);
}
+}
- #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]);
- }
- #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]);
- }
- #endif
-#endif
+static intnat volatile caml_async_signal_mode = 0;
-volatile int caml_async_signal_mode = 0;
-volatile int caml_pending_signal = 0;
-volatile int caml_force_major_slice = 0;
-value caml_signal_handlers = 0;
-void (*caml_enter_blocking_section_hook)() = NULL;
-void (*caml_leave_blocking_section_hook)() = NULL;
+static void caml_enter_blocking_section_default(void)
+{
+ Assert (caml_async_signal_mode == 0);
+ caml_async_signal_mode = 1;
+}
+
+static void caml_leave_blocking_section_default(void)
+{
+ Assert (caml_async_signal_mode == 1);
+ caml_async_signal_mode = 0;
+}
+
+static int caml_try_leave_blocking_section_default(void)
+{
+ intnat res;
+ Read_and_clear(res, caml_async_signal_mode);
+ return res;
+}
-static int rev_convert_signal_number(int signo);
+CAMLexport void (*caml_enter_blocking_section_hook)(void) =
+ caml_enter_blocking_section_default;
+CAMLexport void (*caml_leave_blocking_section_hook)(void) =
+ caml_leave_blocking_section_default;
+CAMLexport int (*caml_try_leave_blocking_section_hook)(void) =
+ caml_try_leave_blocking_section_default;
+
+int caml_rev_convert_signal_number(int signo);
/* Execute a signal handler immediately. */
sigaddset(&sigs, signal_number);
sigprocmask(SIG_BLOCK, &sigs, &sigs);
#endif
- res = caml_callback_exn(Field(caml_signal_handlers, signal_number),
- Val_int(rev_convert_signal_number(signal_number)));
+ res = caml_callback_exn(
+ Field(caml_signal_handlers, signal_number),
+ Val_int(caml_rev_convert_signal_number(signal_number)));
#ifdef POSIX_SIGNALS
if (! in_signal_handler) {
/* Restore the original signal mask */
if (Is_exception_result(res)) caml_raise(Extract_exception(res));
}
+/* Record the delivery of a signal and play with the allocation limit
+ so that the next allocation will trigger a garbage collection. */
+
+void caml_record_signal(int signal_number)
+{
+ caml_pending_signals[signal_number] = 1;
+ caml_young_limit = caml_young_end;
+}
+
/* This routine is the common entry point for garbage collection
and signal handling. It can trigger a callback to Caml code.
With system threads, this callback can cause a context switch.
void caml_garbage_collection(void)
{
- int sig;
+ int signal_number;
+ intnat signal_state;
- if (caml_young_ptr < caml_young_start || caml_force_major_slice){
+ caml_young_limit = caml_young_start;
+ if (caml_young_ptr < caml_young_start || caml_force_major_slice) {
caml_minor_collection();
}
- /* If a signal arrives between the following two instructions,
- it will be lost. */
- sig = caml_pending_signal;
- caml_pending_signal = 0;
- caml_young_limit = caml_young_start;
- if (sig) caml_execute_signal(sig, 0);
+ for (signal_number = 0; signal_number < NSIG; signal_number++) {
+ Read_and_clear(signal_state, caml_pending_signals[signal_number]);
+ if (signal_state) caml_execute_signal(signal_number, 0);
+ }
}
/* Trigger a garbage collection as soon as possible */
void caml_enter_blocking_section(void)
{
- int sig;
+ int i;
+ intnat pending;
while (1){
- Assert (!caml_async_signal_mode);
- /* If a signal arrives between the next two instructions,
- it will be lost. */
- sig = caml_pending_signal;
- caml_pending_signal = 0;
- caml_young_limit = caml_young_start;
- if (sig) caml_execute_signal(sig, 0);
- caml_async_signal_mode = 1;
- if (!caml_pending_signal) break;
- caml_async_signal_mode = 0;
- }
- if (caml_enter_blocking_section_hook != NULL){
- caml_enter_blocking_section_hook();
+ /* Process all pending signals now */
+ caml_process_pending_signals();
+ caml_enter_blocking_section_hook ();
+ /* Check again for pending signals. */
+ pending = 0;
+ for (i = 0; i < NSIG; i++) pending |= caml_pending_signals[i];
+ /* If none, done; otherwise, try again */
+ if (!pending) break;
+ caml_leave_blocking_section_hook ();
}
}
-void caml_leave_blocking_section(void)
+CAMLexport void caml_leave_blocking_section(void)
{
- if (caml_leave_blocking_section_hook != NULL){
- caml_leave_blocking_section_hook();
- }
- Assert(caml_async_signal_mode);
- caml_async_signal_mode = 0;
+ caml_leave_blocking_section_hook ();
+ caml_process_pending_signals();
}
-#if defined(TARGET_alpha) || defined(TARGET_mips)
-static void handle_signal(int sig, int code, struct sigcontext * context)
-#elif defined(TARGET_power) && defined(SYS_elf)
-static void handle_signal(int sig, struct sigcontext * context)
-#elif defined(TARGET_power) && defined(SYS_rhapsody)
-static void handle_signal(int sig, int code, STRUCT_SIGCONTEXT * context)
-#elif defined(TARGET_power) && defined(SYS_bsd)
-static void handle_signal(int sig, int code, struct sigcontext * context)
-#elif defined(TARGET_sparc) && defined(SYS_solaris)
-static void handle_signal(int sig, int code, void * context)
-#else
-static void handle_signal(int sig)
-#endif
+DECLARE_SIGNAL_HANDLER(handle_signal)
{
#if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS)
signal(sig, handle_signal);
#endif
- if (caml_async_signal_mode) {
- /* We are interrupting a C function blocked on I/O.
- Callback the Caml code immediately. */
- caml_leave_blocking_section();
+ if (sig < 0 || sig >= NSIG) return;
+ if (caml_try_leave_blocking_section_hook ()) {
caml_execute_signal(sig, 1);
- caml_enter_blocking_section();
+ caml_enter_blocking_section_hook();
} else {
- /* We can't execute the signal code immediately.
- Instead, we remember the signal and play with the allocation limit
- so that the next allocation will trigger a garbage collection. */
- caml_pending_signal = sig;
- caml_young_limit = caml_young_end;
- /* Some ports cache [caml_young_limit] in a register.
- Use the signal context to modify that register too, but only if
- we are inside Caml code (not inside C code). */
-#if defined(TARGET_alpha)
- if (In_code_area(context->sc_pc)) {
- /* Cached in register $14 */
- context->sc_regs[14] = (long) caml_young_limit;
- }
-#endif
-#if defined(TARGET_mips)
- if (In_code_area(context->sc_pc)) {
- /* Cached in register $23 */
- context->sc_regs[23] = (int) caml_young_limit;
- }
-#endif
-#if defined(TARGET_power) && defined(SYS_elf)
- if (caml_last_return_address == 0) {
- /* Cached in register 30 */
- context->regs->gpr[30] = (unsigned long) caml_young_limit;
- }
-#endif
-#if defined(TARGET_power) && defined(SYS_rhapsody)
- if (In_code_area(CONTEXT_PC(context))) {
- /* Cached in register 30 */
- CONTEXT_GPR(context, 30) = (unsigned long) caml_young_limit;
- }
-#endif
-#if defined(TARGET_power) && defined(SYS_bsd)
- if (caml_last_return_address == 0) {
- /* Cached in register 30 */
- context->sc_frame.fixreg[30] = (unsigned long) caml_young_limit;
- }
-#endif
-#if defined(TARGET_sparc) && defined(SYS_solaris)
- { greg_t * gregs = ((ucontext_t *)context)->uc_mcontext.gregs;
- if (In_code_area(gregs[REG_PC])) {
- /* Cached in register l7, which is saved on the stack 7 words
- after the stack pointer. */
- ((long *)(gregs[REG_SP]))[7] = (long) caml_young_limit;
- }
- }
+ caml_record_signal(sig);
+ /* Some ports cache [caml_young_limit] in a register.
+ Use the signal context to modify that register too, but only if
+ we are inside Caml code (not inside C code). */
+#if defined(CONTEXT_PC) && defined(CONTEXT_YOUNG_LIMIT)
+ if (In_code_area(CONTEXT_PC))
+ CONTEXT_YOUNG_LIMIT = (context_reg) caml_young_limit;
#endif
}
}
return signo;
}
-static int rev_convert_signal_number(int signo)
+int caml_rev_convert_signal_number(int signo)
{
int i;
for (i = 0; i < sizeof(posix_signals) / sizeof(int); i++)
return signo;
}
-#ifndef NSIG
-#define NSIG 64
-#endif
+typedef void (*signal_handler)(int signo);
value caml_install_signal_handler(value signal_number, value action) /* ML */
{
CAMLparam2 (signal_number, action);
int sig;
- void (*act)(int signo), (*oldact)(int signo);
+ signal_handler oldact;
#ifdef POSIX_SIGNALS
struct sigaction sigact, oldsigact;
+#else
+ signal_handler act;
#endif
CAMLlocal1 (res);
sig = caml_convert_signal_number(Int_val(signal_number));
if (sig < 0 || sig >= NSIG)
caml_invalid_argument("Sys.signal: unavailable signal");
+#ifdef POSIX_SIGNALS
switch(action) {
case Val_int(0): /* Signal_default */
- act = SIG_DFL;
+ sigact.sa_handler = SIG_DFL;
+ sigact.sa_flags = 0;
break;
case Val_int(1): /* Signal_ignore */
- act = SIG_IGN;
+ sigact.sa_handler = SIG_IGN;
+ sigact.sa_flags = 0;
break;
default: /* Signal_handle */
- act = (void (*)(int)) handle_signal;
+ SET_SIGACT(sigact, handle_signal);
break;
}
-#ifdef POSIX_SIGNALS
- sigact.sa_handler = act;
sigemptyset(&sigact.sa_mask);
-#if defined(SYS_solaris) || defined(SYS_rhapsody)
- sigact.sa_flags = SA_SIGINFO;
-#else
- sigact.sa_flags = 0;
-#endif
if (sigaction(sig, &sigact, &oldsigact) == -1) caml_sys_error(NO_ARG);
oldact = oldsigact.sa_handler;
#else
+ switch(action) {
+ case Val_int(0): /* Signal_default */
+ act = SIG_DFL;
+ break;
+ case Val_int(1): /* Signal_ignore */
+ act = SIG_IGN;
+ break;
+ default: /* Signal_handle */
+ act = handle_signal;
+ break;
+ }
oldact = signal(sig, act);
if (oldact == SIG_ERR) caml_sys_error(NO_ARG);
#endif
- if (oldact == (void (*)(int)) handle_signal) {
+ if (oldact == (signal_handler) handle_signal) {
res = caml_alloc_small(1, 0); /* Signal_handle */
Field(res, 0) = Field(caml_signal_handlers, sig);
}
}
caml_modify(&Field(caml_signal_handlers, sig), Field(action, 0));
}
+ caml_process_pending_signals();
CAMLreturn (res);
}
/* Machine- and OS-dependent handling of bound check trap */
-#if defined(TARGET_sparc) && defined(SYS_sunos)
-static void trap_handler(int sig, int code,
- struct sigcontext * context, char * address)
-{
- int * sp;
- /* Unblock SIGILL */
- sigset_t mask;
- sigemptyset(&mask);
- sigaddset(&mask, SIGILL);
- sigprocmask(SIG_UNBLOCK, &mask, NULL);
- if (code != ILL_TRAP_FAULT(5)) {
- fprintf(stderr, "Fatal error: illegal instruction, code 0x%x\n", code);
- exit(100);
- }
- /* Recover [caml_young_ptr] and [caml_exception_pointer]
- from the %l5 and %l6 regs */
- sp = (int *) context->sc_sp;
- caml_exception_pointer = (char *) sp[5];
- caml_young_ptr = (char *) sp[6];
- caml_array_bound_error();
-}
-#endif
-
-#if defined(TARGET_sparc) && defined(SYS_solaris)
-static void trap_handler(int sig, siginfo_t * info, void * context)
+#if defined(TARGET_power) || (defined(TARGET_sparc) && defined(SYS_solaris))
+DECLARE_SIGNAL_HANDLER(trap_handler)
{
- long * sp;
-
+#if defined(SYS_solaris)
if (info->si_code != ILL_ILLTRP) {
- fprintf(stderr, "Fatal error: illegal instruction, code 0x%x\n",
- info->si_code);
- exit(100);
+ /* Deactivate our exception handler and return. */
+ struct sigaction act;
+ act.sa_handler = SIG_DFL;
+ act.sa_flags = 0;
+ sigemptyset(&act.sa_mask);
+ sigaction(sig, &act, NULL);
+ return;
}
- /* Recover [caml_young_ptr] and [caml_exception_pointer]
- from the %l5 and %l6 regs */
- sp = (long *) (((ucontext_t *)context)->uc_mcontext.gregs[REG_SP]);
- caml_exception_pointer = (char *) sp[5];
- caml_young_ptr = (char *) sp[6];
- caml_array_bound_error();
-}
-#endif
-
-#if defined(TARGET_sparc) && (defined(SYS_bsd) || defined(SYS_linux))
-static void trap_handler(int sig)
-{
- /* TODO: recover registers from context and call [caml_array_bound_error] */
- caml_fatal_error("Fatal error: out-of-bound access in array or string\n");
-}
#endif
-
-#if defined(TARGET_power) && defined(SYS_elf)
-static void trap_handler(int sig, struct sigcontext * context)
-{
- /* Recover [caml_young_ptr] and [caml_exception_pointer]
- from registers 31 and 29 */
- caml_exception_pointer = (char *) context->regs->gpr[29];
- caml_young_ptr = (char *) context->regs->gpr[31];
- caml_array_bound_error();
-}
-#endif
-
-#if defined(TARGET_power) && defined(SYS_rhapsody)
-static void trap_handler(int sig, int code, STRUCT_SIGCONTEXT * context)
-{
+#if defined(SYS_rhapsody)
/* Unblock SIGTRAP */
- sigset_t mask;
- sigemptyset(&mask);
- sigaddset(&mask, SIGTRAP);
- sigprocmask(SIG_UNBLOCK, &mask, NULL);
- /* Recover [caml_young_ptr] and [caml_exception_pointer]
- from registers 31 and 29 */
- caml_exception_pointer = (char *) CONTEXT_GPR(context, 29);
- caml_young_ptr = (char *) CONTEXT_GPR(context, 31);
- caml_array_bound_error();
-}
+ { sigset_t mask;
+ sigemptyset(&mask);
+ sigaddset(&mask, SIGTRAP);
+ sigprocmask(SIG_UNBLOCK, &mask, NULL);
+ }
#endif
-
-#if defined(TARGET_power) && defined(SYS_bsd)
-static void trap_handler(int sig, int code, struct sigcontext * context)
-{
- /* Recover [caml_young_ptr] and [caml_exception_pointer]
- from registers 31 and 29 */
- caml_exception_pointer = (char *) context->sc_frame.fixreg[29];
- caml_young_ptr = (char *) context->sc_frame.fixreg[31];
+ caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER;
+ caml_young_ptr = (char *) CONTEXT_YOUNG_PTR;
caml_array_bound_error();
}
#endif
-
/* Machine- and OS-dependent handling of stack overflow */
#ifdef HAS_STACK_OVERFLOW_DETECTION
static char * system_stack_top;
static char sig_alt_stack[SIGSTKSZ];
-static int is_stack_overflow(char * fault_addr)
+DECLARE_SIGNAL_HANDLER(segv_handler)
{
struct rlimit limit;
struct sigaction act;
+ char * fault_addr;
/* Sanity checks:
- faulting address is word-aligned
- - faulting address is within the stack */
- if (((long) fault_addr & (sizeof(long) - 1)) == 0 &&
- getrlimit(RLIMIT_STACK, &limit) == 0 &&
- fault_addr < system_stack_top &&
- fault_addr >= system_stack_top - limit.rlim_cur - 0x2000) {
- /* OK, caller can turn this into a Stack_overflow exception */
- return 1;
- } else {
- /* Otherwise, deactivate our exception handler. Caller will
- return, causing fatal signal to be generated at point of error. */
- act.sa_handler = SIG_DFL;
- act.sa_flags = 0;
- sigemptyset(&act.sa_mask);
- sigaction(SIGSEGV, &act, NULL);
- return 0;
- }
-}
-
-#if defined(TARGET_i386) && defined(SYS_linux_elf)
-static void segv_handler(int signo, struct sigcontext sc)
-{
- if (is_stack_overflow((char *) sc.cr2))
- caml_raise_stack_overflow();
-}
+ - faulting address is within the stack
+ - we are in Caml code */
+ fault_addr = CONTEXT_FAULTING_ADDRESS;
+ if (((uintnat) fault_addr & (sizeof(intnat) - 1)) == 0
+ && getrlimit(RLIMIT_STACK, &limit) == 0
+ && fault_addr < system_stack_top
+ && fault_addr >= system_stack_top - limit.rlim_cur - 0x2000
+#ifdef CONTEXT_PC
+ && In_code_area(CONTEXT_PC)
+#endif
+ ) {
+ /* Turn this into a Stack_overflow exception */
+#if defined(CONTEXT_YOUNG_PTR) && defined(CONTEXT_EXCEPTION_POINTER)
+ caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER;
+ caml_young_ptr = (char *) CONTEXT_YOUNG_PTR;
#endif
-
-#if defined(TARGET_i386) && !defined(SYS_linux_elf)
-static void segv_handler(int signo, siginfo_t * info, void * arg)
-{
- if (is_stack_overflow((char *) info->si_addr))
caml_raise_stack_overflow();
+ }
+ /* Otherwise, deactivate our exception handler and return,
+ causing fatal signal to be generated at point of error. */
+ act.sa_handler = SIG_DFL;
+ act.sa_flags = 0;
+ sigemptyset(&act.sa_mask);
+ sigaction(SIGSEGV, &act, NULL);
}
-#endif
#endif
void caml_init_signals(void)
{
/* Bound-check trap handling */
-#if defined(TARGET_sparc) && \
- (defined(SYS_sunos) || defined(SYS_bsd) || defined(SYS_linux))
- {
- struct sigaction act;
- act.sa_handler = (void (*)(int)) trap_handler;
- sigemptyset(&act.sa_mask);
- act.sa_flags = 0;
- sigaction(SIGILL, &act, NULL);
- }
-#endif
#if defined(TARGET_sparc) && defined(SYS_solaris)
- {
- struct sigaction act;
- act.sa_sigaction = trap_handler;
+ { struct sigaction act;
sigemptyset(&act.sa_mask);
- act.sa_flags = SA_SIGINFO | SA_NODEFER;
+ SET_SIGACT(act, trap_handler);
+ act.sa_flags |= SA_NODEFER;
sigaction(SIGILL, &act, NULL);
}
#endif
+
#if defined(TARGET_power)
- {
- struct sigaction act;
- act.sa_handler = (void (*)(int)) trap_handler;
+ { struct sigaction act;
sigemptyset(&act.sa_mask);
-#if defined (SYS_rhapsody)
- act.sa_flags = SA_SIGINFO;
-#else
- act.sa_flags = SA_NODEFER;
+ SET_SIGACT(act, trap_handler);
+#if !defined(SYS_rhapsody)
+ act.sa_flags |= SA_NODEFER;
#endif
sigaction(SIGTRAP, &act, NULL);
}
#endif
+
/* Stack overflow handling */
#ifdef HAS_STACK_OVERFLOW_DETECTION
{
stk.ss_sp = sig_alt_stack;
stk.ss_size = SIGSTKSZ;
stk.ss_flags = 0;
-#if defined(TARGET_i386) && defined(SYS_linux_elf)
- act.sa_handler = (void (*)(int)) segv_handler;
- act.sa_flags = SA_ONSTACK | SA_NODEFER;
-#else
- act.sa_sigaction = segv_handler;
- act.sa_flags = SA_SIGINFO | SA_ONSTACK | SA_NODEFER;
-#endif
+ SET_SIGACT(act, segv_handler);
+ act.sa_flags |= SA_ONSTACK | SA_NODEFER;
sigemptyset(&act.sa_mask);
system_stack_top = (char *) &act;
if (sigaltstack(&stk, NULL) == 0) { sigaction(SIGSEGV, &act, NULL); }
--- /dev/null
+/***********************************************************************/
+/* */
+/* Objective Caml */
+/* */
+/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 2004 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the GNU Library General Public License, with */
+/* the special exception on linking described in file ../LICENSE. */
+/* */
+/***********************************************************************/
+
+/* $Id: signals_osdep.h,v 1.3 2005/10/14 16:41:30 xleroy Exp $ */
+
+/* Processor- and OS-dependent signal interface */
+
+/****************** Alpha, all OS */
+
+#if defined(TARGET_alpha)
+
+ #define DECLARE_SIGNAL_HANDLER(name) \
+ static void name(int sig, int code, struct sigcontext * context)
+
+ #define SET_SIGACT(sigact,name) \
+ sigact.sa_handler = (void (*)(int)) (name); \
+ sigact.sa_flags = 0
+
+ typedef long context_reg;
+ #define CONTEXT_PC (context->sc_pc)
+ #define CONTEXT_EXCEPTION_POINTER (context->sc_regs[15])
+ #define CONTEXT_YOUNG_LIMIT (context->sc_regs[13])
+ #define CONTEXT_YOUNG_PTR (context->sc_regs[14])
+
+/****************** AMD64, Linux */
+
+#elif defined(TARGET_amd64) && defined (SYS_linux)
+
+ #define DECLARE_SIGNAL_HANDLER(name) \
+ static void name(int sig, siginfo_t * info, ucontext_t * context)
+
+ #define SET_SIGACT(sigact,name) \
+ sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \
+ sigact.sa_flags = SA_SIGINFO
+
+ typedef greg_t context_reg;
+ #define CONTEXT_PC (context->uc_mcontext.gregs[REG_RIP])
+ #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.gregs[REG_R14])
+ #define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15])
+ #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.gregs[REG_CR2])
+
+/****************** I386, Linux */
+
+#elif defined(TARGET_i386) && defined(SYS_linux_elf)
+
+ #define DECLARE_SIGNAL_HANDLER(name) \
+ static void name(int sig, struct sigcontext context)
+
+ #define SET_SIGACT(sigact,name) \
+ sigact.sa_handler = (void (*)(int)) (name); \
+ sigact.sa_flags = 0
+
+ #define CONTEXT_FAULTING_ADDRESS ((char *) context.cr2)
+
+/****************** I386, BSD */
+
+#elif defined(TARGET_i386) && defined(SYS_bsd)
+
+ #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
+
+ #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
+
+/****************** MIPS, all OS */
+
+#elif defined(TARGET_mips)
+
+ #define DECLARE_SIGNAL_HANDLER(name) \
+ static void name(int sig, int code, struct sigcontext * context)
+
+ #define SET_SIGACT(sigact,name) \
+ sigact.sa_handler = (void (*)(int)) (name); \
+ sigact.sa_flags = 0
+
+ typedef int context_reg;
+ #define CONTEXT_PC (context->sc_pc)
+ #define CONTEXT_EXCEPTION_POINTER (context->sc_regs[30])
+ #define CONTEXT_YOUNG_LIMIT (context->sc_regs[22]
+ #define CONTEXT_YOUNG_PTR (context->sc_regs[23])
+
+/****************** PowerPC, MacOS X */
+
+#elif defined(TARGET_power) && defined(SYS_rhapsody)
+
+ #include <sys/utsname.h>
+
+ #define DECLARE_SIGNAL_HANDLER(name) \
+ static void name(int sig, int code, void * context)
+
+ #define SET_SIGACT(sigact,name) \
+ sigact.sa_handler = (void (*)(int)) (name); \
+ sigact.sa_flags = SA_SIGINFO
+
+ typedef unsigned long context_reg;
+ #define CONTEXT_PC (*context_gpr_p(context, -2))
+ #define CONTEXT_EXCEPTION_POINTER (*context_gpr_p(context, 29))
+ #define CONTEXT_YOUNG_LIMIT (*context_gpr_p(context, 30))
+ #define CONTEXT_YOUNG_PTR (*context_gpr_p(context, 31))
+
+ 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]);
+ }
+ #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]);
+ }
+ #endif
+
+/****************** PowerPC, ELF (Linux) */
+
+#elif defined(TARGET_power) && defined(SYS_elf)
+
+ #define DECLARE_SIGNAL_HANDLER(name) \
+ static void name(int sig, struct sigcontext * context)
+
+ #define SET_SIGACT(sigact,name) \
+ sigact.sa_handler = (void (*)(int)) (name); \
+ sigact.sa_flags = 0
+
+ typedef unsigned long context_reg;
+ #define CONTEXT_PC (context->regs->nip)
+ #define CONTEXT_EXCEPTION_POINTER (context->regs->gpr[29])
+ #define CONTEXT_YOUNG_LIMIT (context->regs->gpr[30])
+ #define CONTEXT_YOUNG_PTR (context->regs->gpr[31])
+
+/****************** PowerPC, BSD */
+
+#elif defined(TARGET_power) && defined(SYS_bsd)
+
+ #define DECLARE_SIGNAL_HANDLER(name) \
+ static void name(int sig, int code, struct sigcontext * context)
+
+ #define SET_SIGACT(sigact,name) \
+ sigact.sa_handler = (void (*)(int)) (name); \
+ sigact.sa_flags = 0
+
+ typedef unsigned long context_reg;
+ #define CONTEXT_EXCEPTION_POINTER (context->sc_frame.fixreg[29])
+ #define CONTEXT_YOUNG_LIMIT (context->sc_frame.fixreg[30])
+ #define CONTEXT_YOUNG_PTR (context->sc_frame.fixreg[31])
+
+/****************** SPARC, Solaris */
+
+#elif defined(TARGET_sparc) && defined(SYS_solaris)
+
+ #include <ucontext.h>
+
+ #define DECLARE_SIGNAL_HANDLER(name) \
+ static void name(int sig, siginfo_t * info, ucontext_t * context)
+
+ #define SET_SIGACT(sigact,name) \
+ sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \
+ sigact.sa_flags = SA_SIGINFO
+
+ typedef long context_reg;
+ #define CONTEXT_PC (context->uc_mcontext.gregs[REG_PC])
+ /* Local register number N is saved on the stack N words
+ after the stack pointer */
+ #define SPARC_L_REG(n) ((long *)(context->uc_mcontext.gregs[REG_SP]))[n]
+ #define CONTEXT_EXCEPTION_POINTER (SPARC_L_REG(5))
+ #define CONTEXT_YOUNG_LIMIT (SPARC_L_REG(7))
+ #define CONTEXT_YOUNG_PTR (SPARC_L_REG(6))
+
+/******************** Default */
+
+#else
+
+ #define DECLARE_SIGNAL_HANDLER(name) \
+ static void name(int sig)
+
+ #define SET_SIGACT(sigact,name) \
+ sigact.sa_handler = (name); \
+ sigact.sa_flags = 0
+
+#endif
/* */
/***********************************************************************/
-/* $Id: sparc.S,v 1.24.4.1 2004/10/06 09:02:36 garrigue Exp $ */
+/* $Id: sparc.S,v 1.26 2004/10/06 06:33:25 garrigue Exp $ */
/* Asm part of the runtime system for the Sparc processor. */
/* Must be preprocessed by cpp */
#if defined(SYS_sunos)
- .common _caml_required_size, 4, "bss"
-
#define Caml_young_limit _caml_young_limit
#define Caml_young_ptr _caml_young_ptr
#define Caml_bottom_of_stack _caml_bottom_of_stack
#define Caml_last_return_address _caml_last_return_address
#define Caml_gc_regs _caml_gc_regs
#define Caml_exception_pointer _caml_exception_pointer
-#define Caml_required_size _caml_required_size
#define Caml_allocN _caml_allocN
#define Caml_call_gc _caml_call_gc
#define Caml_garbage_collection _caml_garbage_collection
#define Caml_apply3 _caml_apply3
#define Caml_raise _caml_raise
#define Caml_system__frametable _caml_system__frametable
+#define Caml_ml_array_bound_error _caml_ml_array_bound_error
+#define Caml_array_bound_error _caml_array_bound_error
#else
- .common caml_required_size, 4, 4
-
#define Caml_young_limit caml_young_limit
#define Caml_young_ptr caml_young_ptr
#define Caml_bottom_of_stack caml_bottom_of_stack
#define Caml_last_return_address caml_last_return_address
#define Caml_gc_regs caml_gc_regs
#define Caml_exception_pointer caml_exception_pointer
-#define Caml_required_size caml_required_size
#define Caml_allocN caml_allocN
#define Caml_call_gc caml_call_gc
#define Caml_garbage_collection caml_garbage_collection
#define Caml_apply3 caml_apply3
#define Caml_raise caml_raise
#define Caml_system__frametable caml_system__frametable
+#define Caml_ml_array_bound_error caml_ml_array_bound_error
+#define Caml_array_bound_error caml_array_bound_error
#endif
/* Required size in %g2 */
Caml_call_gc:
- /* Save %g2 (required size) */
- Store(%g2, Caml_required_size)
/* Save exception pointer if GC raises */
Store(Exn_ptr, Caml_exception_pointer)
/* Save current allocation pointer for debugging purposes */
/* Allocate space on stack for caml_context structure and float regs */
sub %sp, 20*4 + 15*8, %sp
/* Save int regs on stack and save it into caml_gc_regs */
-L100: add %sp, 96 + 15*8, %g2
- st %o0, [%g2]
- st %o1, [%g2 + 0x4]
- st %o2, [%g2 + 0x8]
- st %o3, [%g2 + 0xc]
- st %o4, [%g2 + 0x10]
- st %o5, [%g2 + 0x14]
- st %i0, [%g2 + 0x18]
- st %i1, [%g2 + 0x1c]
- st %i2, [%g2 + 0x20]
- st %i3, [%g2 + 0x24]
- st %i4, [%g2 + 0x28]
- st %i5, [%g2 + 0x2c]
- st %l0, [%g2 + 0x30]
- st %l1, [%g2 + 0x34]
- st %l2, [%g2 + 0x38]
- st %l3, [%g2 + 0x3c]
- st %l4, [%g2 + 0x40]
- st %g3, [%g2 + 0x44]
- st %g4, [%g2 + 0x48]
+L100: add %sp, 96 + 15*8, %g1
+ st %o0, [%g1]
+ st %o1, [%g1 + 0x4]
+ st %o2, [%g1 + 0x8]
+ st %o3, [%g1 + 0xc]
+ st %o4, [%g1 + 0x10]
+ st %o5, [%g1 + 0x14]
+ st %i0, [%g1 + 0x18]
+ st %i1, [%g1 + 0x1c]
+ st %i2, [%g1 + 0x20]
+ st %i3, [%g1 + 0x24]
+ st %i4, [%g1 + 0x28]
+ st %i5, [%g1 + 0x2c]
+ st %l0, [%g1 + 0x30]
+ st %l1, [%g1 + 0x34]
+ st %l2, [%g1 + 0x38]
+ st %l3, [%g1 + 0x3c]
+ st %l4, [%g1 + 0x40]
+ st %g3, [%g1 + 0x44]
+ st %g4, [%g1 + 0x48]
+ st %g2, [%g1 + 0x4C] /* Save required size */
+ mov %g1, %g2
Store(%g2, Caml_gc_regs)
/* Save the floating-point registers */
add %sp, 96, %g1
call Caml_garbage_collection
nop
/* Restore all regs used by the code generator */
- add %sp, 96 + 15*8, %g2
- ld [%g2], %o0
- ld [%g2 + 0x4], %o1
- ld [%g2 + 0x8], %o2
- ld [%g2 + 0xc], %o3
- ld [%g2 + 0x10], %o4
- ld [%g2 + 0x14], %o5
- ld [%g2 + 0x18], %i0
- ld [%g2 + 0x1c], %i1
- ld [%g2 + 0x20], %i2
- ld [%g2 + 0x24], %i3
- ld [%g2 + 0x28], %i4
- ld [%g2 + 0x2c], %i5
- ld [%g2 + 0x30], %l0
- ld [%g2 + 0x34], %l1
- ld [%g2 + 0x38], %l2
- ld [%g2 + 0x3c], %l3
- ld [%g2 + 0x40], %l4
- ld [%g2 + 0x44], %g3
- ld [%g2 + 0x48], %g4
+ add %sp, 96 + 15*8, %g1
+ ld [%g1], %o0
+ ld [%g1 + 0x4], %o1
+ ld [%g1 + 0x8], %o2
+ ld [%g1 + 0xc], %o3
+ ld [%g1 + 0x10], %o4
+ ld [%g1 + 0x14], %o5
+ ld [%g1 + 0x18], %i0
+ ld [%g1 + 0x1c], %i1
+ ld [%g1 + 0x20], %i2
+ ld [%g1 + 0x24], %i3
+ ld [%g1 + 0x28], %i4
+ ld [%g1 + 0x2c], %i5
+ ld [%g1 + 0x30], %l0
+ ld [%g1 + 0x34], %l1
+ ld [%g1 + 0x38], %l2
+ ld [%g1 + 0x3c], %l3
+ ld [%g1 + 0x40], %l4
+ ld [%g1 + 0x44], %g3
+ ld [%g1 + 0x48], %g4
+ ld [%g1 + 0x4C], %g2 /* Recover desired size */
add %sp, 96, %g1
ldd [%g1], %f0
ldd [%g1 + 0x8], %f2
/* Reload alloc ptr */
Load(Caml_young_ptr, Alloc_ptr)
/* Allocate space for block */
- Load(Caml_required_size, %g2)
#ifdef INDIRECT_LIMIT
ld [Alloc_limit], %g1
sub Alloc_ptr, %g2, Alloc_ptr
b L108
or %l2, %lo(Caml_apply3), %l2
+#ifndef SYS_solaris
+/* Glue code to call [caml_array_bound_error] */
+
+ .global Caml_ml_array_bound_error
+Caml_ml_array_bound_error:
+ Address(Caml_array_bound_error, %g2)
+ b Caml_c_call
+ nop
+#endif
+
#ifdef SYS_solaris
.section ".rodata"
#else
/* */
/***********************************************************************/
-/* $Id: stack.h,v 1.28 2003/12/16 18:09:04 doligez Exp $ */
+/* $Id: stack.h,v 1.29 2005/09/22 14:21:47 xleroy Exp $ */
/* Machine-dependent interface with the asm code */
/* Macros to access the stack frame */
#ifdef TARGET_alpha
-#define Saved_return_address(sp) *((long *)((sp) - 8))
+#define Saved_return_address(sp) *((intnat *)((sp) - 8))
#define Already_scanned(sp, retaddr) ((retaddr) & 1L)
-#define Mark_scanned(sp, retaddr) (*((long *)((sp) - 8)) = (retaddr) | 1L)
+#define Mark_scanned(sp, retaddr) (*((intnat *)((sp) - 8)) = (retaddr) | 1L)
#define Mask_already_scanned(retaddr) ((retaddr) & ~1L)
#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
#endif
#ifdef TARGET_sparc
-#define Saved_return_address(sp) *((long *)((sp) + 92))
+#define Saved_return_address(sp) *((intnat *)((sp) + 92))
#define Callback_link(sp) ((struct caml_context *)((sp) + 104))
#endif
#ifdef TARGET_i386
-#define Saved_return_address(sp) *((long *)((sp) - 4))
+#define Saved_return_address(sp) *((intnat *)((sp) - 4))
#define Callback_link(sp) ((struct caml_context *)((sp) + 8))
#endif
#ifdef TARGET_mips
-#define Saved_return_address(sp) *((long *)((sp) - 4))
+#define Saved_return_address(sp) *((intnat *)((sp) - 4))
#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
#endif
#ifdef TARGET_hppa
#define Stack_grows_upwards
-#define Saved_return_address(sp) *((long *)(sp))
+#define Saved_return_address(sp) *((intnat *)(sp))
#define Callback_link(sp) ((struct caml_context *)((sp) - 24))
#endif
#ifdef TARGET_power
-#define Saved_return_address(sp) *((long *)((sp) - 4))
+#define Saved_return_address(sp) *((intnat *)((sp) - 4))
#define Already_scanned(sp, retaddr) ((retaddr) & 1)
-#define Mark_scanned(sp, retaddr) (*((long *)((sp) - 4)) = (retaddr) | 1)
+#define Mark_scanned(sp, retaddr) (*((intnat *)((sp) - 4)) = (retaddr) | 1)
#define Mask_already_scanned(retaddr) ((retaddr) & ~1)
#ifdef SYS_aix
#define Trap_frame_size 32
#endif
#ifdef TARGET_m68k
-#define Saved_return_address(sp) *((long *)((sp) - 4))
+#define Saved_return_address(sp) *((intnat *)((sp) - 4))
#define Callback_link(sp) ((struct caml_context *)((sp) + 8))
#endif
#ifdef TARGET_arm
-#define Saved_return_address(sp) *((long *)((sp) - 4))
+#define Saved_return_address(sp) *((intnat *)((sp) - 4))
#define Callback_link(sp) ((struct caml_context *)((sp) + 8))
#endif
#ifdef TARGET_ia64
-#define Saved_return_address(sp) *((long *)((sp) + 8))
+#define Saved_return_address(sp) *((intnat *)((sp) + 8))
#define Already_scanned(sp, retaddr) ((retaddr) & 1L)
-#define Mark_scanned(sp, retaddr) (*((long *)((sp) + 8)) = (retaddr) | 1L)
+#define Mark_scanned(sp, retaddr) (*((intnat *)((sp) + 8)) = (retaddr) | 1L)
#define Mask_already_scanned(retaddr) ((retaddr) & ~1L)
#define Callback_link(sp) ((struct caml_context *)((sp) + 32))
#endif
#ifdef TARGET_amd64
-#define Saved_return_address(sp) *((long *)((sp) - 8))
+#define Saved_return_address(sp) *((intnat *)((sp) - 8))
#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
#endif
struct caml_context {
char * bottom_of_stack; /* beginning of Caml stack chunk */
- unsigned long last_retaddr; /* last return address in Caml code */
+ uintnat last_retaddr; /* last return address in Caml code */
value * gc_regs; /* pointer to register block */
};
/* Declaration of variables used in the asm code */
extern char * caml_bottom_of_stack;
-extern unsigned long caml_last_return_address;
+extern uintnat caml_last_return_address;
extern value * caml_gc_regs;
extern char * caml_exception_pointer;
extern value caml_globals[];
-extern long caml_globals_inited;
-extern long * caml_frametable[];
+extern intnat caml_globals_inited;
+extern intnat * caml_frametable[];
#endif /* CAML_STACK_H */
/* */
/***********************************************************************/
-/* $Id: startup.c,v 1.30.4.3 2005/03/16 12:05:28 doligez Exp $ */
+/* $Id: startup.c,v 1.32 2005/09/22 14:21:47 xleroy Exp $ */
/* Start-up code */
/* Configuration parameters and flags */
-static unsigned long percent_free_init = Percent_free_def;
-static unsigned long max_percent_free_init = Max_percent_free_def;
-static unsigned long minor_heap_init = Minor_heap_def;
-static unsigned long heap_chunk_init = Heap_chunk_def;
-static unsigned long heap_size_init = Init_heap_def;
-static unsigned long max_stack_init = Max_stack_def;
+static uintnat percent_free_init = Percent_free_def;
+static uintnat max_percent_free_init = Max_percent_free_def;
+static uintnat minor_heap_init = Minor_heap_def;
+static uintnat heap_chunk_init = Heap_chunk_def;
+static uintnat heap_size_init = Init_heap_def;
+static uintnat max_stack_init = Max_stack_def;
/* Parse the CAMLRUNPARAM variable */
/* The option letter for each runtime option is the first letter of the
/* If you change these functions, see also their copy in byterun/startup.c */
-static void scanmult (char *opt, long unsigned int *var)
+static void scanmult (char *opt, uintnat *var)
{
char mult = ' ';
- sscanf (opt, "=%lu%c", var, &mult);
- sscanf (opt, "=0x%lx%c", var, &mult);
- if (mult == 'k') *var = *var * 1024;
- if (mult == 'M') *var = *var * (1024 * 1024);
- if (mult == 'G') *var = *var * (1024 * 1024 * 1024);
+ int val;
+ sscanf (opt, "=%u%c", &val, &mult);
+ sscanf (opt, "=0x%x%c", &val, &mult);
+ switch (mult) {
+ case 'k': *var = (uintnat) val * 1024; break;
+ case 'M': *var = (uintnat) val * 1024 * 1024; break;
+ case 'G': *var = (uintnat) val * 1024 * 1024 * 1024; break;
+ default: *var = (uintnat) val; break;
+ }
}
static void parse_camlrunparam(void)
(* *)
(***********************************************************************)
-(* $Id: bytegen.ml,v 1.65.2.1 2004/07/07 16:49:51 xleroy Exp $ *)
+(* $Id: bytegen.ml,v 1.67 2005/08/25 15:35:16 doligez Exp $ *)
(* bytegen.ml : translation of lambda terms to lists of instructions. *)
let copy_event ev kind info repr =
{ ev_pos = 0; (* patched in emitcode *)
ev_module = ev.ev_module;
- ev_char = ev.ev_char;
+ ev_loc = ev.ev_loc;
ev_kind = kind;
ev_info = info;
ev_typenv = ev.ev_typenv;
let event kind info =
{ ev_pos = 0; (* patched in emitcode *)
ev_module = !compunit_name;
- ev_char = lev.lev_pos;
+ ev_loc = lev.lev_loc;
ev_kind = kind;
ev_info = info;
ev_typenv = lev.lev_env;
(* *)
(***********************************************************************)
-(* $Id: bytelink.ml,v 1.83.4.1 2004/07/02 09:10:50 xleroy Exp $ *)
+(* $Id: bytelink.ml,v 1.86 2005/10/13 13:32:06 xleroy Exp $ *)
(* Link a set of .cmo files and produce a bytecode executable. *)
(* *)
(***********************************************************************)
-(* $Id: instruct.ml,v 1.21 2004/05/26 11:10:50 garrigue Exp $ *)
+(* $Id: instruct.ml,v 1.22 2005/08/25 15:35:16 doligez Exp $ *)
open Lambda
type debug_event =
{ mutable ev_pos: int; (* Position in bytecode *)
ev_module: string; (* Name of defining module *)
- ev_char: Lexing.position; (* Position in source file *)
+ ev_loc: Location.t; (* Location in source file *)
ev_kind: debug_event_kind; (* Before/after event *)
ev_info: debug_event_info; (* Extra information *)
ev_typenv: Env.summary; (* Typing environment *)
(* *)
(***********************************************************************)
-(* $Id: instruct.mli,v 1.20 2004/05/26 11:10:50 garrigue Exp $ *)
+(* $Id: instruct.mli,v 1.22 2005/10/25 15:56:45 doligez Exp $ *)
(* The type of the instructions of the abstract machine *)
ce_heap: int Ident.tbl; (* Structure of the heap-allocated env *)
ce_rec: int Ident.tbl } (* Functions bound by the same let rec *)
-(* The ce_stack component gives locations of variables residing
+(* The ce_stack component gives locations of variables residing
in the stack. The locations are offsets w.r.t. the origin of the
stack frame.
The ce_heap component gives the positions of variables residing in the
(* Debugging events *)
+(* Warning: when you change these types, check byterun/backtrace.c *)
type debug_event =
{ mutable ev_pos: int; (* Position in bytecode *)
ev_module: string; (* Name of defining module *)
- ev_char: Lexing.position; (* Position in source file *)
+ ev_loc: Location.t; (* Location in source file *)
ev_kind: debug_event_kind; (* Before/after event *)
ev_info: debug_event_info; (* Extra information *)
ev_typenv: Env.summary; (* Typing environment *)
(* *)
(***********************************************************************)
-(* $Id: lambda.ml,v 1.40.2.2 2005/04/04 05:14:25 garrigue Exp $ *)
+(* $Id: lambda.ml,v 1.44 2005/08/25 15:35:16 doligez Exp $ *)
open Misc
open Path
| Pbigarray_float32 | Pbigarray_float64
| Pbigarray_sint8 | Pbigarray_uint8
| Pbigarray_sint16 | Pbigarray_uint16
- | Pbigarray_int32 | Pbigarray_int64
+ | Pbigarray_int32 | Pbigarray_int64
| Pbigarray_caml_int | Pbigarray_native_int
| Pbigarray_complex32 | Pbigarray_complex64
| Const_pointer of int
| Const_block of int * structured_constant list
| Const_float_array of string list
+ | Const_immstring of string
type function_kind = Curried | Tupled
sw_failaction : lambda option}
and lambda_event =
- { lev_pos: Lexing.position;
+ { lev_loc: Location.t;
lev_kind: lambda_event_kind;
lev_repr: int ref option;
lev_env: Env.summary }
| Lsend(k1, a1, b1, cl1), Lsend(k2, a2, b2, cl2) ->
k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2
| Levent(a1, ev1), Levent(a2, ev2) ->
- same a1 a2 && ev1.lev_pos = ev2.lev_pos
+ same a1 a2 && ev1.lev_loc = ev2.lev_loc
| Lifused(id1, a1), Lifused(id2, a2) ->
Ident.same id1 id2 && same a1 a2
| _, _ ->
f e1; f e2
| Lwhile(e1, e2) ->
f e1; f e2
- | Lfor(v, e1, e2, dir, e3) ->
+ | Lfor(v, e1, e2, dir, e3) ->
f e1; f e2; f e3
| Lassign(id, e) ->
f e
| Lletrec(decl, body) ->
List.iter (fun (id, exp) -> fv := IdentSet.remove id !fv) decl
| Lstaticcatch(e1, (_,vars), e2) ->
- List.iter (fun id -> fv := IdentSet.remove id !fv) vars
+ List.iter (fun id -> fv := IdentSet.remove id !fv) vars
| Ltrywith(e1, exn, e2) ->
fv := IdentSet.remove exn !fv
- | Lfor(v, e1, e2, dir, e3) ->
+ | Lfor(v, e1, e2, dir, e3) ->
fv := IdentSet.remove v !fv
| Lassign(id, e) ->
fv := IdentSet.add id !fv
match sw.sw_failaction with
| None -> None
| Some l -> Some (subst l)})
-
+
| Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args)
| Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2)
| Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2)
| Lifthenelse(e1, e2, e3) -> Lifthenelse(subst e1, subst e2, subst e3)
| Lsequence(e1, e2) -> Lsequence(subst e1, subst e2)
| Lwhile(e1, e2) -> Lwhile(subst e1, subst e2)
- | Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3)
+ | Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3)
| Lassign(id, e) -> Lassign(id, subst e)
| Lsend (k, met, obj, args) ->
Lsend (k, subst met, subst obj, List.map subst args)
(* *)
(***********************************************************************)
-(* $Id: lambda.mli,v 1.38.2.2 2005/04/04 05:14:25 garrigue Exp $ *)
+(* $Id: lambda.mli,v 1.42 2005/08/25 15:35:16 doligez Exp $ *)
(* The "lambda" intermediate code *)
| Const_pointer of int
| Const_block of int * structured_constant list
| Const_float_array of string list
+ | Const_immstring of string
type function_kind = Curried | Tupled
sw_blocks: (int * lambda) list; (* Tag block cases *)
sw_failaction : lambda option} (* Action to take if failure *)
and lambda_event =
- { lev_pos: Lexing.position;
+ { lev_loc: Location.t;
lev_kind: lambda_event_kind;
lev_repr: int ref option;
lev_env: Env.summary }
val staticfail : lambda (* Anticipated static failure *)
(* Check anticipated failure, substitute its final value *)
-val is_guarded: lambda -> bool
-val patch_guarded : lambda -> lambda -> lambda
+val is_guarded: lambda -> bool
+val patch_guarded : lambda -> lambda -> lambda
(* *)
(***********************************************************************)
-(* $Id: matching.ml,v 1.60 2004/04/29 12:38:11 maranget Exp $ *)
+(* $Id: matching.ml,v 1.67 2005/09/07 16:07:48 maranget Exp $ *)
(* Compilation of pattern matching *)
let ctx_rshift_num n ctx = List.map (rshift_num n) ctx
+(* Recombination of contexts (eg: (_,_)::p1::p2::rem -> (p1,p2)::rem)
+ All mutable fields are replaced by '_', since side-effects in
+ guards can alter these fields *)
+
let combine {left=left ; right=right} = match left with
-| p::ps -> {left=ps ; right=set_args p right}
+| p::ps -> {left=ps ; right=set_args_erase_mutable p right}
| _ -> assert false
let ctx_combine ctx = List.map combine ctx
prerr_string " " ;
prerr_string (Format.flush_str_formatter ()))
ps ;
-
+(*
prerr_string " -> " ;
Printlambda.lambda Format.str_formatter l ;
prerr_string (Format.flush_str_formatter ()) ;
-
+*)
prerr_endline "")
cases
| _ -> raise NoMatch
let get_key_constant caller = function
- | {pat_desc= Tpat_constant cst} as p -> cst
+ | {pat_desc= Tpat_constant cst} -> cst
| p ->
prerr_endline ("BAD: "^caller) ;
pretty_pat p ;
| Tpat_variant(lab, None , _) -> Cstr_constant (Btype.hash_variant lab)
| _ -> assert false
-let divide_variant row ctx ({cases = cl; args = al; default=def} as pm) =
+let divide_variant row ctx {cases = cl; args = al; default=def} =
let row = Btype.row_repr row in
let rec divide = function
({pat_desc = Tpat_variant(lab, pato, _)} as p:: patl, action) :: rem ->
let default = max_vals cases acts in
let min_key,_,_ = cases.(0)
and _,max_key,_ = cases.(Array.length cases-1) in
- let offset = max_key-min_key in
+
let rec do_rec i k =
if i >= 0 then
let low, high, act = cases.(i) in
let rec init_rec = function
| [] -> []
- | (i,act_i)::rem as all ->
+ | (i,act_i)::rem ->
let index = store.act_store act_i in
if index=0 then
fail_rec low i rem
end
| Total ->
None, [], jumps_empty
+
(* Conforme a l'article et plus simple qu'avant *)
(tag_lambda_list, total1, pats) =
if cstr.cstr_consts < 0 then begin
(* Special cases for exceptions *)
- let cstrs = List.map fst tag_lambda_list in
let fail, to_add, local_jumps =
mk_failaction_neg partial ctx def in
let tag_lambda_list = to_add@tag_lambda_list in
(* Regular concrete type *)
let ncases = List.length tag_lambda_list
and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in
- let sig_complete = ncases = nconstrs
- and cstrs = List.map fst tag_lambda_list in
+ let sig_complete = ncases = nconstrs in
let fails,local_jumps =
if sig_complete then [],jumps_empty
else
let sig_complete = List.length tag_lambda_list = !num_constr
and one_action = same_actions tag_lambda_list in
let fail, to_add, local_jumps =
- if sig_complete || (match partial with Total -> true | _ -> false) then
+ if
+ sig_complete || (match partial with Total -> true | _ -> false)
+ then
None, [], jumps_empty
else
mk_failaction_neg partial ctx def in
lam
| (Levent(lam', ev), Some r) ->
incr r;
- Levent(lam', {lev_pos = ev.lev_pos;
+ Levent(lam', {lev_loc = ev.lev_loc;
lev_kind = ev.lev_kind;
lev_repr = repr;
lev_env = ev.lev_env})
pretty_jumps jumps ;
r
*)
-
and do_compile_matching repr partial ctx arg pmh = match pmh with
| Pm pm ->
let pat = what_is_cases pm.cases in
(* The entry points *)
+(*
+ If there is a guard in a matching, then
+ set exhaustiveness info to Partial.
+ (because of side effects in guards, assume the worst)
+*)
+
+let check_partial pat_act_list partial =
+ if
+ List.exists
+ (fun (_,lam) -> is_guarded lam)
+ pat_act_list
+ then begin
+ Partial
+ end else
+ partial
+
-(* had toplevel handler when appropriate *)
+(* have toplevel handler when appropriate *)
let start_ctx n = [{left=[] ; right = omegas n}]
end
let compile_matching loc repr handler_fun arg pat_act_list partial =
+ let partial = check_partial pat_act_list partial in
match partial with
| Partial ->
let raise_num = next_raise_count () in
let (lambda, total) = compile_match repr partial (start_ctx 1) pm in
check_total total lambda raise_num handler_fun
with
- | Unused -> assert false ; handler_fun()
+ | Unused -> assert false (* ; handler_fun() *)
end
| Total ->
let pm =
assert (jumps_is_empty total) ;
lambda
+
let partial_function loc () =
(* [Location.get_pos_info] is too expensive *)
let fname = match loc.Location.loc_start.Lexing.pos_fname with
(* Easy case since variables are available *)
let for_tupled_function loc paraml pats_act_list partial =
+ let partial = check_partial pats_act_list partial in
let raise_num = next_raise_count () in
let omegas = [List.map (fun _ -> omega) paraml] in
let pm =
let flatten_pattern size p = match p.pat_desc with
-| Tpat_tuple args -> args
+| Tpat_tuple args -> args
| Tpat_any -> omegas size
| _ -> raise Cannot_flatten
| Tpat_any -> omegas size::k
| Tpat_tuple args -> args::k
| Tpat_or (p1,p2,_) -> flatten_pat_line size p1 (flatten_pat_line size p2 k)
+| Tpat_alias (p,_) -> (* Note: if this 'as' pat is here, then this is a useless
+ binding, solves PR #3780 *)
+ flatten_pat_line size p k
| _ -> fatal_error "Matching.flatten_pat_line"
let flatten_cases size cases =
cases
let flatten_matrix size pss =
- List.fold_right
+ List.fold_right
(fun ps r -> match ps with
| [p] -> flatten_pat_line size p r
| _ -> fatal_error "Matching.flatten_matrix")
let for_multiple_match loc paraml pat_act_list partial =
let repr = None in
+ let partial = check_partial pat_act_list partial in
let raise_num,pm1 =
match partial with
| Partial ->
| Total ->
assert (jumps_is_empty total) ;
lam)
-
-
with Cannot_flatten ->
let (lambda, total) = compile_match None partial (start_ctx 1) pm1 in
begin match partial with
lambda
end
with Unused ->
- assert false ; partial_function loc ()
+ assert false (* ; partial_function loc () *)
(* *)
(***********************************************************************)
-(* $Id: printinstr.ml,v 1.22 2004/05/26 11:10:50 garrigue Exp $ *)
+(* $Id: printinstr.ml,v 1.23 2005/08/25 15:35:16 doligez Exp $ *)
(* Pretty-print lists of instructions *)
| Kgetpubmet n -> fprintf ppf "\tgetpubmet %i" n
| Kgetdynmet -> fprintf ppf "\tgetdynmet"
| Kstop -> fprintf ppf "\tstop"
- | Kevent ev -> fprintf ppf "\tevent \"%s\" %i" ev.ev_char.Lexing.pos_fname
- ev.ev_char.Lexing.pos_cnum
+ | Kevent ev -> fprintf ppf "\tevent \"%s\" %i-%i"
+ ev.ev_loc.Location.loc_start.Lexing.pos_fname
+ ev.ev_loc.Location.loc_start.Lexing.pos_cnum
+ ev.ev_loc.Location.loc_end.Lexing.pos_cnum
let rec instruction_list ppf = function
[] -> ()
fprintf ppf "L%i:%a" lbl instruction_list il
| instr :: il ->
fprintf ppf "%a@ %a" instruction instr instruction_list il
-
+
let instrlist ppf il =
fprintf ppf "@[<v 0>%a@]" instruction_list il
(* *)
(***********************************************************************)
-(* $Id: printlambda.ml,v 1.49 2004/05/26 11:10:50 garrigue Exp $ *)
+(* $Id: printlambda.ml,v 1.51 2005/08/25 15:35:16 doligez Exp $ *)
open Format
open Asttypes
| Const_base(Const_int n) -> fprintf ppf "%i" n
| Const_base(Const_char c) -> fprintf ppf "%C" c
| Const_base(Const_string s) -> fprintf ppf "%S" s
+ | Const_immstring s -> fprintf ppf "#%S" s
| Const_base(Const_float f) -> fprintf ppf "%s" f
| Const_base(Const_int32 n) -> fprintf ppf "%lil" n
| Const_base(Const_int64 n) -> fprintf ppf "%LiL" n
if k = Self then "self" else if k = Cached then "cache" else "" in
fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs
| Levent(expr, ev) ->
- let kind =
+ let kind =
match ev.lev_kind with
| Lev_before -> "before"
| Lev_after _ -> "after"
| Lev_function -> "funct-body" in
- fprintf ppf "@[<2>(%s %i@ %a)@]" kind ev.lev_pos.Lexing.pos_cnum lam expr
+ fprintf ppf "@[<2>(%s %i-%i@ %a)@]" kind
+ ev.lev_loc.Location.loc_start.Lexing.pos_cnum
+ ev.lev_loc.Location.loc_end.Lexing.pos_cnum
+ lam expr
| Lifused(id, expr) ->
fprintf ppf "@[<2>(ifused@ %a@ %a)@]" Ident.print id lam expr
(* Sends back a boolean that says whether is switch is worth or not *)
-let dense ({cases=cases ; actions=actions} as s) i j =
+let dense {cases=cases ; actions=actions} i j =
if i=j then true
else
let l,_,_ = cases.(i)
let zyva (low,high) konst arg cases actions =
- let lcases = Array.length cases in
let old_ok = !ok_inter in
ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ;
if !ok_inter <> old_ok then Hashtbl.clear t ;
(* *)
(***********************************************************************)
-(* $Id: symtable.ml,v 1.37 2004/02/22 15:07:50 xleroy Exp $ *)
+(* $Id: symtable.ml,v 1.38 2004/11/30 07:28:00 garrigue Exp $ *)
(* To assign numbers to globals and primitives *)
| Const_base(Const_int64 i) -> Obj.repr i
| Const_base(Const_nativeint i) -> Obj.repr i
| Const_pointer i -> Obj.repr i
+ | Const_immstring s -> Obj.repr s
| Const_block(tag, fields) ->
let block = Obj.new_block tag (List.length fields) in
let pos = ref 0 in
(* *)
(***********************************************************************)
-(* $Id: translclass.ml,v 1.32.2.2 2005/08/08 01:40:31 garrigue Exp $ *)
+(* $Id: translclass.ml,v 1.38 2005/08/13 20:59:37 doligez Exp $ *)
open Misc
open Asttypes
let lfield v i = Lprim(Pfield i, [Lvar v])
-let transl_label l = share (Const_base (Const_string l))
+let transl_label l = share (Const_immstring l)
let rec transl_meth_list lst =
if lst = [] then Lconst (Const_pointer 0) else
share (Const_block
- (0, List.map (fun lab -> Const_base (Const_string lab)) lst))
+ (0, List.map (fun lab -> Const_immstring lab) lst))
let set_inst_var obj id expr =
let kind = if Typeopt.maybe_pointer expr then Paddrarray else Pintarray in
Lapply (oo_prim (if create then "new_variable" else "get_variable"),
[Lvar tbl; transl_label name])
-let transl_vals tbl create sure vals rem =
- if create && sure && List.length vals > 1 then
- let (_,id0) = List.hd vals in
- let call =
- Lapply(oo_prim "new_variables",
- [Lvar tbl; transl_meth_list (List.map fst vals)]) in
- let i = ref (List.length vals) in
- Llet(Strict, id0, call,
- List.fold_right
- (fun (name,id) rem ->
- decr i; Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem))
- (List.tl vals) rem)
- else
+let transl_vals tbl create vals rem =
List.fold_right
(fun (name, id) rem ->
Llet(StrictOpt, id, transl_val tbl create name, rem))
vals rem
-let transl_super tbl meths inh_methods rem =
+let meths_super tbl meths inh_meths =
List.fold_right
(fun (nm, id) rem ->
- begin try
- Llet(StrictOpt, id, Lapply (oo_prim "get_method",
- [Lvar tbl; Lvar (Meths.find nm meths)]),
- rem)
- with Not_found ->
- rem
- end)
- inh_methods rem
+ try
+ (nm, id,
+ Lapply(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
+ (List.fold_right (fun (nm, id, def) rem -> Llet(StrictOpt, id, def, rem))
+ meths cl_init)
let create_object cl obj init =
let obj' = Ident.create "self" in
[Lvar tbl; transl_label lab]),
cl_init)
-let bind_methods tbl meths 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 in
- if len < 2 then Meths.fold (bind_method tbl) meths cl_init else
+ 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
let ids = Ident.create "ids" in
let i = ref len in
+ let getter, names, cl_init =
+ match vals with [] -> "get_method_labels", [], cl_init
+ | (_,id0)::vals' ->
+ incr i;
+ let i = ref (List.length vals) in
+ "new_methods_variables",
+ [transl_meth_list (List.map fst vals)],
+ Llet(Strict, id0, lfield ids 0,
+ List.fold_right
+ (fun (name,id) rem ->
+ decr i;
+ Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem))
+ vals' cl_init)
+ in
Llet(StrictOpt, ids,
- Lapply (oo_prim "get_method_labels",
- [Lvar tbl; transl_meth_list (List.map fst methl)]),
+ Lapply (oo_prim getter,
+ [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
List.fold_right
- (fun (lab,id) lam ->
- decr i; Llet(StrictOpt, id, Lprim(Pfield !i, [Lvar ids]), lam))
+ (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
methl cl_init)
-let output_methods tbl vals methods lam =
- let lam =
- match methods with
- [] -> lam
- | [lab; code] ->
- lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
- | _ ->
- lsequence (Lapply(oo_prim "set_methods",
- [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
- lam
- in
- transl_vals tbl true true vals lam
+let output_methods tbl methods lam =
+ match methods with
+ [] -> lam
+ | [lab; code] ->
+ lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
+ | _ ->
+ lsequence (Lapply(oo_prim "set_methods",
+ [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
+ lam
let rec ignore_cstrs cl =
match cl.cl_desc with
| Tclass_apply (cl, _) -> ignore_cstrs cl
| _ -> cl
-let rec build_class_init cla cstr inh_init cl_init msubst top cl =
+let rec index a = function
+ [] -> raise Not_found
+ | b :: l ->
+ if b = a then 0 else 1 + index a l
+
+let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
match cl.cl_desc with
Tclass_ident path ->
begin match inh_init with
Llet (Strict, obj_init,
Lapply(Lprim(Pfield 1, [lpath]), Lvar cla ::
if top then [Lprim(Pfield 3, [lpath])] else []),
- cl_init))
+ bind_super cla super cl_init))
| _ ->
assert false
end
| Tclass_structure str ->
+ let cl_init = bind_super cla super cl_init in
let (inh_init, cl_init, methods, values) =
List.fold_right
(fun field (inh_init, cl_init, methods, values) ->
match field with
Cf_inher (cl, vals, meths) ->
- let cl_init = output_methods cla values methods cl_init in
+ let cl_init = output_methods cla methods cl_init in
let inh_init, cl_init =
- build_class_init cla false inh_init
- (transl_vals cla false false vals
- (transl_super cla str.cl_meths meths cl_init))
- msubst top cl in
- (inh_init, cl_init, [], [])
+ build_class_init cla false
+ (vals, meths_super cla str.cl_meths meths)
+ inh_init cl_init msubst top cl in
+ (inh_init, cl_init, [], values)
| Cf_val (name, id, exp) ->
(inh_init, cl_init, methods, (name, id)::values)
| Cf_meth (name, exp) ->
(inh_init, cl_init,
Lvar (Meths.find name str.cl_meths) :: met_code @ methods,
values)
- (*
- Lsequence(Lapply (oo_prim ("set_method" ^ builtin),
- Lvar cla ::
- Lvar (Meths.find name str.cl_meths) ::
- met_code),
- cl_init))
- *)
| Cf_let (rec_flag, defs, vals) ->
let vals =
List.map (function (id, _) -> (Ident.name id, id)) vals
str.cl_field
(inh_init, cl_init, [], [])
in
- let cl_init = output_methods cla values methods cl_init in
- (inh_init, bind_methods cla str.cl_meths cl_init)
+ let cl_init = output_methods cla methods cl_init in
+ (inh_init, bind_methods cla str.cl_meths values cl_init)
| Tclass_fun (pat, vals, cl, _) ->
let (inh_init, cl_init) =
- build_class_init cla cstr inh_init cl_init msubst top cl
+ 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 false vals cl_init)
+ (inh_init, transl_vals cla true vals cl_init)
| Tclass_apply (cl, exprs) ->
- build_class_init cla cstr inh_init cl_init msubst top cl
+ 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 inh_init cl_init msubst top cl
+ 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 false vals cl_init)
+ (inh_init, transl_vals cla true 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
+ let concr_meths = Concr.elements concr_meths in
let narrow_args =
[Lvar cla;
transl_meth_list vals;
transl_meth_list virt_meths;
- transl_meth_list (Concr.elements concr_meths)] in
+ transl_meth_list concr_meths] in
let cl = ignore_cstrs cl in
begin match cl.cl_desc, inh_init with
Tclass_ident path, (obj_init, path')::inh_init ->
assert (Path.same path path');
let lpath = transl_path path in
+ let inh = Ident.create "inh"
+ and inh_vals = Ident.create "vals"
+ and inh_meths = Ident.create "meths"
+ and valids, methids = super in
+ let cl_init =
+ List.fold_left
+ (fun init (nm, id, _) ->
+ Llet(StrictOpt, id, lfield inh_meths (index nm concr_meths),
+ init))
+ cl_init methids in
+ let cl_init =
+ List.fold_left
+ (fun init (nm, id) ->
+ Llet(StrictOpt, id, lfield inh_vals (index nm vals), init))
+ cl_init valids in
(inh_init,
- Llet (Strict, obj_init,
+ Llet (Strict, inh,
Lapply(oo_prim "inherits", narrow_args @
[lpath; Lconst(Const_pointer(if top then 1 else 0))]),
- cl_init))
+ Llet(StrictOpt, obj_init, lfield inh 0,
+ Llet(Alias, inh_vals, lfield inh 1,
+ Llet(Alias, inh_meths, lfield inh 2, cl_init)))))
| _ ->
let core cl_init =
- build_class_init cla true inh_init cl_init msubst top cl
+ build_class_init cla true super inh_init cl_init msubst top cl
in
if cstr then core cl_init else
let (inh_init, cl_init) =
let cla = Ident.create "class"
and new_init = Ident.create "new_init"
- and arg = Ident.create "arg"
and env_init = Ident.create "env_init"
and table = Ident.create "table"
and envs = Ident.create "envs" in
build_object_init_0 cla [] cl copy_env subst_env top ids in
if not (Translcore.check_recursive_lambda ids obj_init) then
raise(Error(cl.cl_loc, Illegal_class_expr));
+ let inh_init' = List.rev inh_init in
let (inh_init', cl_init) =
- build_class_init cla true (List.rev inh_init) obj_init msubst top cl
+ build_class_init cla true ([],[]) inh_init' obj_init msubst top cl
in
assert (inh_init' = []);
let table = Ident.create "table"
if top then llets (lbody_virt lambda_unit) else
(* Now for the hard stuff: prepare for table cacheing *)
- let env_index = Ident.create "env_index"
- and envs = Ident.create "envs" in
+ let envs = Ident.create "envs"
+ and cached = Ident.create "cached" in
let lenvs =
if !new_ids_meths = [] && !new_ids_init = [] && inh_init = []
then lambda_unit
Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]),
lam)
in
- let obj_init2 = Ident.create "obj_init"
- and cached = Ident.create "cached" in
let inh_paths =
List.filter
(fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in
else [lambda_unit; lfield cached 0; lambda_unit; lenvs]
)))))
-(* Dummy for recursive modules *)
-
-let dummy_class undef_fn =
- Lprim(Pmakeblock(0, Mutable), [undef_fn; undef_fn; undef_fn; lambda_unit])
-
(* Wrapper for class compilation *)
let transl_class ids cl_id arity pub_meths cl =
(* *)
(***********************************************************************)
-(* $Id: translclass.mli,v 1.10 2004/05/26 11:10:50 garrigue Exp $ *)
+(* $Id: translclass.mli,v 1.11 2004/08/12 12:55:11 xleroy Exp $ *)
open Typedtree
open Lambda
-val dummy_class : lambda -> lambda
val transl_class :
Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;;
(* *)
(***********************************************************************)
-(* $Id: translcore.ml,v 1.96.2.1 2005/06/12 13:59:25 xleroy Exp $ *)
+(* $Id: translcore.ml,v 1.100 2005/08/25 15:35:16 doligez Exp $ *)
(* Translation from typed abstract syntax to lambda terms,
for the core language *)
[pat, ({exp_desc = Texp_function(pl,partial)} as exp)] ->
let pl = push_defaults exp.exp_loc bindings pl partial in
[pat, {exp with exp_desc = Texp_function(pl, partial)}]
- | [pat, ({exp_desc = Texp_let
- (Default, cases, ({exp_desc = Texp_function _} as e2))} as e1)] ->
+ | [pat, {exp_desc = Texp_let
+ (Default, cases, ({exp_desc = Texp_function _} as e2))}] ->
push_defaults loc (cases :: bindings) [pat, e2] partial
| [pat, exp] ->
let exp =
| Lstaticraise (_,_) -> lam
| _ ->
if !Clflags.debug
- then Levent(lam, {lev_pos = exp.exp_loc.Location.loc_start;
+ then Levent(lam, {lev_loc = exp.exp_loc;
lev_kind = Lev_before;
lev_repr = None;
lev_env = Env.summary exp.exp_env})
let event_after exp lam =
if !Clflags.debug
- then Levent(lam, {lev_pos = exp.exp_loc.Location.loc_end;
+ then Levent(lam, {lev_loc = exp.exp_loc;
lev_kind = Lev_after exp.exp_type;
lev_repr = None;
lev_env = Env.summary exp.exp_env})
let repr = Some (ref 0) in
let (info, body) = lam repr in
(info,
- Levent(body, {lev_pos = exp.exp_loc.Location.loc_start;
+ Levent(body, {lev_loc = exp.exp_loc;
lev_kind = Lev_function;
lev_repr = repr;
lev_env = Env.summary exp.exp_env}))
Const_base(Const_int char)]))])])
;;
+let rec cut n l =
+ if n = 0 then ([],l) else
+ match l with [] -> failwith "Translcore.cut"
+ | a::l -> let (l1,l2) = cut (n-1) l in (a::l1,l2)
+
(* Translation of expressions *)
let rec transl_exp e =
in
Lfunction(kind, params, body)
| Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, args)
- when List.length args = p.prim_arity
+ when List.length args >= p.prim_arity
&& List.for_all (fun (arg,_) -> arg <> None) args ->
+ let args, args' = cut p.prim_arity args in
+ let wrap f =
+ event_after e (if args' = [] then f else transl_apply f args') in
+ let wrap0 f =
+ if args' = [] then f else wrap f in
let args = List.map (function Some x, _ -> x | _ -> assert false) args in
let argl = transl_list args in
let public_send = p.prim_name = "%send"
if public_send || p.prim_name = "%sendself" then
let kind = if public_send then Public else Self in
let obj = List.hd argl in
- event_after e (Lsend (kind, List.nth argl 1, obj, []))
+ wrap (Lsend (kind, List.nth argl 1, obj, []))
else if p.prim_name = "%sendcache" then
match argl with [obj; meth; cache; pos] ->
- event_after e (Lsend(Cached, meth, obj, [cache; pos]))
+ wrap (Lsend(Cached, meth, obj, [cache; pos]))
| _ -> assert false
else begin
let prim = transl_prim p args in
match (prim, args) with
(Praise, [arg1]) ->
- Lprim(Praise, [event_after arg1 (List.hd argl)])
+ wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)]))
| (_, _) ->
- if primitive_is_ccall prim
- then event_after e (Lprim(prim, argl))
- else Lprim(prim, argl)
+ let p = Lprim(prim, argl) in
+ if primitive_is_ccall prim then wrap p else wrap0 p
end
| Texp_apply(funct, oargs) ->
event_after e (transl_apply (transl_exp funct) oargs)
- | Texp_match({exp_desc = Texp_tuple argl} as arg, pat_expr_list, partial) ->
+ | Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) ->
Matching.for_multiple_match e.exp_loc
(transl_list argl) (transl_cases pat_expr_list) partial
| Texp_match(arg, pat_expr_list, partial) ->
(* *)
(***********************************************************************)
-(* $Id: translmod.ml,v 1.50 2004/06/12 08:55:45 xleroy Exp $ *)
+(* $Id: translmod.ml,v 1.51 2004/08/12 12:55:11 xleroy Exp $ *)
(* Translation from typed abstract syntax to lambda terms,
for the module language *)
open Misc
open Asttypes
+open Longident
open Path
open Types
open Typedtree
(* Utilities for compiling "module rec" definitions *)
-let undefined_exception loc =
+let mod_prim name =
+ try
+ transl_path
+ (fst (Env.lookup_value (Ldot (Lident "CamlinternalMod", name))
+ Env.empty))
+ with Not_found ->
+ fatal_error ("Primitive " ^ name ^ " not found.")
+
+let undefined_location loc =
(* Confer Translcore.assert_failed *)
let fname = match loc.Location.loc_start.Lexing.pos_fname with
| "" -> !Location.input_name
let pos = loc.Location.loc_start in
let line = pos.Lexing.pos_lnum in
let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in
- Lprim(Pmakeblock(0, Immutable),
- [transl_path Predef.path_undefined_recursive_module;
- Lconst(Const_block(0,
- [Const_base(Const_string fname);
- Const_base(Const_int line);
- Const_base(Const_int char)]))])
-
-let undefined_function loc =
- Lfunction(Curried, [Ident.create "undef"],
- Lprim(Praise, [undefined_exception loc]))
-
-let init_value modl =
- let undef_exn_id = Ident.create "undef_exception" in
- let undef_function_id = Ident.create "undef_function" in
- let rec init_value_mod env mty =
+ Lconst(Const_block(0,
+ [Const_base(Const_string fname);
+ Const_base(Const_int line);
+ Const_base(Const_int char)]))
+
+let init_shape modl =
+ let rec init_shape_mod env mty =
match Mtype.scrape env mty with
Tmty_ident _ ->
raise Not_found
| Tmty_signature sg ->
- Lprim(Pmakeblock(0, Mutable), init_value_struct env sg)
+ Const_block(0, [Const_block(0, init_shape_struct env sg)])
| Tmty_functor(id, arg, res) ->
- raise Not_found (* to be fixed? *)
- and init_value_struct env sg =
+ raise Not_found (* can we do better? *)
+ and init_shape_struct env sg =
match sg with
[] -> []
| Tsig_value(id, vdesc) :: rem ->
let init_v =
match Ctype.expand_head env vdesc.val_type with
{desc = Tarrow(_,_,_,_)} ->
- Lvar undef_function_id
+ Const_pointer 0 (* camlinternalMod.Function *)
| {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t ->
- Lprim(Pmakeblock(Config.lazy_tag, Immutable),
- [Lvar undef_function_id])
+ Const_pointer 1 (* camlinternalMod.Lazy *)
| _ -> raise Not_found in
- init_v :: init_value_struct env rem
+ init_v :: init_shape_struct env rem
| Tsig_type(id, tdecl, _) :: rem ->
- init_value_struct (Env.add_type id tdecl env) rem
+ init_shape_struct (Env.add_type id tdecl env) rem
| Tsig_exception(id, edecl) :: rem ->
- transl_exception
- id (Some Predef.path_undefined_recursive_module) edecl ::
- init_value_struct env rem
+ raise Not_found
| Tsig_module(id, mty, _) :: rem ->
- init_value_mod env mty ::
- init_value_struct (Env.add_module id mty env) rem
+ init_shape_mod env mty ::
+ init_shape_struct (Env.add_module id mty env) rem
| Tsig_modtype(id, minfo) :: rem ->
- init_value_struct (Env.add_modtype id minfo env) rem
+ init_shape_struct (Env.add_modtype id minfo env) rem
| Tsig_class(id, cdecl, _) :: rem ->
- Translclass.dummy_class (Lvar undef_function_id) ::
- init_value_struct env rem
+ Const_pointer 2 (* camlinternalMod.Class *)
+ :: init_shape_struct env rem
| Tsig_cltype(id, ctyp, _) :: rem ->
- init_value_struct env rem
+ init_shape_struct env rem
in
try
- Some(Llet(Alias, undef_function_id, undefined_function modl.mod_loc,
- init_value_mod modl.mod_env modl.mod_type))
+ Some(undefined_location modl.mod_loc,
+ Lconst(init_shape_mod modl.mod_env modl.mod_type))
with Not_found ->
None
(* Generate lambda-code for a reordered list of bindings *)
-let prim_update =
- { prim_name = "caml_update_dummy";
- prim_arity = 2;
- prim_alloc = true;
- prim_native_name = "";
- prim_native_float = false }
-
let eval_rec_bindings bindings cont =
let rec bind_inits = function
[] ->
bind_strict bindings
| (id, None, rhs) :: rem ->
bind_inits rem
- | (id, Some init, rhs) :: rem ->
- Llet(Strict, id, init, bind_inits rem)
+ | (id, Some(loc, shape), rhs) :: rem ->
+ Llet(Strict, id, Lapply(mod_prim "init_mod", [loc; shape]),
+ bind_inits rem)
and bind_strict = function
[] ->
patch_forwards bindings
| (id, None, rhs) :: rem ->
Llet(Strict, id, rhs, bind_strict rem)
- | (id, Some init, rhs) :: rem ->
+ | (id, Some(loc, shape), rhs) :: rem ->
bind_strict rem
and patch_forwards = function
[] ->
cont
| (id, None, rhs) :: rem ->
patch_forwards rem
- | (id, Some init, rhs) :: rem ->
- Lsequence(Lprim(Pccall prim_update, [Lvar id; rhs]), patch_forwards rem)
+ | (id, Some(loc, shape), rhs) :: rem ->
+ Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs]),
+ patch_forwards rem)
in
bind_inits bindings
(reorder_rec_bindings
(List.map
(fun (id, modl) ->
- (id, modl.mod_loc, init_value modl, compile_rhs id modl))
+ (id, modl.mod_loc, init_shape modl, compile_rhs id modl))
bindings))
cont
primitives
prims.c
opnames.h
+version.h
ocamlrun
ocamlrund
ld.conf
freelist.h minor_gc.h globroots.h stacks.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 sys.h
+ major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \
+ sys.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
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
+ prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \
+ version.h
str.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h fail.h
sys.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \
freelist.h minor_gc.h globroots.h stacks.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 sys.h
+ major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \
+ sys.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
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
+ prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \
+ version.h
str.d.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h fail.h
sys.d.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \
# #
#########################################################################
-# $Id: Makefile,v 1.48.4.2 2004/08/20 15:11:36 doligez Exp $
+# $Id: Makefile,v 1.52 2005/10/18 14:03:52 xleroy Exp $
include ../config/Makefile
echo ' 0 };') > prims.c
opnames.h : instruct.h
- LANG=C; \
sed -e '/\/\*/d' \
-e '/^#/d' \
-e 's/enum /char * names_of_/' \
-e 's/{$$/[] = {/' \
- -e 's/\([A-Z][A-Z_0-9]*\)/"\1"/g' instruct.h > opnames.h
+ -e 's/\([[:upper:]][[:upper:]_0-9]*\)/"\1"/g' instruct.h > opnames.h
# jumptbl.h is required only if you have GCC 2.0 or later
jumptbl.h : instruct.h
sed -n -e '/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp' \
-e '/^}/q' instruct.h > jumptbl.h
+version.h : ../stdlib/sys.ml
+ sed -n -e 's/;;//' \
+ -e '/let *ocaml_version *= */s//#define OCAML_VERSION /p' \
+ <../stdlib/sys.ml >version.h
+
.SUFFIXES: .d.o
.c.d.o:
mv $*.o $*.d.o
@ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi
-depend : prims.c opnames.h jumptbl.h
+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
# #
#########################################################################
-# $Id: Makefile.nt,v 1.36.4.1 2004/08/20 15:11:36 doligez Exp $
+# $Id: Makefile.nt,v 1.38 2005/02/02 15:51:23 xleroy Exp $
include ../config/Makefile
sed -n -e "/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp" \
-e "/^}/q" instruct.h > jumptbl.h
+version.h : ../stdlib/sys.ml
+ sed -n -e 's/;;//' \
+ -e '/let *ocaml_version *= */s//#define OCAML_VERSION /p' \
+ <../stdlib/sys.ml >version.h
+
main.$(DO): main.c
$(CC) $(DLLCCCOMPOPTS) -c main.c
mv main.$(O) main.$(DO)
/* */
/***********************************************************************/
-/* $Id: alloc.h,v 1.17 2004/01/02 19:23:18 doligez Exp $ */
+/* $Id: alloc.h,v 1.18 2005/09/22 14:21:50 xleroy Exp $ */
#ifndef CAML_ALLOC_H
#define CAML_ALLOC_H
CAMLextern value caml_copy_double (double);
CAMLextern value caml_copy_int32 (int32); /* defined in [ints.c] */
CAMLextern value caml_copy_int64 (int64); /* defined in [ints.c] */
-CAMLextern value caml_copy_nativeint (long); /* defined in [ints.c] */
+CAMLextern value caml_copy_nativeint (intnat); /* defined in [ints.c] */
CAMLextern value caml_alloc_array (value (*funct) (char const *),
char const ** array);
/* */
/***********************************************************************/
-/* $Id: array.c,v 1.22 2004/01/02 19:23:19 doligez Exp $ */
+/* $Id: array.c,v 1.23 2005/09/22 14:21:50 xleroy Exp $ */
/* Operations on arrays */
CAMLprim value caml_array_get_addr(value array, value index)
{
- long idx = Long_val(index);
+ intnat idx = Long_val(index);
if (idx < 0 || idx >= Wosize_val(array)) caml_array_bound_error();
return Field(array, idx);
}
CAMLprim value caml_array_get_float(value array, value index)
{
- long idx = Long_val(index);
+ intnat idx = Long_val(index);
double d;
value res;
CAMLprim value caml_array_set_addr(value array, value index, value newval)
{
- long idx = Long_val(index);
+ intnat idx = Long_val(index);
if (idx < 0 || idx >= Wosize_val(array)) caml_array_bound_error();
Modify(&Field(array, idx), newval);
return Val_unit;
CAMLprim value caml_array_set_float(value array, value index, value newval)
{
- long idx = Long_val(index);
+ intnat idx = Long_val(index);
if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
caml_array_bound_error();
Store_double_field(array, idx, Double_val(newval));
CAMLprim value caml_array_unsafe_set_addr(value array, value index,value newval)
{
- long idx = Long_val(index);
+ intnat idx = Long_val(index);
Modify(&Field(array, idx), newval);
return Val_unit;
}
/* */
/***********************************************************************/
-/* $Id: backtrace.c,v 1.20 2004/01/02 19:23:19 doligez Exp $ */
+/* $Id: backtrace.c,v 1.23 2005/10/25 16:22:38 doligez Exp $ */
/* Stack backtrace for uncaught exceptions */
/* Location of fields in the Instruct.debug_event record */
enum { EV_POS = 0,
EV_MODULE = 1,
- EV_CHAR = 2,
+ EV_LOC = 2,
EV_KIND = 3 };
+/* Location of fields in the Location.t record. */
+enum { LOC_START = 0,
+ LOC_END = 1,
+ LOC_GHOST = 2 };
+
/* Location of fields in the Lexing.position record. */
enum {
POS_FNAME = 0,
static value event_for_location(value events, code_t pc)
{
mlsize_t i;
- value pos, l, ev, ev_pos;
+ value pos, l, ev, ev_pos, best_ev;
+ best_ev = 0;
Assert(pc >= caml_start_code && pc < caml_start_code + caml_code_size);
pos = Val_long((char *) pc - (char *) caml_start_code);
for (i = 0; i < Wosize_val(events); i++) {
for (l = Field(events, i); l != Val_int(0); l = Field(l, 1)) {
ev = Field(l, 0);
ev_pos = Field(ev, EV_POS);
+ if (ev_pos == pos) return ev;
/* ocamlc sometimes moves an event past a following PUSH instruction;
allow mismatch by 1 instruction. */
- if (ev_pos == pos || ev_pos == pos + 8) return ev;
+ if (ev_pos == pos + 8) best_ev = ev;
}
}
+ if (best_ev != 0) return best_ev;
return Val_false;
}
if (ev == Val_false) {
fprintf(stderr, "%s unknown location\n", info);
} else {
- value ev_char = Field (ev, EV_CHAR);
- char *fname = String_val (Field (ev_char, POS_FNAME));
- int lnum = Int_val (Field (ev_char, POS_LNUM));
- int chr = Int_val (Field (ev_char, POS_CNUM))
- - Int_val (Field (ev_char, POS_BOL));
- fprintf (stderr, "%s file \"%s\", line %d, character %d\n", info, fname,
- lnum, chr);
+ 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);
}
}
/* */
/***********************************************************************/
-/* $Id: compact.c,v 1.22.6.1 2005/03/09 15:49:09 doligez Exp $ */
+/* $Id: compact.c,v 1.24 2005/09/22 14:21:50 xleroy Exp $ */
#include <string.h>
#include "roots.h"
#include "weak.h"
-extern unsigned long caml_percent_free; /* major_gc.c */
+extern uintnat caml_percent_free; /* major_gc.c */
extern void caml_shrink_heap (char *); /* memory.c */
/* Encoded headers: the color is stored in the 2 least significant bits.
#define Tag_ehd(h) (((h) >> 2) & 0xFF)
#define Ecolor(w) ((w) & 3)
-typedef unsigned long word;
+typedef uintnat word;
static void invert_pointer_at (word *p)
{
word q = *p;
- Assert (Ecolor ((long) p) == 0);
+ Assert (Ecolor ((intnat) p) == 0);
/* Use Ecolor (q) == 0 instead of Is_block (q) because q could be an
inverted pointer for an infix header (with Ecolor == 2). */
/* Get the original header of this block. */
infixes = p + sz;
q = *infixes;
- while (Ecolor (q) != 3) q = * (word *) (q & ~(unsigned long)3);
+ while (Ecolor (q) != 3) q = * (word *) (q & ~(uintnat)3);
sz = Whsize_ehd (q);
t = Tag_ehd (q);
}
/* Get the original header of this block. */
infixes = p + sz;
q = *infixes; Assert (Ecolor (q) == 2);
- while (Ecolor (q) != 3) q = * (word *) (q & ~(unsigned long)3);
+ while (Ecolor (q) != 3) q = * (word *) (q & ~(uintnat)3);
sz = Whsize_ehd (q);
t = Tag_ehd (q);
}
if (infixes != NULL){
/* Rebuild the infix headers and revert the infix pointers. */
while (Ecolor ((word) infixes) != 3){
- infixes = (word *) ((word) infixes & ~(unsigned long) 3);
+ infixes = (word *) ((word) infixes & ~(uintnat) 3);
q = *infixes;
while (Ecolor (q) == 2){
word next;
- q = (word) q & ~(unsigned long) 3;
+ q = (word) q & ~(uintnat) 3;
next = * (word *) q;
* (word *) q = (word) Val_hp ((word *) newadr + (infixes - p));
q = next;
caml_gc_message (0x10, "done.\n", 0);
}
-unsigned long caml_percent_max; /* used in gc_ctrl.c */
+uintnat caml_percent_max; /* used in gc_ctrl.c */
void caml_compact_heap_maybe (void)
{
fp = 100.0 * fw / (Wsize_bsize (caml_stat_heap_size) - fw);
if (fp > 1000000.0) fp = 1000000.0;
}
- caml_gc_message (0x200, "FL size at phase change = %lu\n",
- (unsigned long) caml_fl_size_at_phase_change);
- caml_gc_message (0x200, "Estimated overhead = %lu%%\n", (unsigned long) fp);
+ caml_gc_message (0x200, "FL size at phase change = %"
+ ARCH_INTNAT_PRINTF_FORMAT "u\n",
+ (uintnat) caml_fl_size_at_phase_change);
+ caml_gc_message (0x200, "Estimated overhead = %"
+ ARCH_INTNAT_PRINTF_FORMAT "u%%\n",
+ (uintnat) fp);
if (fp >= caml_percent_max){
caml_gc_message (0x200, "Automatic compaction triggered.\n", 0);
caml_finish_major_cycle ();
/* We just did a complete GC, so we can measure the overhead exactly. */
fw = caml_fl_cur_size;
fp = 100.0 * fw / (Wsize_bsize (caml_stat_heap_size) - fw);
- caml_gc_message (0x200, "Measured overhead: %lu%%\n", (unsigned long) fp);
+ caml_gc_message (0x200, "Measured overhead: %"
+ ARCH_INTNAT_PRINTF_FORMAT "u%%\n",
+ (uintnat) fp);
caml_compact_heap ();
}
/* */
/***********************************************************************/
-/* $Id: compare.c,v 1.31.6.1 2004/07/07 16:48:46 xleroy Exp $ */
+/* $Id: compare.c,v 1.34 2005/09/22 14:21:50 xleroy Exp $ */
#include <string.h>
#include <stdlib.h>
< 0 and > UNORDERED v1 is less than v2
UNORDERED v1 and v2 cannot be compared */
-static long compare_val(value v1, value v2, int total)
+static intnat compare_val(value v1, value v2, int total)
{
struct compare_item * sp;
tag_t t1, t2;
t2 = Tag_val(v2);
if (t1 == Forward_tag) { v1 = Forward_val (v1); continue; }
if (t2 == Forward_tag) { v2 = Forward_val (v2); continue; }
- if (t1 != t2) return (long)t1 - (long)t2;
+ if (t1 != t2) return (intnat)t1 - (intnat)t2;
switch(t1) {
case String_tag: {
mlsize_t len1, len2, len;
p2 = (unsigned char *) String_val(v2);
len > 0;
len--, p1++, p2++)
- if (*p1 != *p2) return (long)*p1 - (long)*p2;
+ if (*p1 != *p2) return (intnat)*p1 - (intnat)*p2;
if (len1 != len2) return len1 - len2;
break;
}
compare_free_stack();
caml_invalid_argument("equal: functional value");
case Object_tag: {
- long oid1 = Oid_val(v1);
- long oid2 = Oid_val(v2);
+ intnat oid1 = Oid_val(v1);
+ intnat oid2 = Oid_val(v2);
if (oid1 != oid2) return oid1 - oid2;
break;
}
CAMLprim value caml_compare(value v1, value v2)
{
- long res = compare_val(v1, v2, 1);
+ intnat res = compare_val(v1, v2, 1);
/* Free stack if needed */
if (compare_stack != compare_stack_init) compare_free_stack();
if (res < 0)
CAMLprim value caml_equal(value v1, value v2)
{
- long res = compare_val(v1, v2, 0);
+ intnat res = compare_val(v1, v2, 0);
if (compare_stack != compare_stack_init) compare_free_stack();
return Val_int(res == 0);
}
CAMLprim value caml_notequal(value v1, value v2)
{
- long res = compare_val(v1, v2, 0);
+ intnat res = compare_val(v1, v2, 0);
if (compare_stack != compare_stack_init) compare_free_stack();
return Val_int(res != 0);
}
CAMLprim value caml_lessthan(value v1, value v2)
{
- long res = compare_val(v1, v2, 0);
+ intnat res = compare_val(v1, v2, 0);
if (compare_stack != compare_stack_init) compare_free_stack();
return Val_int(res - 1 < -1);
}
CAMLprim value caml_lessequal(value v1, value v2)
{
- long res = compare_val(v1, v2, 0);
+ intnat res = compare_val(v1, v2, 0);
if (compare_stack != compare_stack_init) compare_free_stack();
return Val_int(res - 1 <= -1);
}
CAMLprim value caml_greaterthan(value v1, value v2)
{
- long res = compare_val(v1, v2, 0);
+ intnat res = compare_val(v1, v2, 0);
if (compare_stack != compare_stack_init) compare_free_stack();
return Val_int(res > 0);
}
CAMLprim value caml_greaterequal(value v1, value v2)
{
- long res = compare_val(v1, v2, 0);
+ intnat res = compare_val(v1, v2, 0);
if (compare_stack != compare_stack_init) compare_free_stack();
return Val_int(res >= 0);
}
--- /dev/null
+/***********************************************************************/
+/* */
+/* Objective Caml */
+/* */
+/* Damien Doligez, Projet Moscova, INRIA Rocquencourt */
+/* */
+/* Copyright 2003 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the GNU Library General Public License, with */
+/* the special exception on linking described in file ../LICENSE. */
+/* */
+/***********************************************************************/
+
+/* $Id: compare.h,v 1.2 2003/12/31 14:20:35 doligez Exp $ */
+
+#ifndef CAML_COMPARE_H
+#define CAML_COMPARE_H
+
+CAMLextern int caml_compare_unordered;
+
+#endif /* CAML_COMPARE_H */
/* */
/***********************************************************************/
-/* $Id: compatibility.h,v 1.13 2004/06/14 14:28:30 doligez Exp $ */
+/* $Id: compatibility.h,v 1.14 2005/07/29 12:11:00 xleroy Exp $ */
/* definitions for compatibility with old identifiers */
#define do_local_roots caml_do_local_roots
/* **** signals.c */
-#define async_signal_mode caml_async_signal_mode
-#define pending_signal caml_pending_signal
+#define pending_signals caml_pending_signals
#define something_to_do caml_something_to_do
#define enter_blocking_section_hook caml_enter_blocking_section_hook
#define leave_blocking_section_hook caml_leave_blocking_section_hook
+#define try_leave_blocking_section_hook caml_try_leave_blocking_section_hook
#define async_action_hook caml_async_action_hook
#define enter_blocking_section caml_enter_blocking_section
#define leave_blocking_section caml_leave_blocking_section
/* */
/***********************************************************************/
-/* $Id: config.h,v 1.36 2004/04/19 07:55:28 starynke Exp $ */
+/* $Id: config.h,v 1.39 2005/09/24 09:19:28 xleroy Exp $ */
#ifndef CAML_CONFIG_H
#define CAML_CONFIG_H
#include "compatibility.h"
#endif
-/* Types for signed chars, 16-bit integers, 32-bit integers, 64-bit integers */
+/* Types for signed chars, 32-bit integers, 64-bit integers,
+ native integers (as wide as a pointer type) */
typedef signed char schar;
-typedef short int16; /* FIXME -- not true on the Cray T3E */
-typedef unsigned short uint16; /* FIXME -- not true on the Cray T3E */
+#if SIZEOF_PTR == SIZEOF_LONG
+/* Standard models: ILP32 or I32LP64 */
+typedef long intnat;
+typedef unsigned long uintnat;
+#define ARCH_INTNAT_PRINTF_FORMAT "l"
+#elif SIZEOF_PTR == SIZEOF_INT
+/* Hypothetical IP32L64 model */
+typedef int intnat;
+typedef unsigned int uintnat;
+#define ARCH_INTNAT_PRINTF_FORMAT ""
+#elif SIZEOF_PTR == 8 && defined(ARCH_INT64_TYPE)
+/* Win64 model: IL32LLP64 */
+typedef ARCH_INT64_TYPE intnat;
+typedef ARCH_UINT64_TYPE uintnat;
+#define ARCH_INTNAT_PRINTF_FORMAT ARCH_INT64_PRINTF_FORMAT
+#else
+#error "No integer type available to represent pointers"
+#endif
#if SIZEOF_INT == 4
typedef int int32;
typedef unsigned int uint32;
+#define ARCH_INT32_PRINTF_FORMAT ""
#elif SIZEOF_LONG == 4
typedef long int32;
typedef unsigned long uint32;
+#define ARCH_INT32_PRINTF_FORMAT "l"
#elif SIZEOF_SHORT == 4
typedef short int32;
typedef unsigned short uint32;
+#define ARCH_INT32_PRINTF_FORMAT ""
+#else
+#error "No 32-bit integer type available"
#endif
#if defined(ARCH_INT64_TYPE)
typedef ARCH_INT64_TYPE int64;
typedef ARCH_UINT64_TYPE uint64;
#else
-# if ARCH_BIG_ENDIAN
+# ifdef ARCH_BIG_ENDIAN
typedef struct { uint32 h, l; } uint64, int64;
# else
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 (long)]. */
+ It must be a multiple of [sizeof (value)]. */
#define Page_log 12 /* A page is 4 kilobytes. */
/* Initial size of stack (bytes). */
/* */
/***********************************************************************/
-/* $Id: custom.c,v 1.14 2004/01/05 20:25:58 doligez Exp $ */
+/* $Id: custom.c,v 1.15 2005/09/22 14:21:50 xleroy Exp $ */
#include <string.h>
#include "mlvalues.h"
CAMLexport value caml_alloc_custom(struct custom_operations * ops,
- unsigned long size,
+ uintnat size,
mlsize_t mem,
mlsize_t max)
{
/* */
/***********************************************************************/
-/* $Id: custom.h,v 1.11.6.1 2005/02/22 14:33:36 doligez Exp $ */
+/* $Id: custom.h,v 1.13 2005/09/22 14:21:50 xleroy Exp $ */
#ifndef CAML_CUSTOM_H
#define CAML_CUSTOM_H
char *identifier;
void (*finalize)(value v);
int (*compare)(value v1, value v2);
- long (*hash)(value v);
+ intnat (*hash)(value v);
void (*serialize)(value v,
- /*out*/ unsigned long * wsize_32 /*size in bytes*/,
- /*out*/ unsigned long * wsize_64 /*size in bytes*/);
- unsigned long (*deserialize)(void * dst);
+ /*out*/ uintnat * wsize_32 /*size in bytes*/,
+ /*out*/ uintnat * wsize_64 /*size in bytes*/);
+ uintnat (*deserialize)(void * dst);
};
#define custom_finalize_default NULL
#define Custom_ops_val(v) (*((struct custom_operations **) (v)))
CAMLextern value caml_alloc_custom(struct custom_operations * ops,
- unsigned long size, /*size in bytes*/
+ uintnat size, /*size in bytes*/
mlsize_t mem, /*resources consumed*/
mlsize_t max /*max resources*/);
/* */
/***********************************************************************/
-/* $Id: debugger.c,v 1.28 2004/01/02 19:23:20 doligez Exp $ */
+/* $Id: debugger.c,v 1.29 2005/09/22 14:21:50 xleroy Exp $ */
/* Interface with the debugger */
#include "sys.h"
int caml_debugger_in_use = 0;
-unsigned long caml_event_count;
+uintnat caml_event_count;
#if !defined(HAS_SOCKETS) || defined(_WIN32)
{
int frame_number;
value * frame;
- long i, pos;
+ intnat i, pos;
value val;
if (dbg_socket == -1) return; /* Not connected to a debugger. */
/* */
/***********************************************************************/
-/* $Id: debugger.h,v 1.9 2004/01/01 16:42:35 doligez Exp $ */
+/* $Id: debugger.h,v 1.10 2005/09/22 14:21:50 xleroy Exp $ */
/* Interface with the debugger */
extern int caml_debugger_in_use;
extern int running;
-extern unsigned long caml_event_count;
+extern uintnat caml_event_count;
enum event_kind {
EVENT_COUNT, BREAKPOINT, PROGRAM_START, PROGRAM_EXIT,
/* */
/***********************************************************************/
-/* $Id: dynlink.c,v 1.14 2004/02/22 15:07:51 xleroy Exp $ */
+/* $Id: dynlink.c,v 1.15 2005/09/22 14:21:50 xleroy Exp $ */
/* Dynamic loading of C primitives. */
realname = caml_search_dll_in_path(&caml_shared_libs_path, name);
caml_gc_message(0x100, "Loading shared library %s\n",
- (unsigned long) realname);
+ (uintnat) realname);
handle = caml_dlopen(realname);
if (handle == NULL)
caml_fatal_error_arg2("Fatal error: cannot load shared library %s\n", name,
/* */
/***********************************************************************/
-/* $Id: extern.c,v 1.56 2004/06/19 16:02:07 xleroy Exp $ */
+/* $Id: extern.c,v 1.58 2005/09/22 14:21:50 xleroy Exp $ */
/* Structured output */
#include "mlvalues.h"
#include "reverse.h"
-/* To keep track of sharing in externed objects */
+static uintnat obj_counter; /* Number of objects emitted so far */
+static uintnat size_32; /* Size in words of 32-bit block for struct. */
+static uintnat size_64; /* Size in words of 64-bit block for struct. */
-typedef unsigned long byteoffset_t;
+static int extern_ignore_sharing; /* Flag to ignore sharing */
+static int extern_closures; /* Flag to allow externing code pointers */
+
+/* Trail mechanism to undo forwarding pointers put inside objects */
-struct extern_obj {
- byteoffset_t ofs;
- value obj;
+struct trail_entry {
+ value obj; /* address of object + initial color in low 2 bits */
+ value field0; /* initial contents of field 0 */
};
-static byteoffset_t initial_ofs = 1; /* Initial value of object offsets */
-static byteoffset_t obj_counter; /* Number of objects emitted so far */
-static struct extern_obj * extern_table = NULL; /* Table of objects seen */
-static unsigned long extern_table_size;
-static unsigned long extern_table_mask;
-static unsigned int extern_hash_shift;
-/* extern_table_size, extern_table_mask and extern_hash_shift are such that
- extern_table_size == 1 << (wordsize - extern_hash_shift)
- extern_table_mask == extern_table_size - 1 */
-
-/* Multiplicative Fibonacci hashing (Knuth vol 3, section 6.4, page 518).
- HASH_FACTOR is (sqrt(5) - 1) / 2 * 2^wordsize. */
-#ifdef ARCH_SIXTYFOUR
-#define HASH_FACTOR 11400714819323198485UL
-#else
-#define HASH_FACTOR 2654435769UL
-#endif
-#define Hash(v) (((unsigned long)(v) * HASH_FACTOR) >> extern_hash_shift)
-
-/* Allocate a new extern table */
-static void alloc_extern_table(void)
-{
- asize_t i;
- extern_table = (struct extern_obj *)
- caml_stat_alloc(extern_table_size * sizeof(struct extern_obj));
- for (i = 0; i < extern_table_size; i++) extern_table[i].ofs = 0;
-}
-
-/* Grow the extern table */
-static void resize_extern_table(void)
-{
- asize_t oldsize;
- struct extern_obj * oldtable;
- value obj;
- byteoffset_t ofs;
- asize_t i, h;
-
- oldsize = extern_table_size;
- oldtable = extern_table;
- extern_hash_shift = extern_hash_shift - 1;
- extern_table_size = 2 * extern_table_size;
- extern_table_mask = extern_table_size - 1;
- alloc_extern_table();
- for (i = 0; i < oldsize; i++) {
- ofs = oldtable[i].ofs;
- if (ofs >= initial_ofs) {
- obj = oldtable[i].obj;
- h = Hash(obj);
- while (extern_table[h].ofs > 0) h = (h + 1) & extern_table_mask;
- extern_table[h].ofs = ofs;
- extern_table[h].obj = obj;
+struct trail_block {
+ struct trail_block * previous;
+ struct trail_entry entries[ENTRIES_PER_TRAIL_BLOCK];
+};
+
+static struct trail_block extern_trail_first;
+static struct trail_block * extern_trail_block;
+static struct trail_entry * extern_trail_cur, * extern_trail_limit;
+
+/* Forward declarations */
+
+static void extern_out_of_memory(void);
+static void extern_invalid_argument(char *msg);
+
+/* Initialize the trail */
+
+static void init_extern_trail(void)
+{
+ extern_trail_block = &extern_trail_first;
+ extern_trail_cur = extern_trail_block->entries;
+ extern_trail_limit = extern_trail_block->entries + ENTRIES_PER_TRAIL_BLOCK;
+}
+
+/* Replay the trail, undoing the in-place modifications
+ performed on objects */
+
+static void extern_replay_trail(void)
+{
+ struct trail_block * blk, * prevblk;
+ struct trail_entry * ent, * lim;
+
+ blk = extern_trail_block;
+ lim = extern_trail_cur;
+ while (1) {
+ for (ent = &(blk->entries[0]); ent < lim; ent++) {
+ value obj = ent->obj;
+ color_t colornum = obj & 3;
+ obj = obj & ~3;
+ Hd_val(obj) = Coloredhd_hd(Hd_val(obj), colornum);
+ Field(obj, 0) = ent->field0;
}
+ if (blk == &extern_trail_first) break;
+ prevblk = blk->previous;
+ free(blk);
+ blk = prevblk;
+ lim = &(blk->entries[ENTRIES_PER_TRAIL_BLOCK]);
}
- caml_stat_free(oldtable);
+ /* Protect against a second call to extern_replay_trail */
+ extern_trail_block = &extern_trail_first;
+ extern_trail_cur = extern_trail_block->entries;
}
-/* Free the extern table. We keep it around for next call if
- it's still small (we did not grow it) and the initial offset
- does not risk overflowing next time. */
-static void free_extern_table(void)
+/* Set forwarding pointer on an object and add corresponding entry
+ to the trail. */
+
+static void extern_record_location(value obj)
{
- if (extern_table_size > INITIAL_EXTERN_TABLE_SIZE ||
- initial_ofs >= INITIAL_OFFSET_MAX) {
- caml_stat_free(extern_table);
- extern_table = NULL;
+ header_t hdr;
+
+ if (extern_ignore_sharing) return;
+ if (extern_trail_cur == extern_trail_limit) {
+ struct trail_block * new_block = malloc(sizeof(struct trail_block));
+ if (new_block == NULL) extern_out_of_memory();
+ new_block->previous = extern_trail_block;
+ extern_trail_block = new_block;
+ extern_trail_cur = extern_trail_block->entries;
+ extern_trail_limit = extern_trail_block->entries + ENTRIES_PER_TRAIL_BLOCK;
}
+ hdr = Hd_val(obj);
+ extern_trail_cur->obj = obj | Colornum_hd(hdr);
+ extern_trail_cur->field0 = Field(obj, 0);
+ extern_trail_cur++;
+ Hd_val(obj) = Bluehd_hd(hdr);
+ Field(obj, 0) = (value) obj_counter;
+ obj_counter++;
}
/* To buffer the output */
-static char * extern_block, * extern_ptr, * extern_limit;
-static int extern_block_malloced;
+static char * extern_userprovided_output;
+static char * extern_ptr, * extern_limit;
+
+struct output_block {
+ struct output_block * next;
+ char * end;
+ char data[SIZE_EXTERN_OUTPUT_BLOCK];
+};
+
+static struct output_block * extern_output_first, * extern_output_block;
-static void alloc_extern_block(void)
+static void init_extern_output(void)
{
- extern_block = caml_stat_alloc(INITIAL_EXTERN_BLOCK_SIZE);
- extern_limit = extern_block + INITIAL_EXTERN_BLOCK_SIZE;
- extern_ptr = extern_block;
- extern_block_malloced = 1;
+ extern_userprovided_output = NULL;
+ extern_output_first = malloc(sizeof(struct output_block));
+ if (extern_output_first == NULL) caml_raise_out_of_memory();
+ extern_output_block = extern_output_first;
+ extern_output_block->next = NULL;
+ extern_ptr = extern_output_block->data;
+ extern_limit = extern_output_block->data + SIZE_EXTERN_OUTPUT_BLOCK;
+}
+
+static void free_extern_output(void)
+{
+ struct output_block * blk, * nextblk;
+
+ if (extern_userprovided_output != NULL) return;
+ for (blk = extern_output_first; blk != NULL; blk = nextblk) {
+ nextblk = blk->next;
+ free(blk);
+ }
+ extern_output_first = NULL;
}
-static void resize_extern_block(int required)
+static void grow_extern_output(intnat required)
{
- long curr_pos, size, reqd_size;
+ struct output_block * blk;
+ intnat extra;
- if (! extern_block_malloced) {
- initial_ofs += obj_counter;
- free_extern_table();
+ if (extern_userprovided_output != NULL) {
+ extern_replay_trail();
caml_failwith("Marshal.to_buffer: buffer overflow");
}
- curr_pos = extern_ptr - extern_block;
- size = extern_limit - extern_block;
- reqd_size = curr_pos + required;
- while (size <= reqd_size) size *= 2;
- extern_block = caml_stat_resize(extern_block, size);
- extern_limit = extern_block + size;
- extern_ptr = extern_block + curr_pos;
+ extern_output_block->end = extern_ptr;
+ if (required <= SIZE_EXTERN_OUTPUT_BLOCK / 2)
+ extra = 0;
+ else
+ extra = required;
+ blk = malloc(sizeof(struct output_block) + extra);
+ if (blk == NULL) extern_out_of_memory();
+ extern_output_block->next = blk;
+ extern_output_block = blk;
+ extern_output_block->next = NULL;
+ extern_ptr = extern_output_block->data;
+ extern_limit = extern_output_block->data + SIZE_EXTERN_OUTPUT_BLOCK + extra;
+}
+
+static intnat extern_output_length(void)
+{
+ struct output_block * blk;
+ intnat len;
+
+ if (extern_userprovided_output != NULL) {
+ return extern_ptr - extern_userprovided_output;
+ } else {
+ for (len = 0, blk = extern_output_first; blk != NULL; blk = blk->next)
+ len += blk->end - blk->data;
+ return len;
+ }
+}
+
+/* Exception raising, with cleanup */
+
+static void extern_out_of_memory(void)
+{
+ extern_replay_trail();
+ free_extern_output();
+ caml_raise_out_of_memory();
+}
+
+static void extern_invalid_argument(char *msg)
+{
+ extern_replay_trail();
+ free_extern_output();
+ caml_invalid_argument(msg);
}
/* Write characters, integers, and blocks in the output buffer */
#define Write(c) \
- if (extern_ptr >= extern_limit) resize_extern_block(1); \
+ if (extern_ptr >= extern_limit) grow_extern_output(1); \
*extern_ptr++ = (c)
-static void writeblock(char *data, long int len)
+static void writeblock(char *data, intnat len)
{
- if (extern_ptr + len > extern_limit) resize_extern_block(len);
+ if (extern_ptr + len > extern_limit) grow_extern_output(len);
memmove(extern_ptr, data, len);
extern_ptr += len;
}
caml_serialize_block_float_8((data), (ndoubles))
#endif
-static void writecode8(int code, long int val)
+static void writecode8(int code, intnat val)
{
- if (extern_ptr + 2 > extern_limit) resize_extern_block(2);
+ if (extern_ptr + 2 > extern_limit) grow_extern_output(2);
extern_ptr[0] = code;
extern_ptr[1] = val;
extern_ptr += 2;
}
-static void writecode16(int code, long int val)
+static void writecode16(int code, intnat val)
{
- if (extern_ptr + 3 > extern_limit) resize_extern_block(3);
+ if (extern_ptr + 3 > extern_limit) grow_extern_output(3);
extern_ptr[0] = code;
extern_ptr[1] = val >> 8;
extern_ptr[2] = val;
extern_ptr += 3;
}
-static void write32(long int val)
+static void write32(intnat val)
{
- if (extern_ptr + 4 > extern_limit) resize_extern_block(4);
+ if (extern_ptr + 4 > extern_limit) grow_extern_output(4);
extern_ptr[0] = val >> 24;
extern_ptr[1] = val >> 16;
extern_ptr[2] = val >> 8;
extern_ptr += 4;
}
-static void writecode32(int code, long int val)
+static void writecode32(int code, intnat val)
{
- if (extern_ptr + 5 > extern_limit) resize_extern_block(5);
+ if (extern_ptr + 5 > extern_limit) grow_extern_output(5);
extern_ptr[0] = code;
extern_ptr[1] = val >> 24;
extern_ptr[2] = val >> 16;
}
#ifdef ARCH_SIXTYFOUR
-static void writecode64(int code, long val)
+static void writecode64(int code, intnat val)
{
int i;
- if (extern_ptr + 9 > extern_limit) resize_extern_block(9);
+ if (extern_ptr + 9 > extern_limit) grow_extern_output(9);
*extern_ptr ++ = code;
for (i = 64 - 8; i >= 0; i -= 8) *extern_ptr++ = val >> i;
}
/* Marshal the given value in the output buffer */
-static unsigned long size_32; /* Size in words of 32-bit block for struct. */
-static unsigned long size_64; /* Size in words of 64-bit block for struct. */
-
-static int extern_ignore_sharing; /* Flag to ignore sharing */
-static int extern_closures; /* Flag to allow externing code pointers */
-
-static void extern_invalid_argument(char *msg)
-{
- if (extern_block_malloced) caml_stat_free(extern_block);
- initial_ofs += obj_counter;
- free_extern_table();
- caml_invalid_argument(msg);
-}
-
static void extern_rec(value v)
{
tailcall:
if (Is_long(v)) {
- long n = Long_val(v);
+ intnat n = Long_val(v);
if (n >= 0 && n < 0x40) {
Write(PREFIX_SMALL_INT + n);
} else if (n >= -(1 << 7) && n < (1 << 7)) {
header_t hd = Hd_val(v);
tag_t tag = Tag_hd(hd);
mlsize_t sz = Wosize_hd(hd);
- asize_t h;
if (tag == Forward_tag) {
value f = Forward_val (v);
return;
}
/* Check if already seen */
- if (! extern_ignore_sharing && tag != Infix_tag) {
- if (2 * obj_counter >= extern_table_size) resize_extern_table();
- h = Hash(v);
- while (extern_table[h].ofs >= initial_ofs) {
- if (extern_table[h].obj == v) {
- byteoffset_t d = obj_counter - (extern_table[h].ofs - initial_ofs);
- if (d < 0x100) {
- writecode8(CODE_SHARED8, d);
- } else if (d < 0x10000) {
- writecode16(CODE_SHARED16, d);
- } else {
- writecode32(CODE_SHARED32, d);
- }
- return;
- }
- h = (h + 1) & extern_table_mask;
+ if (Color_hd(hd) == Caml_blue) {
+ uintnat d = obj_counter - (uintnat) Field(v, 0);
+ if (d < 0x100) {
+ writecode8(CODE_SHARED8, d);
+ } else if (d < 0x10000) {
+ writecode16(CODE_SHARED16, d);
+ } else {
+ writecode32(CODE_SHARED32, d);
}
- /* Not seen yet. Record the object */
- extern_table[h].ofs = initial_ofs + obj_counter;
- extern_table[h].obj = v;
- obj_counter++;
+ return;
}
+
/* Output the contents of the object */
switch(tag) {
case String_tag: {
writeblock(String_val(v), len);
size_32 += 1 + (len + 4) / 4;
size_64 += 1 + (len + 8) / 8;
+ extern_record_location(v);
break;
}
case Double_tag: {
writeblock_float8((double *) v, 1);
size_32 += 1 + 2;
size_64 += 1 + 1;
+ extern_record_location(v);
break;
}
case Double_array_tag: {
writeblock_float8((double *) v, nfloats);
size_32 += 1 + nfloats * 2;
size_64 += 1 + nfloats;
+ extern_record_location(v);
break;
}
case Abstract_tag:
writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd));
extern_rec(v - Infix_offset_hd(hd));
break;
- /* Use default case for objects
- case Object_tag:
- extern_invalid_argument("output_value: object value");
- break;
- */
case Custom_tag: {
- unsigned long sz_32, sz_64;
+ uintnat sz_32, sz_64;
char * ident = Custom_ops_val(v)->identifier;
- void (*serialize)(value v, unsigned long * wsize_32,
- unsigned long * wsize_64)
+ void (*serialize)(value v, uintnat * wsize_32,
+ uintnat * wsize_64)
= Custom_ops_val(v)->serialize;
if (serialize == NULL)
extern_invalid_argument("output_value: abstract value (Custom)");
Custom_ops_val(v)->serialize(v, &sz_32, &sz_64);
size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */
size_64 += 2 + ((sz_64 + 7) >> 3);
+ extern_record_location(v);
break;
}
default: {
+ value field0;
mlsize_t i;
if (tag < 16 && sz < 8) {
Write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
}
size_32 += 1 + sz;
size_64 += 1 + sz;
- for (i = 0; i < sz - 1; i++) extern_rec(Field(v, i));
- v = Field(v, i);
- goto tailcall;
+ field0 = Field(v, 0);
+ extern_record_location(v);
+ if (sz == 1) {
+ v = field0;
+ } else {
+ extern_rec(field0);
+ for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i));
+ v = Field(v, i);
}
+ goto tailcall;
+ }
}
- return;
}
- if ((char *) v >= caml_code_area_start && (char *) v < caml_code_area_end) {
+ else if ((char *) v >= caml_code_area_start &&
+ (char *) v < caml_code_area_end) {
if (!extern_closures)
extern_invalid_argument("output_value: functional value");
writecode32(CODE_CODEPOINTER, (char *) v - caml_code_area_start);
writeblock((char *) caml_code_checksum(), 16);
- return;
+ } else {
+ extern_invalid_argument("output_value: abstract value (outside heap)");
}
- extern_invalid_argument("output_value: abstract value (outside heap)");
}
enum { NO_SHARING = 1, CLOSURES = 2 };
static int extern_flags[] = { NO_SHARING, CLOSURES };
-static long extern_value(value v, value flags)
+static intnat extern_value(value v, value flags)
{
- long res_len;
+ intnat res_len;
int fl;
/* Parse flag list */
fl = caml_convert_flag_list(flags, extern_flags);
extern_ignore_sharing = fl & NO_SHARING;
extern_closures = fl & CLOSURES;
- /* Allocate hashtable of objects already seen, if needed */
- extern_table_size = INITIAL_EXTERN_TABLE_SIZE;
- extern_table_mask = extern_table_size - 1;
- extern_hash_shift = 8 * sizeof(value) - INITIAL_EXTERN_TABLE_SIZE_LOG2;
- if (extern_table == NULL) {
- alloc_extern_table();
- initial_ofs = 1;
- }
+ /* Initializations */
+ init_extern_trail();
obj_counter = 0;
size_32 = 0;
size_64 = 0;
extern_ptr += 4*4;
/* Marshal the object */
extern_rec(v);
- /* Update initial offset for next call to extern_value(),
- if we decide to keep the table of shared objects. */
- initial_ofs += obj_counter;
- /* Free the table of shared objects (if needed) */
- free_extern_table();
+ /* Record end of output */
+ extern_output_block->end = extern_ptr;
+ /* Undo the modifications done on externed blocks */
+ extern_replay_trail();
/* Write the sizes */
- res_len = extern_ptr - extern_block;
+ res_len = extern_output_length();
#ifdef ARCH_SIXTYFOUR
if (res_len >= (1L << 32) ||
size_32 >= (1L << 32) || size_64 >= (1L << 32)) {
/* The object is so big its size cannot be written in the header.
Besides, some of the array lengths or string lengths or shared offsets
it contains may have overflowed the 32 bits used to write them. */
+ free_extern_output();
caml_failwith("output_value: object too big");
}
#endif
- extern_ptr = extern_block + 4;
+ if (extern_userprovided_output != NULL)
+ extern_ptr = extern_userprovided_output + 4;
+ else {
+ extern_ptr = extern_output_first->data + 4;
+ extern_limit = extern_output_first->data + SIZE_EXTERN_OUTPUT_BLOCK;
+ }
write32(res_len - 5*4);
write32(obj_counter);
write32(size_32);
write32(size_64);
- /* Result is res_len bytes starting at extern_block */
return res_len;
}
void caml_output_val(struct channel *chan, value v, value flags)
{
- long len;
- char * block;
+ intnat len;
+ struct output_block * blk, * nextblk;
if (! caml_channel_binary_mode(chan))
caml_failwith("output_value: not a binary channel");
- alloc_extern_block();
+ init_extern_output();
len = extern_value(v, flags);
/* During [caml_really_putblock], concurrent [caml_output_val] operations
can take place (via signal handlers or context switching in systhreads),
- and [extern_block] may change. So, save the pointer in a local variable. */
- block = extern_block;
- caml_really_putblock(chan, extern_block, len);
- caml_stat_free(block);
+ and [extern_output_first] may change. So, save it in a local variable. */
+ blk = extern_output_first;
+ while (blk != NULL) {
+ caml_really_putblock(chan, blk->data, blk->end - blk->data);
+ nextblk = blk->next;
+ free(blk);
+ blk = nextblk;
+ }
}
CAMLprim value caml_output_value(value vchan, value v, value flags)
CAMLprim value caml_output_value_to_string(value v, value flags)
{
- long len;
+ intnat len, ofs;
value res;
- alloc_extern_block();
+ struct output_block * blk;
+
+ init_extern_output();
len = extern_value(v, flags);
res = caml_alloc_string(len);
- memmove(String_val(res), extern_block, len);
- caml_stat_free(extern_block);
+ for (ofs = 0, blk = extern_output_first; blk != NULL; blk = blk->next) {
+ int n = blk->end - blk->data;
+ memmove(&Byte(res, ofs), blk->data, n);
+ ofs += n;
+ }
+ free_extern_output();
return res;
}
CAMLprim value caml_output_value_to_buffer(value buf, value ofs, value len,
value v, value flags)
{
- long len_res;
- extern_block = &Byte(buf, Long_val(ofs));
- extern_limit = extern_block + Long_val(len);
- extern_ptr = extern_block;
- extern_block_malloced = 0;
+ intnat len_res;
+ extern_userprovided_output = &Byte(buf, Long_val(ofs));
+ extern_ptr = extern_userprovided_output;
+ extern_limit = extern_userprovided_output + Long_val(len);
len_res = extern_value(v, flags);
return Val_long(len_res);
}
CAMLexport void caml_output_value_to_malloc(value v, value flags,
/*out*/ char ** buf,
- /*out*/ long * len)
+ /*out*/ intnat * len)
{
- long len_res;
- alloc_extern_block();
+ intnat len_res;
+ char * res;
+ struct output_block * blk;
+
+ init_extern_output();
len_res = extern_value(v, flags);
- *buf = extern_block;
+ res = malloc(len_res);
+ if (res == NULL) extern_out_of_memory();
+ *buf = res;
*len = len_res;
+ for (blk = extern_output_first; blk != NULL; blk = blk->next) {
+ int n = blk->end - blk->data;
+ memmove(res, blk->data, n);
+ res += n;
+ }
+ free_extern_output();
}
-CAMLexport long caml_output_value_to_block(value v, value flags,
- char * buf, long len)
+CAMLexport intnat caml_output_value_to_block(value v, value flags,
+ char * buf, intnat len)
{
- long len_res;
- extern_block = buf;
- extern_limit = extern_block + len;
- extern_ptr = extern_block;
- extern_block_malloced = 0;
+ intnat len_res;
+ extern_userprovided_output = buf;
+ extern_ptr = extern_userprovided_output;
+ extern_limit = extern_userprovided_output + len;
len_res = extern_value(v, flags);
return len_res;
}
CAMLexport void caml_serialize_int_1(int i)
{
- if (extern_ptr + 1 > extern_limit) resize_extern_block(1);
+ if (extern_ptr + 1 > extern_limit) grow_extern_output(1);
extern_ptr[0] = i;
extern_ptr += 1;
}
CAMLexport void caml_serialize_int_2(int i)
{
- if (extern_ptr + 2 > extern_limit) resize_extern_block(2);
+ if (extern_ptr + 2 > extern_limit) grow_extern_output(2);
extern_ptr[0] = i >> 8;
extern_ptr[1] = i;
extern_ptr += 2;
CAMLexport void caml_serialize_int_4(int32 i)
{
- if (extern_ptr + 4 > extern_limit) resize_extern_block(4);
+ if (extern_ptr + 4 > extern_limit) grow_extern_output(4);
extern_ptr[0] = i >> 24;
extern_ptr[1] = i >> 16;
extern_ptr[2] = i >> 8;
caml_serialize_block_8(&f, 1);
}
-CAMLexport void caml_serialize_block_1(void * data, long len)
+CAMLexport void caml_serialize_block_1(void * data, intnat len)
{
- if (extern_ptr + len > extern_limit) resize_extern_block(len);
+ if (extern_ptr + len > extern_limit) grow_extern_output(len);
memmove(extern_ptr, data, len);
extern_ptr += len;
}
-CAMLexport void caml_serialize_block_2(void * data, long len)
+CAMLexport void caml_serialize_block_2(void * data, intnat len)
{
- if (extern_ptr + 2 * len > extern_limit) resize_extern_block(2 * len);
+ if (extern_ptr + 2 * len > extern_limit) grow_extern_output(2 * len);
#ifndef ARCH_BIG_ENDIAN
{
unsigned char * p;
#endif
}
-CAMLexport void caml_serialize_block_4(void * data, long len)
+CAMLexport void caml_serialize_block_4(void * data, intnat len)
{
- if (extern_ptr + 4 * len > extern_limit) resize_extern_block(4 * len);
+ if (extern_ptr + 4 * len > extern_limit) grow_extern_output(4 * len);
#ifndef ARCH_BIG_ENDIAN
{
unsigned char * p;
#endif
}
-CAMLexport void caml_serialize_block_8(void * data, long len)
+CAMLexport void caml_serialize_block_8(void * data, intnat len)
{
- if (extern_ptr + 8 * len > extern_limit) resize_extern_block(8 * len);
+ if (extern_ptr + 8 * len > extern_limit) grow_extern_output(8 * len);
#ifndef ARCH_BIG_ENDIAN
{
unsigned char * p;
#endif
}
-CAMLexport void caml_serialize_block_float_8(void * data, long len)
+CAMLexport void caml_serialize_block_float_8(void * data, intnat len)
{
- if (extern_ptr + 8 * len > extern_limit) resize_extern_block(8 * len);
+ if (extern_ptr + 8 * len > extern_limit) grow_extern_output(8 * len);
#if ARCH_FLOAT_ENDIANNESS == 0x01234567
memmove(extern_ptr, data, len * 8);
extern_ptr += len * 8;
/* */
/***********************************************************************/
-/* $Id: fail.c,v 1.29 2004/05/17 17:09:59 doligez Exp $ */
+/* $Id: fail.c,v 1.30 2005/10/18 14:03:34 xleroy Exp $ */
/* Raising exceptions from C. */
CAMLexport void caml_raise(value v)
{
-#ifdef DEBUG
- extern int volatile caml_async_signal_mode; /* from signals.c */
- Assert(! caml_async_signal_mode);
-#endif
Unlock_exn();
caml_exn_bucket = v;
if (caml_external_raise == NULL) caml_fatal_uncaught_exception(v);
/* */
/***********************************************************************/
-/* $Id: finalise.c,v 1.15.2.2 2005/03/09 15:49:09 doligez Exp $ */
+/* $Id: finalise.c,v 1.19 2005/09/22 14:21:50 xleroy Exp $ */
/* Handling of finalised values. */
};
static struct final *final_table = NULL;
-static unsigned long old = 0, young = 0, size = 0;
+static uintnat old = 0, young = 0, size = 0;
/* [0..old) : finalisable set
[old..young) : recent set
[young..size) : free space
*/
void caml_final_update (void)
{
- unsigned long i, j, k;
- unsigned long todo_count = 0;
+ uintnat i, j, k;
+ uintnat todo_count = 0;
Assert (young == old);
for (i = 0; i < old; i++){
*/
void caml_final_do_strong_roots (scanning_action f)
{
- unsigned long i;
+ uintnat i;
struct to_do *todo;
Assert (old == young);
*/
void caml_final_do_weak_roots (scanning_action f)
{
- unsigned long i;
+ uintnat i;
Assert (old == young);
for (i = 0; i < old; i++) Call_action (f, final_table[i].val);
*/
void caml_final_do_young_roots (scanning_action f)
{
- unsigned long i;
+ uintnat i;
Assert (old <= young);
for (i = old; i < young; i++){
if (young >= size){
if (final_table == NULL){
- unsigned long new_size = 30;
+ uintnat new_size = 30;
final_table = caml_stat_alloc (new_size * sizeof (struct final));
Assert (old == 0);
Assert (young == 0);
size = new_size;
}else{
- unsigned long new_size = size * 2;
+ uintnat new_size = size * 2;
final_table = caml_stat_resize (final_table,
new_size * sizeof (struct final));
size = new_size;
/* */
/***********************************************************************/
-/* $Id: floats.c,v 1.46 2004/01/09 15:33:31 xleroy Exp $ */
+/* $Id: floats.c,v 1.49 2005/10/12 14:50:03 xleroy Exp $ */
/* The interface of this file is in "mlvalues.h" and "alloc.h" */
return res;
}
+/*CAMLprim*/ value caml_float_of_substring(value vs, value idx, value l)
+{
+ char parse_buffer[64];
+ char * buf, * src, * dst, * end;
+ mlsize_t len, lenvs;
+ double d;
+ intnat flen = Long_val(l);
+ intnat fidx = Long_val(idx);
+
+ lenvs = caml_string_length(vs);
+ len =
+ fidx >= 0 && fidx < lenvs && flen > 0 && flen <= lenvs - fidx
+ ? flen : 0;
+ buf = len < sizeof(parse_buffer) ? parse_buffer : caml_stat_alloc(len + 1);
+ src = String_val(vs) + fidx;
+ dst = buf;
+ while (len--) {
+ char c = *src++;
+ if (c != '_') *dst++ = c;
+ }
+ *dst = 0;
+ if (dst == buf) goto error;
+ d = strtod((const char *) buf, &end);
+ if (end != dst) goto error;
+ if (buf != parse_buffer) caml_stat_free(buf);
+ return caml_copy_double(d);
+ error:
+ if (buf != parse_buffer) caml_stat_free(buf);
+ caml_failwith("float_of_string");
+}
+
CAMLprim value caml_float_of_string(value vs)
{
char parse_buffer[64];
if (c != '_') *dst++ = c;
}
*dst = 0;
- if (dst == buf) caml_failwith("float_of_string");
+ if (dst == buf) goto error;
d = strtod((const char *) buf, &end);
+ if (end != dst) goto error;
if (buf != parse_buffer) caml_stat_free(buf);
- if (end != dst) caml_failwith("float_of_string");
return caml_copy_double(d);
+ error:
+ if (buf != parse_buffer) caml_stat_free(buf);
+ caml_failwith("float_of_string");
}
CAMLprim value caml_int_of_float(value f)
{
- return Val_long((long) Double_val(f));
+ return Val_long((intnat) Double_val(f));
}
CAMLprim value caml_float_of_int(value n)
/* */
/***********************************************************************/
-/* $Id: freelist.c,v 1.16 2004/01/02 19:23:21 doligez Exp $ */
+/* $Id: freelist.c,v 1.17 2005/09/22 14:21:50 xleroy Exp $ */
#include "config.h"
#include "freelist.h"
{
char *cur, *prev;
int prev_found = 0, merge_found = 0;
- unsigned long size_found = 0;
+ uintnat size_found = 0;
prev = Fl_head;
cur = Next (prev);
/* */
/***********************************************************************/
-/* $Id: gc.h,v 1.14 2003/12/15 18:10:46 doligez Exp $ */
+/* $Id: gc.h,v 1.15 2004/07/19 13:20:06 xleroy Exp $ */
#ifndef CAML_GC_H
#define CAML_GC_H
#define Is_blue_val(val) (Color_val(val) == Caml_blue)
#define Is_black_val(val) (Color_val(val) == Caml_black)
+/* For extern.c */
+#define Colornum_hd(hd) ((color_t) (((hd) >> 8) & 3))
+#define Coloredhd_hd(hd,colnum) (((hd) & ~Caml_black) | ((colnum) << 8))
#endif /* CAML_GC_H */
/* */
/***********************************************************************/
-/* $Id: gc_ctrl.c,v 1.47.4.2 2005/03/09 15:49:09 doligez Exp $ */
+/* $Id: gc_ctrl.c,v 1.50 2005/09/22 14:21:50 xleroy Exp $ */
#include "alloc.h"
#include "compact.h"
#include "stacks.h"
#ifndef NATIVE_CODE
-extern unsigned long caml_max_stack_size; /* defined in stacks.c */
+extern uintnat caml_max_stack_size; /* defined in stacks.c */
#endif
double caml_stat_minor_words = 0.0,
caml_stat_promoted_words = 0.0,
caml_stat_major_words = 0.0;
-long caml_stat_minor_collections = 0,
- caml_stat_major_collections = 0,
- caml_stat_heap_size = 0, /* bytes */
- caml_stat_top_heap_size = 0, /* bytes */
- caml_stat_compactions = 0,
- caml_stat_heap_chunks = 0;
+intnat caml_stat_minor_collections = 0,
+ caml_stat_major_collections = 0,
+ caml_stat_heap_size = 0, /* bytes */
+ caml_stat_top_heap_size = 0, /* bytes */
+ caml_stat_compactions = 0,
+ caml_stat_heap_chunks = 0;
extern asize_t caml_major_heap_increment; /* bytes; see major_gc.c */
-extern unsigned long caml_percent_free; /* see major_gc.c */
-extern unsigned long caml_percent_max; /* see compact.c */
+extern uintnat caml_percent_free; /* see major_gc.c */
+extern uintnat caml_percent_max; /* see compact.c */
#define Next(hp) ((hp) + Bhsize_hp (hp))
static void check_block (char *hp)
{
- mlsize_t nfields = Wosize_hp (hp);
mlsize_t i;
value v = Val_hp (hp);
value f;
- mlsize_t lastbyte;
check_head (v);
switch (Tag_hp (hp)){
case Abstract_tag: break;
case String_tag:
- /* not true when [caml_check_urgent_gc] is called by [caml_alloc]
- or caml_alloc_string:
- lastbyte = Bosize_val (v) - 1;
- i = Byte (v, lastbyte);
- Assert (i >= 0);
- Assert (i < sizeof (value));
- Assert (Byte (v, lastbyte - i) == 0);
- */
break;
case Double_tag:
Assert (Wosize_val (v) == Double_wosize);
static value heap_stats (int returnstats)
{
CAMLparam0 ();
- long live_words = 0, live_blocks = 0,
- free_words = 0, free_blocks = 0, largest_free = 0,
- fragments = 0, heap_chunks = 0;
+ intnat live_words = 0, live_blocks = 0,
+ free_words = 0, free_blocks = 0, largest_free = 0,
+ fragments = 0, heap_chunks = 0;
char *chunk = caml_heap_start, *chunk_end;
char *cur_hp, *prev_hp;
header_t cur_hd;
+ (double) Wsize_bsize (caml_young_end - caml_young_ptr);
double prowords = caml_stat_promoted_words;
double majwords = caml_stat_major_words + (double) caml_allocated_words;
- long mincoll = caml_stat_minor_collections;
- long majcoll = caml_stat_major_collections;
- long heap_words = Wsize_bsize (caml_stat_heap_size);
- long cpct = caml_stat_compactions;
- long top_heap_words = Wsize_bsize (caml_stat_top_heap_size);
+ intnat mincoll = caml_stat_minor_collections;
+ intnat majcoll = caml_stat_major_collections;
+ intnat heap_words = Wsize_bsize (caml_stat_heap_size);
+ intnat cpct = caml_stat_compactions;
+ intnat top_heap_words = Wsize_bsize (caml_stat_top_heap_size);
res = caml_alloc_tuple (15);
Store_field (res, 0, caml_copy_double (minwords));
+ (double) Wsize_bsize (caml_young_end - caml_young_ptr);
double prowords = caml_stat_promoted_words;
double majwords = caml_stat_major_words + (double) caml_allocated_words;
- long mincoll = caml_stat_minor_collections;
- long majcoll = caml_stat_major_collections;
- long heap_words = caml_stat_heap_size / sizeof (value);
- long top_heap_words = caml_stat_top_heap_size / sizeof (value);
- long cpct = caml_stat_compactions;
- long heap_chunks = caml_stat_heap_chunks;
+ intnat mincoll = caml_stat_minor_collections;
+ intnat majcoll = caml_stat_major_collections;
+ intnat heap_words = caml_stat_heap_size / sizeof (value);
+ intnat top_heap_words = caml_stat_top_heap_size / sizeof (value);
+ intnat cpct = caml_stat_compactions;
+ intnat heap_chunks = caml_stat_heap_chunks;
res = caml_alloc_tuple (15);
Store_field (res, 0, caml_copy_double (minwords));
#define Max(x,y) ((x) < (y) ? (y) : (x))
-static unsigned long norm_pfree (long unsigned int p)
+static uintnat norm_pfree (uintnat p)
{
return Max (p, 1);
}
-static unsigned long norm_pmax (long unsigned int p)
+static uintnat norm_pmax (uintnat p)
{
return p;
}
-static long norm_heapincr (long unsigned int i)
+static intnat norm_heapincr (uintnat i)
{
#define Psv (Wsize_bsize (Page_size))
i = ((i + Psv - 1) / Psv) * Psv;
return i;
}
-static long norm_minsize (long int s)
+static intnat norm_minsize (intnat s)
{
if (s < Minor_heap_min) s = Minor_heap_min;
if (s > Minor_heap_max) s = Minor_heap_max;
CAMLprim value caml_gc_set(value v)
{
- unsigned long newpf, newpm;
+ uintnat newpf, newpm;
asize_t newheapincr;
asize_t newminsize;
fp = 100.0 * caml_fl_cur_size
/ (Wsize_bsize (caml_stat_heap_size) - caml_fl_cur_size);
if (fp > 1000000.0) fp = 1000000.0;
- caml_gc_message (0x200, "Estimated overhead (lower bound) = %lu%%\n",
- (unsigned long) fp);
+ caml_gc_message (0x200, "Estimated overhead (lower bound) = %"
+ ARCH_INTNAT_PRINTF_FORMAT "u%%\n",
+ (uintnat) fp);
if (fp >= caml_percent_max && caml_stat_heap_chunks > 1){
caml_gc_message (0x200, "Automatic compaction triggered.\n", 0);
caml_compact_heap ();
return Val_unit;
}
-void caml_init_gc (unsigned long minor_size, unsigned long major_size,
- unsigned long major_incr, unsigned long percent_fr,
- unsigned long percent_m)
+void caml_init_gc (uintnat minor_size, uintnat major_size,
+ uintnat major_incr, uintnat percent_fr,
+ uintnat percent_m)
{
- unsigned long major_heap_size = Bsize_wsize (norm_heapincr (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);
/* */
/***********************************************************************/
-/* $Id: gc_ctrl.h,v 1.15 2004/01/02 19:23:22 doligez Exp $ */
+/* $Id: gc_ctrl.h,v 1.16 2005/09/22 14:21:50 xleroy Exp $ */
#ifndef CAML_GC_CTRL_H
#define CAML_GC_CTRL_H
caml_stat_promoted_words,
caml_stat_major_words;
-extern long
+extern intnat
caml_stat_minor_collections,
caml_stat_major_collections,
caml_stat_heap_size,
caml_stat_compactions,
caml_stat_heap_chunks;
-void caml_init_gc (unsigned long, unsigned long, unsigned long,
- unsigned long, unsigned long);
+void caml_init_gc (uintnat, uintnat, uintnat,
+ uintnat, uintnat);
#ifdef DEBUG
/* */
/***********************************************************************/
-/* $Id: globroots.c,v 1.7 2004/01/05 20:25:58 doligez Exp $ */
+/* $Id: globroots.c,v 1.8 2005/09/22 14:21:50 xleroy Exp $ */
/* Registration of global memory roots */
struct global_root * e, * f;
int i, new_level;
- Assert (((long) r & 3) == 0); /* compact.c demands this (for now) */
+ Assert (((intnat) r & 3) == 0); /* compact.c demands this (for now) */
/* Init "cursor" to list head */
e = (struct global_root *) &caml_global_roots;
/* */
/***********************************************************************/
-/* $Id: hash.c,v 1.22 2004/01/02 19:23:22 doligez Exp $ */
+/* $Id: hash.c,v 1.23 2005/09/22 14:21:50 xleroy Exp $ */
/* The generic hashing primitive */
#include "custom.h"
#include "memory.h"
-static unsigned long hash_accu;
-static long hash_univ_limit, hash_univ_count;
+static uintnat hash_accu;
+static intnat hash_univ_limit, hash_univ_count;
static void hash_aux(value obj);
/* Otherwise, obj is a pointer outside the heap, to an object with
a priori unknown structure. Use its physical address as hash key. */
- Combine((long) obj);
+ Combine((intnat) obj);
}
/* Hashing variant tags */
/* */
/***********************************************************************/
-/* $Id: instrtrace.c,v 1.19 2004/04/23 23:16:15 basile Exp $ */
+/* $Id: instrtrace.c,v 1.21 2005/10/18 14:04:13 xleroy Exp $ */
/* Trace the instructions executed */
extern code_t caml_start_code;
-long caml_icount = 0;
+intnat caml_icount = 0;
void caml_stop_here () {}
fflush (stdout);
}
-
-
-
-char *
-caml_instr_string (code_t pc)
+char * caml_instr_string (code_t pc)
{
- static char buf[96];
- char nambuf[36];
+ static char buf[256];
+ char nambuf[128];
int instr = *pc;
- char *nam = 0;
- memset (buf, 0, sizeof (buf));
-#define bufprintf(Fmt,...) snprintf(buf,sizeof(buf)-1,Fmt,##__VA_ARGS__)
+ char *nam;
+
nam = (instr < 0 || instr > STOP)
- ? (snprintf (nambuf, sizeof (nambuf), "???%d", instr), nambuf)
+ ? (sprintf (nambuf, "???%d", instr), nambuf)
: names_of_instructions[instr];
pc++;
switch (instr) {
case OFFSETREF:
case OFFSETCLOSURE:
case PUSHOFFSETCLOSURE:
- bufprintf ("%s %d", nam, pc[0]);
+ sprintf(buf, "%s %d", nam, pc[0]);
break;
/* Instructions with two operands */
case APPTERM:
case BGEINT:
case BULTINT:
case BUGEINT:
- bufprintf ("%s %d, %d", nam, pc[0], pc[1]);
+ sprintf(buf, "%s %d, %d", nam, pc[0], pc[1]);
break;
case SWITCH:
- bufprintf ("SWITCH sz%#lx=%ld::ntag%ld nint%ld",
- (long) pc[0], (long) pc[0], (unsigned long) pc[0] >> 16,
- (unsigned long) pc[0] & 0xffff);
+ sprintf(buf, "SWITCH sz%#lx=%ld::ntag%ld nint%ld",
+ (long) pc[0], (long) pc[0], (unsigned long) pc[0] >> 16,
+ (unsigned long) pc[0] & 0xffff);
break;
/* Instructions with a C primitive as operand */
case C_CALLN:
- bufprintf ("%s %d,", nam, pc[0]);
+ sprintf(buf, "%s %d,", nam, pc[0]);
pc++;
/* fallthrough */
case C_CALL1:
case C_CALL4:
case C_CALL5:
if (pc[0] < 0 || pc[0] >= caml_prim_name_table.size)
- bufprintf ("%s unknown primitive %d", nam, pc[0]);
+ sprintf(buf, "%s unknown primitive %d", nam, pc[0]);
else
- bufprintf ("%s %s", nam, (char *) caml_prim_name_table.contents[pc[0]]);
+ sprintf(buf, "%s %s", nam, (char *) caml_prim_name_table.contents[pc[0]]);
break;
default:
- bufprintf ("%s", nam);
+ sprintf(buf, "%s", nam);
break;
};
return buf;
&& (code_t) v < (code_t) ((char *) prog + proglen))
fprintf (f, "=code@%d", (code_t) v - prog);
else if (Is_long (v))
- fprintf (f, "=long%ld", Long_val (v));
+ fprintf (f, "=long%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val (v));
else if ((void*)v >= (void*)caml_stack_low
&& (void*)v < (void*)caml_stack_high)
- fprintf (f, "=stack_%d", (long*)caml_stack_high - (long*)v);
+ fprintf (f, "=stack_%d", (intnat*)caml_stack_high - (intnat*)v);
else if (Is_block (v)) {
int s = Wosize_val (v);
int tg = Tag_val (v);
}
}
-// added by Basile
void
caml_trace_accu_sp_file (value accu, value * sp, code_t prog, int proglen,
FILE * f)
value *p;
fprintf (f, "accu=");
caml_trace_value_file (accu, prog, proglen, f);
- fprintf (f, "\n sp=%#lx @%d:", (long) sp, caml_stack_high - sp);
+ fprintf (f, "\n sp=%#" ARCH_INTNAT_PRINTF_FORMAT "x @%d:",
+ (intnat) sp, caml_stack_high - sp);
for (p = sp, i = 0; i < 12 + (1 << caml_trace_flag) && p < caml_stack_high;
p++, i++) {
fprintf (f, "\n[%d] ", caml_stack_high - p);
}
#endif /* DEBUG */
-/* eof $Id: instrtrace.c,v 1.19 2004/04/23 23:16:15 basile Exp $ */
/* */
/***********************************************************************/
-/* $Id: instrtrace.h,v 1.8 2004/04/22 09:48:04 basile Exp $ */
+/* $Id: instrtrace.h,v 1.9 2005/09/22 14:21:50 xleroy Exp $ */
/* Trace the instructions executed */
#include "misc.h"
extern int caml_trace_flag;
-extern long caml_icount;
+extern intnat caml_icount;
void caml_stop_here (void);
void caml_disasm_instr (code_t pc);
void caml_trace_value_file (value v, code_t prog, int proglen, FILE * f);
/* */
/***********************************************************************/
-/* $Id: int64_emul.h,v 1.3 2003/12/15 18:10:47 doligez Exp $ */
+/* $Id: int64_emul.h,v 1.5 2005/09/22 14:21:50 xleroy Exp $ */
/* Software emulation of 64-bit integer arithmetic, for C compilers
that do not support it. */
#include <math.h>
-#if ARCH_BIG_ENDIAN
+#ifdef ARCH_BIG_ENDIAN
#define I64_literal(hi,lo) { hi, lo }
#else
#define I64_literal(hi,lo) { lo, hi }
#define I64_to_int32(x) ((int32) (x).l)
-/* Note: we assume sizeof(long) = 4 here, which is true otherwise
+/* Note: we assume sizeof(intnat) = 4 here, which is true otherwise
autoconfiguration would have selected native 64-bit integers */
-#define I64_of_long I64_of_int32
-#define I64_to_long I64_to_int32
+#define I64_of_intnat I64_of_int32
+#define I64_to_intnat I64_to_int32
static double I64_to_double(int64 x)
{
/* */
/***********************************************************************/
-/* $Id: int64_native.h,v 1.4 2003/12/15 18:10:47 doligez Exp $ */
+/* $Id: int64_native.h,v 1.5 2005/09/22 14:21:50 xleroy Exp $ */
/* Wrapper macros around native 64-bit integer arithmetic,
so that it has the same interface as the software emulation
#define I64_lsl(x,y) ((x) << (y))
#define I64_asr(x,y) ((x) >> (y))
#define I64_lsr(x,y) ((uint64)(x) >> (y))
-#define I64_to_long(x) ((long) (x))
-#define I64_of_long(x) ((int64) (x))
+#define I64_to_intnat(x) ((intnat) (x))
+#define I64_of_intnat(x) ((intnat) (x))
#define I64_to_int32(x) ((int32) (x))
#define I64_of_int32(x) ((int64) (x))
#define I64_to_double(x) ((double)(x))
/* */
/***********************************************************************/
-/* $Id: intern.c,v 1.58.2.1 2004/11/03 19:47:20 doligez Exp $ */
+/* $Id: intern.c,v 1.60 2005/09/22 14:21:50 xleroy Exp $ */
/* Structured input, compact format */
/* Point to the heap block allocated as destination block.
Meaningful only if intern_extra_block is NULL. */
-#define Sign_extend_shift ((sizeof(long) - 1) * 8)
-#define Sign_extend(x) (((long)(x) << Sign_extend_shift) >> Sign_extend_shift)
+#define Sign_extend_shift ((sizeof(intnat) - 1) * 8)
+#define Sign_extend(x) (((intnat)(x) << Sign_extend_shift) >> Sign_extend_shift)
#define read8u() (*intern_src++)
#define read8s() Sign_extend(*intern_src++)
(intern_src[-2] << 8) + intern_src[-1])
#ifdef ARCH_SIXTYFOUR
-static long read64s(void)
+static intnat read64s(void)
{
- long res;
+ intnat res;
int i;
res = 0;
for (i = 0; i < 8; i++) res = (res << 8) + intern_src[i];
CAMLreturn (res);
}
-CAMLexport value caml_input_val_from_string(value str, long int ofs)
+CAMLexport value caml_input_val_from_string(value str, intnat ofs)
{
CAMLparam1 (str);
mlsize_t num_objects, size_32, size_64, whsize;
return obj;
}
-CAMLexport value caml_input_value_from_malloc(char * data, long ofs)
+CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs)
{
uint32 magic;
mlsize_t block_len;
return obj;
}
-CAMLexport value caml_input_value_from_block(char * data, long len)
+CAMLexport value caml_input_value_from_block(char * data, intnat len)
{
uint32 magic;
mlsize_t block_len;
return f;
}
-CAMLexport void caml_deserialize_block_1(void * data, long len)
+CAMLexport void caml_deserialize_block_1(void * data, intnat len)
{
memmove(data, intern_src, len);
intern_src += len;
}
-CAMLexport void caml_deserialize_block_2(void * data, long len)
+CAMLexport void caml_deserialize_block_2(void * data, intnat len)
{
#ifndef ARCH_BIG_ENDIAN
unsigned char * p, * q;
#endif
}
-CAMLexport void caml_deserialize_block_4(void * data, long len)
+CAMLexport void caml_deserialize_block_4(void * data, intnat len)
{
#ifndef ARCH_BIG_ENDIAN
unsigned char * p, * q;
#endif
}
-CAMLexport void caml_deserialize_block_8(void * data, long len)
+CAMLexport void caml_deserialize_block_8(void * data, intnat len)
{
#ifndef ARCH_BIG_ENDIAN
unsigned char * p, * q;
#endif
}
-CAMLexport void caml_deserialize_block_float_8(void * data, long len)
+CAMLexport void caml_deserialize_block_float_8(void * data, intnat len)
{
#if ARCH_FLOAT_ENDIANNESS == 0x01234567
memmove(data, intern_src, len * 8);
/* */
/***********************************************************************/
-/* $Id: interp.c,v 1.90 2004/06/12 10:40:52 xleroy Exp $ */
+/* $Id: interp.c,v 1.95 2005/10/25 18:34:07 doligez Exp $ */
/* The bytecode interpreter */
#include <stdio.h>
# ifdef DEBUG
# define Next goto next_instr
# else
-# ifdef __ia64__
-# define Next goto *(void *)(jumptbl_base + *((uint32 *) pc)++)
-# else
-# define Next goto *(void *)(jumptbl_base + *pc++)
-# endif
+# define Next goto *(void *)(jumptbl_base + *pc++)
# endif
#else
# define Instruct(name) case name
#define SP_REG asm("%edi")
#define ACCU_REG
#endif
-#if defined(PPC) || defined(_POWER) || defined(_IBMR2)
+#ifdef __ppc__
#define PC_REG asm("26")
#define SP_REG asm("27")
#define ACCU_REG asm("28")
/* Division and modulus madness */
#ifdef NONSTANDARD_DIV_MOD
-extern long caml_safe_div(long p, long q);
-extern long caml_safe_mod(long p, long q);
+extern intnat caml_safe_div(intnat p, intnat q);
+extern intnat caml_safe_mod(intnat p, intnat q);
#endif
#ifdef DEBUG
-static long caml_bcodcount;
+static intnat caml_bcodcount;
#endif
/* The interpreter itself */
#endif
#endif
value env;
- long extra_args;
+ intnat extra_args;
struct longjmp_buffer * initial_external_raise;
int initial_sp_offset;
/* volatile ensures that initial_local_roots and saved_pc
Instruct(SWITCH): {
uint32 sizes = *pc++;
if (Is_block(accu)) {
- long index = Tag_val(accu);
- Assert (index >= 0);
- Assert (index < (sizes >> 16));
+ intnat index = Tag_val(accu);
+ Assert ((uintnat) index < (sizes >> 16));
pc += pc[(sizes & 0xFFFF) + index];
} else {
- long index = Long_val(accu);
- Assert ((unsigned long) index < (sizes & 0xFFFF)) ;
+ intnat index = Long_val(accu);
+ Assert ((uintnat) index < (sizes & 0xFFFF)) ;
pc += pc[index];
}
Next;
/* Integer arithmetic */
Instruct(NEGINT):
- accu = (value)(2 - (long)accu); Next;
+ accu = (value)(2 - (intnat)accu); Next;
Instruct(ADDINT):
- accu = (value)((long) accu + (long) *sp++ - 1); Next;
+ accu = (value)((intnat) accu + (intnat) *sp++ - 1); Next;
Instruct(SUBINT):
- accu = (value)((long) accu - (long) *sp++ + 1); Next;
+ accu = (value)((intnat) accu - (intnat) *sp++ + 1); Next;
Instruct(MULINT):
accu = Val_long(Long_val(accu) * Long_val(*sp++)); Next;
Instruct(DIVINT): {
- long divisor = Long_val(*sp++);
+ intnat divisor = Long_val(*sp++);
if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); }
#ifdef NONSTANDARD_DIV_MOD
accu = Val_long(caml_safe_div(Long_val(accu), divisor));
Next;
}
Instruct(MODINT): {
- long divisor = Long_val(*sp++);
+ intnat divisor = Long_val(*sp++);
if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); }
#ifdef NONSTANDARD_DIV_MOD
accu = Val_long(caml_safe_mod(Long_val(accu), divisor));
Next;
}
Instruct(ANDINT):
- accu = (value)((long) accu & (long) *sp++); Next;
+ accu = (value)((intnat) accu & (intnat) *sp++); Next;
Instruct(ORINT):
- accu = (value)((long) accu | (long) *sp++); Next;
+ accu = (value)((intnat) accu | (intnat) *sp++); Next;
Instruct(XORINT):
- accu = (value)(((long) accu ^ (long) *sp++) | 1); Next;
+ accu = (value)(((intnat) accu ^ (intnat) *sp++) | 1); Next;
Instruct(LSLINT):
- accu = (value)((((long) accu - 1) << Long_val(*sp++)) + 1); Next;
+ accu = (value)((((intnat) accu - 1) << Long_val(*sp++)) + 1); Next;
Instruct(LSRINT):
- accu = (value)((((unsigned long) accu - 1) >> Long_val(*sp++)) | 1);
+ accu = (value)((((uintnat) accu - 1) >> Long_val(*sp++)) | 1);
Next;
Instruct(ASRINT):
- accu = (value)((((long) accu - 1) >> Long_val(*sp++)) | 1); Next;
+ accu = (value)((((intnat) accu - 1) >> Long_val(*sp++)) | 1); Next;
-#define Integer_comparison(sign,opname,tst) \
+#define Integer_comparison(typ,opname,tst) \
Instruct(opname): \
- accu = Val_int((sign long) accu tst (sign long) *sp++); Next;
-
- Integer_comparison(signed,EQ, ==)
- Integer_comparison(signed,NEQ, !=)
- Integer_comparison(signed,LTINT, <)
- Integer_comparison(signed,LEINT, <=)
- Integer_comparison(signed,GTINT, >)
- Integer_comparison(signed,GEINT, >=)
- Integer_comparison(unsigned,ULTINT, <)
- Integer_comparison(unsigned,UGEINT, >=)
-
-#define Integer_branch_comparison(sign,opname,tst,debug) \
+ accu = Val_int((typ) accu tst (typ) *sp++); Next;
+
+ Integer_comparison(intnat,EQ, ==)
+ Integer_comparison(intnat,NEQ, !=)
+ Integer_comparison(intnat,LTINT, <)
+ Integer_comparison(intnat,LEINT, <=)
+ Integer_comparison(intnat,GTINT, >)
+ Integer_comparison(intnat,GEINT, >=)
+ Integer_comparison(uintnat,ULTINT, <)
+ Integer_comparison(uintnat,UGEINT, >=)
+
+#define Integer_branch_comparison(typ,opname,tst,debug) \
Instruct(opname): \
- if ( *pc++ tst ((sign long)Long_val(accu))) { \
+ if ( *pc++ tst (typ) Long_val(accu)) { \
pc += *pc ; \
} else { \
pc++ ; \
} ; Next;
- Integer_branch_comparison(signed,BEQ, ==, "==")
- Integer_branch_comparison(signed,BNEQ, !=, "!=")
- Integer_branch_comparison(signed,BLTINT, <, "<")
- Integer_branch_comparison(signed,BLEINT, <=, "<=")
- Integer_branch_comparison(signed,BGTINT, >, ">")
- Integer_branch_comparison(signed,BGEINT, >=, ">=")
- Integer_branch_comparison(unsigned,BULTINT, <, "<")
- Integer_branch_comparison(unsigned,BUGEINT, >=, ">=")
+ Integer_branch_comparison(intnat,BEQ, ==, "==")
+ Integer_branch_comparison(intnat,BNEQ, !=, "!=")
+ Integer_branch_comparison(intnat,BLTINT, <, "<")
+ Integer_branch_comparison(intnat,BLEINT, <=, "<=")
+ Integer_branch_comparison(intnat,BGTINT, >, ">")
+ Integer_branch_comparison(intnat,BGEINT, >=, ">=")
+ Integer_branch_comparison(uintnat,BULTINT, <, "<")
+ Integer_branch_comparison(uintnat,BUGEINT, >=, ">=")
Instruct(OFFSETINT):
accu += *pc << 1;
#if _MSC_VER >= 1200
__assume(0);
#else
- caml_fatal_error_arg("Fatal error: bad opcode (%lx)\n",
- (char *)(long)(*(pc-1)));
+ caml_fatal_error_arg("Fatal error: bad opcode (%"
+ ARCH_INTNAT_PRINTF_FORMAT "x)\n",
+ (char *)(*(pc-1)));
#endif
}
}
Assert(prog);
Assert(prog_size>0);
}
-
-/* eof $Id: interp.c,v 1.90 2004/06/12 10:40:52 xleroy Exp $ */
/* */
/***********************************************************************/
-/* $Id: intext.h,v 1.30 2004/01/02 19:23:23 doligez Exp $ */
+/* $Id: intext.h,v 1.32 2005/09/22 14:21:50 xleroy Exp $ */
/* Structured input/output */
#define CODE_DOUBLE_ARRAY32_NATIVE CODE_DOUBLE_ARRAY32_LITTLE
#endif
-/* Initial sizes of data structures for extern */
+/* Size-ing data structures for extern. Chosen so that
+ sizeof(struct trail_block) and sizeof(struct output_block)
+ are slightly below 8Kb. */
-#ifndef INITIAL_EXTERN_BLOCK_SIZE
-#define INITIAL_EXTERN_BLOCK_SIZE 8192
-#endif
-
-#ifndef INITIAL_EXTERN_TABLE_SIZE_LOG2
-#define INITIAL_EXTERN_TABLE_SIZE_LOG2 11
-#endif
-
-#define INITIAL_EXTERN_TABLE_SIZE (1UL << INITIAL_EXTERN_TABLE_SIZE_LOG2)
-
-/* Maximal value of initial_ofs above which we should start again with
- initial_ofs = 1. Should be low enough to prevent rollover of initial_ofs
- next time we extern a structure. Since a structure contains at most
- 2^N / (2 * sizeof(value)) heap objects (N = 32 or 64 depending on target),
- any value below 2^N - (2^N / (2 * sizeof(value))) suffices.
- We just take 2^(N-1) for simplicity. */
-
-#define INITIAL_OFFSET_MAX (1UL << (8 * sizeof(value) - 1))
+#define ENTRIES_PER_TRAIL_BLOCK 1025
+#define SIZE_EXTERN_OUTPUT_BLOCK 8100
/* The entry points */
CAMLextern void caml_output_value_to_malloc(value v, value flags,
/*out*/ char ** buf,
- /*out*/ long * len);
+ /*out*/ intnat * len);
/* Output [v] with flags [flags] to a memory buffer allocated with
malloc. On return, [*buf] points to the buffer and [*len]
contains the number of bytes in buffer. */
-CAMLextern long caml_output_value_to_block(value v, value flags,
- char * data, long len);
+CAMLextern intnat caml_output_value_to_block(value v, value flags,
+ char * data, intnat len);
/* Output [v] with flags [flags] to a user-provided memory buffer.
[data] points to the start of this buffer, and [len] is its size
in bytes. Return the number of bytes actually written in buffer.
/* Read a structured value from the channel [chan]. */
/* </private> */
-CAMLextern value caml_input_val_from_string (value str, long ofs);
+CAMLextern value caml_input_val_from_string (value str, intnat ofs);
/* Read a structured value from the Caml string [str], starting
at offset [ofs]. */
-CAMLextern value caml_input_value_from_malloc(char * data, long ofs);
+CAMLextern value caml_input_value_from_malloc(char * data, intnat ofs);
/* Read a structured value from a malloced buffer. [data] points
to the beginning of the buffer, and [ofs] is the offset of the
beginning of the externed data in this buffer. The buffer is
deallocated with [free] on return, or if an exception is raised. */
-CAMLextern value caml_input_value_from_block(char * data, long len);
+CAMLextern value caml_input_value_from_block(char * data, intnat len);
/* Read a structured value from a user-provided buffer. [data] points
to the beginning of the externed data in this buffer,
and [len] is the length in bytes of valid data in this buffer.
CAMLextern void caml_serialize_int_8(int64 i);
CAMLextern void caml_serialize_float_4(float f);
CAMLextern void caml_serialize_float_8(double f);
-CAMLextern void caml_serialize_block_1(void * data, long len);
-CAMLextern void caml_serialize_block_2(void * data, long len);
-CAMLextern void caml_serialize_block_4(void * data, long len);
-CAMLextern void caml_serialize_block_8(void * data, long len);
-CAMLextern void caml_serialize_block_float_8(void * data, long len);
+CAMLextern void caml_serialize_block_1(void * data, intnat len);
+CAMLextern void caml_serialize_block_2(void * data, intnat len);
+CAMLextern void caml_serialize_block_4(void * data, intnat len);
+CAMLextern void caml_serialize_block_8(void * data, intnat len);
+CAMLextern void caml_serialize_block_float_8(void * data, intnat len);
CAMLextern int caml_deserialize_uint_1(void);
CAMLextern int caml_deserialize_sint_1(void);
CAMLextern int64 caml_deserialize_sint_8(void);
CAMLextern float caml_deserialize_float_4(void);
CAMLextern double caml_deserialize_float_8(void);
-CAMLextern void caml_deserialize_block_1(void * data, long len);
-CAMLextern void caml_deserialize_block_2(void * data, long len);
-CAMLextern void caml_deserialize_block_4(void * data, long len);
-CAMLextern void caml_deserialize_block_8(void * data, long len);
-CAMLextern void caml_deserialize_block_float_8(void * data, long len);
+CAMLextern void caml_deserialize_block_1(void * data, intnat len);
+CAMLextern void caml_deserialize_block_2(void * data, intnat len);
+CAMLextern void caml_deserialize_block_4(void * data, intnat len);
+CAMLextern void caml_deserialize_block_8(void * data, intnat len);
+CAMLextern void caml_deserialize_block_float_8(void * data, intnat len);
CAMLextern void caml_deserialize_error(char * msg);
/* <private> */
/* */
/***********************************************************************/
-/* $Id: ints.c,v 1.47 2004/01/02 19:23:23 doligez Exp $ */
+/* $Id: ints.c,v 1.48 2005/09/22 14:21:50 xleroy Exp $ */
#include <stdio.h>
#include <string.h>
return -1;
}
-static long parse_long(value s, int nbits)
+static intnat parse_intnat(value s, int nbits)
{
char * p;
- unsigned long res, threshold;
+ uintnat res, threshold;
int sign, base, d;
p = parse_sign_and_base(String_val(s), &base, &sign);
- threshold = ((unsigned long) -1) / base;
+ threshold = ((uintnat) -1) / base;
d = parse_digit(*p);
if (d < 0 || d >= base) caml_failwith("int_of_string");
for (p++, res = d; /*nothing*/; p++) {
if (res > threshold) caml_failwith("int_of_string");
res = base * res + d;
/* Detect overflow in addition (base * res) + d */
- if (res < (unsigned long) d) caml_failwith("int_of_string");
+ if (res < (uintnat) d) caml_failwith("int_of_string");
}
if (p != String_val(s) + caml_string_length(s)){
caml_failwith("int_of_string");
} else {
/* Unsigned representation expected, allow 0 to 2^nbits - 1
and tolerate -(2^nbits - 1) to 0 */
- if (nbits < sizeof(unsigned long) * 8 && res >= 1UL << nbits)
+ if (nbits < sizeof(uintnat) * 8 && res >= 1UL << nbits)
caml_failwith("int_of_string");
}
- return sign < 0 ? -((long) res) : (long) res;
+ return sign < 0 ? -((intnat) res) : (intnat) res;
}
#ifdef NONSTANDARD_DIV_MOD
-long caml_safe_div(long p, long q)
+intnat caml_safe_div(intnat p, intnat q)
{
- unsigned long ap = p >= 0 ? p : -p;
- unsigned long aq = q >= 0 ? q : -q;
- unsigned long ar = ap / aq;
+ uintnat ap = p >= 0 ? p : -p;
+ uintnat aq = q >= 0 ? q : -q;
+ uintnat ar = ap / aq;
return (p ^ q) >= 0 ? ar : -ar;
}
-long caml_safe_mod(long p, long q)
+intnat caml_safe_mod(intnat p, intnat q)
{
- unsigned long ap = p >= 0 ? p : -p;
- unsigned long aq = q >= 0 ? q : -q;
- unsigned long ar = ap % aq;
+ uintnat ap = p >= 0 ? p : -p;
+ uintnat aq = q >= 0 ? q : -q;
+ uintnat ar = ap % aq;
return p >= 0 ? ar : -ar;
}
#endif
CAMLprim value caml_int_of_string(value s)
{
- return Val_long(parse_long(s, 8 * sizeof(value) - 1));
+ return Val_long(parse_intnat(s, 8 * sizeof(value) - 1));
}
#define FORMAT_BUFFER_SIZE 32
return (i1 > i2) - (i1 < i2);
}
-static long int32_hash(value v)
+static intnat int32_hash(value v)
{
return Int32_val(v);
}
-static void int32_serialize(value v, unsigned long * wsize_32,
- unsigned long * wsize_64)
+static void int32_serialize(value v, uintnat * wsize_32,
+ uintnat * wsize_64)
{
caml_serialize_int_4(Int32_val(v));
*wsize_32 = *wsize_64 = 4;
}
-static unsigned long int32_deserialize(void * dst)
+static uintnat int32_deserialize(void * dst)
{
*((int32 *) dst) = caml_deserialize_sint_4();
return 4;
char conv;
value res;
- buffer = parse_format(fmt, "", format_string, default_format_buffer, &conv);
- sprintf(buffer, format_string, (long) Int32_val(arg));
+ buffer = parse_format(fmt, ARCH_INT32_PRINTF_FORMAT,
+ format_string, default_format_buffer, &conv);
+ sprintf(buffer, format_string, Int32_val(arg));
res = caml_copy_string(buffer);
if (buffer != default_format_buffer) caml_stat_free(buffer);
return res;
CAMLprim value caml_int32_of_string(value s)
{
- return caml_copy_int32(parse_long(s, 32));
+ return caml_copy_int32(parse_intnat(s, 32));
}
CAMLprim value caml_int32_bits_of_float(value vd)
return I64_compare(i1, i2);
}
-static long int64_hash(value v)
+static intnat int64_hash(value v)
{
- return I64_to_long(Int64_val(v));
+ return I64_to_intnat(Int64_val(v));
}
-static void int64_serialize(value v, unsigned long * wsize_32,
- unsigned long * wsize_64)
+static void int64_serialize(value v, uintnat * wsize_32,
+ uintnat * wsize_64)
{
caml_serialize_int_8(Int64_val(v));
*wsize_32 = *wsize_64 = 8;
}
-static unsigned long int64_deserialize(void * dst)
+static uintnat int64_deserialize(void * dst)
{
#ifndef ARCH_ALIGN_INT64
*((int64 *) dst) = caml_deserialize_sint_8();
{ return caml_copy_int64(I64_lsr(Int64_val(v1), Int_val(v2))); }
CAMLprim value caml_int64_of_int(value v)
-{ return caml_copy_int64(I64_of_long(Long_val(v))); }
+{ return caml_copy_int64(I64_of_intnat(Long_val(v))); }
CAMLprim value caml_int64_to_int(value v)
-{ return Val_long(I64_to_long(Int64_val(v))); }
+{ return Val_long(I64_to_intnat(Int64_val(v))); }
CAMLprim value caml_int64_of_float(value v)
{ return caml_copy_int64(I64_of_double(Double_val(v))); }
{ return caml_copy_int32(I64_to_int32(Int64_val(v))); }
CAMLprim value caml_int64_of_nativeint(value v)
-{ return caml_copy_int64(I64_of_long(Nativeint_val(v))); }
+{ return caml_copy_int64(I64_of_intnat(Nativeint_val(v))); }
CAMLprim value caml_int64_to_nativeint(value v)
-{ return caml_copy_nativeint(I64_to_long(Int64_val(v))); }
+{ return caml_copy_nativeint(I64_to_intnat(Int64_val(v))); }
CAMLprim value caml_int64_compare(value v1, value v2)
{
static int nativeint_cmp(value v1, value v2)
{
- long i1 = Nativeint_val(v1);
- long i2 = Nativeint_val(v2);
+ intnat i1 = Nativeint_val(v1);
+ intnat i2 = Nativeint_val(v2);
return (i1 > i2) - (i1 < i2);
}
-static long nativeint_hash(value v)
+static intnat nativeint_hash(value v)
{
return Nativeint_val(v);
}
-static void nativeint_serialize(value v, unsigned long * wsize_32,
- unsigned long * wsize_64)
+static void nativeint_serialize(value v, uintnat * wsize_32,
+ uintnat * wsize_64)
{
- long l = Nativeint_val(v);
+ intnat l = Nativeint_val(v);
#ifdef ARCH_SIXTYFOUR
if (l <= 0x7FFFFFFFL && l >= -0x80000000L) {
caml_serialize_int_1(1);
*wsize_64 = 8;
}
-static unsigned long nativeint_deserialize(void * dst)
+static uintnat nativeint_deserialize(void * dst)
{
switch (caml_deserialize_uint_1()) {
case 1:
nativeint_deserialize
};
-CAMLexport value caml_copy_nativeint(long i)
+CAMLexport value caml_copy_nativeint(intnat i)
{
- value res = caml_alloc_custom(&caml_nativeint_ops, sizeof(long), 0, 1);
+ value res = caml_alloc_custom(&caml_nativeint_ops, sizeof(intnat), 0, 1);
Nativeint_val(res) = i;
return res;
}
CAMLprim value caml_nativeint_div(value v1, value v2)
{
- long divisor = Nativeint_val(v2);
+ intnat divisor = Nativeint_val(v2);
if (divisor == 0) caml_raise_zero_divide();
#ifdef NONSTANDARD_DIV_MOD
return caml_copy_nativeint(caml_safe_div(Nativeint_val(v1), divisor));
CAMLprim value caml_nativeint_mod(value v1, value v2)
{
- long divisor = Nativeint_val(v2);
+ intnat divisor = Nativeint_val(v2);
if (divisor == 0) caml_raise_zero_divide();
#ifdef NONSTANDARD_DIV_MOD
return caml_copy_nativeint(caml_safe_mod(Nativeint_val(v1), divisor));
{ return caml_copy_nativeint(Nativeint_val(v1) >> Int_val(v2)); }
CAMLprim value caml_nativeint_shift_right_unsigned(value v1, value v2)
-{ return caml_copy_nativeint((unsigned long)Nativeint_val(v1) >> Int_val(v2)); }
+{ return caml_copy_nativeint((uintnat)Nativeint_val(v1) >> Int_val(v2)); }
CAMLprim value caml_nativeint_of_int(value v)
{ return caml_copy_nativeint(Long_val(v)); }
{ return Val_long(Nativeint_val(v)); }
CAMLprim value caml_nativeint_of_float(value v)
-{ return caml_copy_nativeint((long)(Double_val(v))); }
+{ return caml_copy_nativeint((intnat)(Double_val(v))); }
CAMLprim value caml_nativeint_to_float(value v)
{ return caml_copy_double((double)(Nativeint_val(v))); }
CAMLprim value caml_nativeint_compare(value v1, value v2)
{
- long i1 = Nativeint_val(v1);
- long i2 = Nativeint_val(v2);
+ intnat i1 = Nativeint_val(v1);
+ intnat i2 = Nativeint_val(v2);
int res = (i1 > i2) - (i1 < i2);
return Val_int(res);
}
char conv;
value res;
- buffer = parse_format(fmt, "l", format_string, default_format_buffer, &conv);
+ buffer = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT,
+ format_string, default_format_buffer, &conv);
sprintf(buffer, format_string, (long) Nativeint_val(arg));
res = caml_copy_string(buffer);
if (buffer != default_format_buffer) caml_stat_free(buffer);
CAMLprim value caml_nativeint_of_string(value s)
{
- return caml_copy_nativeint(parse_long(s, 8 * sizeof(value)));
+ return caml_copy_nativeint(parse_intnat(s, 8 * sizeof(value)));
}
/* */
/***********************************************************************/
-/* $Id: io.c,v 1.68 2004/01/08 22:28:48 doligez Exp $ */
+/* $Id: io.c,v 1.72 2005/10/25 19:15:36 mauny Exp $ */
/* Buffered input/output. */
channel->old_revealed = 0;
channel->refcount = 0;
channel->next = caml_all_opened_channels;
+ channel->prev = NULL;
+ if (caml_all_opened_channels != NULL)
+ caml_all_opened_channels->prev = channel;
caml_all_opened_channels = channel;
return channel;
}
static void unlink_channel(struct channel *channel)
{
- struct channel ** cp = &caml_all_opened_channels;
-
- while (*cp != channel && *cp != NULL)
- cp = &(*cp)->next;
- if (*cp != NULL)
- *cp = (*cp)->next;
+ if (channel->prev == NULL) {
+ Assert (channel == caml_all_opened_channels);
+ caml_all_opened_channels = caml_all_opened_channels->next;
+ if (caml_all_opened_channels != NULL)
+ caml_all_opened_channels->prev = NULL;
+ } else {
+ channel->prev->next = channel->next;
+ if (channel->next != NULL) channel->next->prev = channel->prev;
+ }
}
CAMLexport void caml_close_channel(struct channel *channel)
CAMLexport int caml_channel_binary_mode(struct channel *channel)
{
-#ifdef _WIN32
+#if defined(_WIN32) || defined(__CYGWIN__)
int oldmode = setmode(channel->fd, O_BINARY);
if (oldmode == O_TEXT) setmode(channel->fd, O_TEXT);
return oldmode == O_BINARY;
{
int retcode;
- Assert(!Is_young((value) p));
again:
caml_enter_blocking_section();
retcode = write(fd, p, n);
putch(channel, w);
}
-CAMLexport int caml_putblock(struct channel *channel, char *p, long int len)
+CAMLexport int caml_putblock(struct channel *channel, char *p, intnat len)
{
int n, free, towrite, written;
}
}
-CAMLexport void caml_really_putblock(struct channel *channel, char *p, long len)
+CAMLexport void caml_really_putblock(struct channel *channel,
+ char *p, intnat len)
{
int written;
while (len > 0) {
{
int retcode;
- /*Assert(!Is_young((value) p)); ** Is_young only applies to a true value */
- caml_enter_blocking_section();
-#ifdef EINTR
- do { retcode = read(fd, p, n); } while (retcode == -1 && errno == EINTR);
-#else
- retcode = read(fd, p, n);
-#endif
- caml_leave_blocking_section();
+ do {
+ caml_enter_blocking_section();
+ retcode = read(fd, p, n);
+ caml_leave_blocking_section();
+ } while (retcode == -1 && errno == EINTR);
if (retcode == -1) caml_sys_error(NO_ARG);
return retcode;
}
return res;
}
-CAMLexport int caml_getblock(struct channel *channel, char *p, long int len)
+CAMLexport int caml_getblock(struct channel *channel, char *p, intnat len)
{
int n, avail, nread;
}
}
-CAMLexport int caml_really_getblock(struct channel *chan, char *p, long int n)
+CAMLexport int caml_really_getblock(struct channel *chan, char *p, intnat n)
{
int r;
while (n > 0) {
return channel->offset - (file_offset)(channel->max - channel->curr);
}
-CAMLexport long caml_input_scan_line(struct channel *channel)
+CAMLexport intnat caml_input_scan_line(struct channel *channel)
{
char * p;
int n;
CAMLprim value caml_ml_set_binary_mode(value vchannel, value mode)
{
-#ifdef _WIN32
+#if defined(_WIN32) || defined(__CYGWIN__)
struct channel * channel = Channel(vchannel);
if (setmode(channel->fd, Bool_val(mode) ? O_BINARY : O_TEXT) == -1)
caml_sys_error(NO_ARG);
{
CAMLparam4 (vchannel, buff, start, length);
struct channel * channel = Channel(vchannel);
- long pos = Long_val(start);
- long len = Long_val(length);
+ intnat pos = Long_val(start);
+ intnat len = Long_val(length);
Lock(channel);
while (len > 0) {
CAMLprim value caml_ml_input_int(value vchannel)
{
struct channel * channel = Channel(vchannel);
- long i;
+ intnat i;
Lock(channel);
i = caml_getword(channel);
{
CAMLparam4 (vchannel, buff, vstart, vlength);
struct channel * channel = Channel(vchannel);
- long start, len;
+ intnat start, len;
int n, avail, nread;
Lock(channel);
CAMLprim value caml_ml_input_scan_line(value vchannel)
{
struct channel * channel = Channel(vchannel);
- long res;
+ intnat res;
Lock(channel);
res = caml_input_scan_line(channel);
/* */
/***********************************************************************/
-/* $Id: io.h,v 1.25 2004/01/01 16:42:36 doligez Exp $ */
+/* $Id: io.h,v 1.29 2005/09/24 16:14:41 xleroy Exp $ */
/* Buffered input/output */
#define IO_BUFFER_SIZE 4096
#endif
-#ifdef HAS_OFF_T
+#if defined(_WIN32)
+typedef __int64 file_offset;
+extern __int64 _lseeki64(int, __int64, int);
+#define lseek(fd,d,m) _lseeki64(fd,d,m)
+#elif defined(HAS_OFF_T)
#include <sys/types.h>
typedef off_t file_offset;
#else
char * curr; /* Current position in the buffer */
char * max; /* Logical end of the buffer (for input) */
void * mutex; /* Placeholder for mutex (for systhreads) */
- struct channel * next; /* Linear chaining of channels (flush_all) */
+ struct channel * next, * prev;/* Double chaining of channels (flush_all) */
int revealed; /* For Cash only */
int old_revealed; /* For Cash only */
int refcount; /* For flush_all and for Cash */
CAMLextern int caml_flush_partial (struct channel *);
CAMLextern void caml_flush (struct channel *);
CAMLextern void caml_putword (struct channel *, uint32);
-CAMLextern int caml_putblock (struct channel *, char *, long);
-CAMLextern void caml_really_putblock (struct channel *, char *, long);
+CAMLextern int caml_putblock (struct channel *, char *, intnat);
+CAMLextern void caml_really_putblock (struct channel *, char *, intnat);
CAMLextern unsigned char caml_refill (struct channel *);
CAMLextern uint32 caml_getword (struct channel *);
-CAMLextern int caml_getblock (struct channel *, char *, long);
-CAMLextern int caml_really_getblock (struct channel *, char *, long);
+CAMLextern int caml_getblock (struct channel *, char *, intnat);
+CAMLextern int caml_really_getblock (struct channel *, char *, intnat);
/* Extract a struct channel * from the heap object representing it */
/* */
/***********************************************************************/
-/* $Id: major_gc.c,v 1.54.2.1 2004/07/03 10:00:59 doligez Exp $ */
+/* $Id: major_gc.c,v 1.58 2005/10/25 16:24:13 doligez Exp $ */
#include <limits.h>
#include "roots.h"
#include "weak.h"
-unsigned long caml_percent_free;
-long caml_major_heap_increment;
+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;
static asize_t gray_vals_size;
static int heap_is_pure; /* The heap is pure if the only gray objects
below [markhp] are also in [gray_vals]. */
-unsigned long caml_allocated_words;
-unsigned long caml_dependent_size, caml_dependent_allocated;
+uintnat caml_allocated_words;
+uintnat caml_dependent_size, caml_dependent_allocated;
double caml_extra_heap_resources;
-unsigned long caml_fl_size_at_phase_change = 0;
+uintnat caml_fl_size_at_phase_change = 0;
extern char *caml_fl_merge; /* Defined in freelist.c. */
Assert (gray_vals_cur == gray_vals_end);
if (gray_vals_size < caml_stat_heap_size / 128){
- caml_gc_message (0x08, "Growing gray_vals to %luk bytes\n",
- (long) gray_vals_size * sizeof (value) / 512);
+ caml_gc_message (0x08, "Growing gray_vals to %"
+ ARCH_INTNAT_PRINTF_FORMAT "uk bytes\n",
+ (intnat) gray_vals_size * sizeof (value) / 512);
new = (value *) realloc ((char *) gray_vals,
2 * gray_vals_size * sizeof (value));
if (new == NULL){
void caml_darken (value v, value *p /* not used */)
{
if (Is_block (v) && Is_in_heap (v)) {
- if (Tag_val(v) == Infix_tag) v -= Infix_offset_val(v);
- CAMLassert (!Is_blue_val (v));
- if (Is_white_val (v)){
- Hd_val (v) = Grayhd_hd (Hd_val (v));
- *gray_vals_cur++ = v;
- if (gray_vals_cur >= gray_vals_end) realloc_gray_vals ();
+ header_t h = Hd_val (v);
+ tag_t t = Tag_hd (h);
+ if (t == Infix_tag){
+ v -= Infix_offset_val(v);
+ h = Hd_val (v);
+ t = Tag_hd (h);
+ }
+ CAMLassert (!Is_blue_hd (h));
+ if (Is_white_hd (h)){
+ if (t < No_scan_tag){
+ Hd_val (v) = Grayhd_hd (h);
+ *gray_vals_cur++ = v;
+ if (gray_vals_cur >= gray_vals_end) realloc_gray_vals ();
+ }else{
+ Hd_val (v) = Blackhd_hd (h);
+ }
}
}
}
#endif
}
-static void mark_slice (long work)
+static void mark_slice (intnat work)
{
value *gray_vals_ptr; /* Local copy of gray_vals_cur */
value v, child;
gray_vals_cur = gray_vals_ptr;
}
-static void sweep_slice (long work)
+static void sweep_slice (intnat work)
{
char *hp;
header_t hd;
[howmuch] is the amount of work to do, 0 to let the GC compute it.
Return the computed amount of work to do.
*/
-long caml_major_collection_slice (long howmuch)
+intnat caml_major_collection_slice (intnat howmuch)
{
double p, dp;
- long computed_work;
+ intnat computed_work;
/*
Free memory at the start of the GC cycle (garbage + free list) (assumed):
FM = caml_stat_heap_size * caml_percent_free
if (p < dp) p = dp;
if (p < caml_extra_heap_resources) p = caml_extra_heap_resources;
- caml_gc_message (0x40, "allocated_words = %lu\n", caml_allocated_words);
- caml_gc_message (0x40, "extra_heap_resources = %luu\n",
- (unsigned long) (caml_extra_heap_resources * 1000000));
- caml_gc_message (0x40, "amount of work to do = %luu\n",
- (unsigned long) (p * 1000000));
+ caml_gc_message (0x40, "allocated_words = %"
+ ARCH_INTNAT_PRINTF_FORMAT "u\n",
+ caml_allocated_words);
+ caml_gc_message (0x40, "extra_heap_resources = %"
+ ARCH_INTNAT_PRINTF_FORMAT "uu\n",
+ (uintnat) (caml_extra_heap_resources * 1000000));
+ caml_gc_message (0x40, "amount of work to do = %"
+ ARCH_INTNAT_PRINTF_FORMAT "uu\n",
+ (uintnat) (p * 1000000));
if (caml_gc_phase == Phase_mark){
- computed_work = 2 * (long) (p * Wsize_bsize (caml_stat_heap_size) * 100
+ computed_work = 2 * (intnat) (p * Wsize_bsize (caml_stat_heap_size) * 100
/ (100 + caml_percent_free));
}else{
- computed_work = 2 * (long) (p * Wsize_bsize (caml_stat_heap_size));
+ computed_work = 2 * (intnat) (p * Wsize_bsize (caml_stat_heap_size));
}
caml_gc_message (0x40, "ordered work = %ld words\n", howmuch);
caml_gc_message (0x40, "computed work = %ld words\n", computed_work);
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 ((unsigned long) caml_heap_end % Page_size == 0);
+ Assert ((uintnat) caml_heap_end % Page_size == 0);
caml_stat_heap_chunks = 1;
/* */
/***********************************************************************/
-/* $Id: major_gc.h,v 1.20 2004/06/14 15:17:43 doligez Exp $ */
+/* $Id: major_gc.h,v 1.21 2005/09/22 14:21:50 xleroy Exp $ */
#ifndef CAML_MAJOR_GC_H
#define CAML_MAJOR_GC_H
#define Chunk_block(c) (((heap_chunk_head *) (c)) [-1]).block
extern int caml_gc_phase;
-extern unsigned long caml_allocated_words;
+extern uintnat caml_allocated_words;
extern double caml_extra_heap_resources;
-extern unsigned long caml_dependent_size, caml_dependent_allocated;
-extern unsigned long caml_fl_size_at_phase_change;
+extern uintnat caml_dependent_size, caml_dependent_allocated;
+extern uintnat caml_fl_size_at_phase_change;
#define Phase_mark 0
#define Phase_sweep 1
CAMLextern char *caml_heap_start;
CAMLextern char *caml_heap_end;
-extern unsigned long total_heap_size;
+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) ((unsigned long) (p) >> Page_log)
+#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 \
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 *);
-long caml_major_collection_slice (long);
+intnat caml_major_collection_slice (long);
void major_collection (void);
void caml_finish_major_cycle (void);
/* */
/***********************************************************************/
-/* $Id: md5.c,v 1.18 2004/01/01 16:42:36 doligez Exp $ */
+/* $Id: md5.c,v 1.19 2005/09/22 14:21:50 xleroy Exp $ */
#include <string.h>
#include "alloc.h"
struct channel * chan = Channel(vchan);
struct MD5Context ctx;
value res;
- long toread, read;
+ intnat toread, read;
char buffer[4096];
Lock(chan);
* of bytes.
*/
CAMLexport void caml_MD5Update(struct MD5Context *ctx, unsigned char *buf,
- unsigned long len)
+ uintnat len)
{
uint32 t;
/* */
/***********************************************************************/
-/* $Id: md5.h,v 1.12 2003/12/31 14:20:37 doligez Exp $ */
+/* $Id: md5.h,v 1.13 2005/09/22 14:21:50 xleroy Exp $ */
/* MD5 message digest */
CAMLextern void caml_MD5Init (struct MD5Context *context);
CAMLextern void caml_MD5Update (struct MD5Context *context, unsigned char *buf,
- unsigned long len);
+ uintnat len);
CAMLextern void caml_MD5Final (unsigned char *digest, struct MD5Context *ctx);
CAMLextern void caml_MD5Transform (uint32 *buf, uint32 *in);
/* */
/***********************************************************************/
-/* $Id: memory.c,v 1.40.2.1 2004/12/22 16:12:16 doligez Exp $ */
+/* $Id: memory.c,v 1.43 2005/09/22 14:21:50 xleroy Exp $ */
#include <stdlib.h>
#include <string.h>
}
#ifdef DEBUG
{
- unsigned long i;
+ uintnat i;
for (i = 0; i < wosize; i++){
Field (Val_hp (hp), i) = Debug_uninit_major;
}
/* Dependent memory is all memory blocks allocated out of the heap
that depend on the GC (and finalizers) for deallocation.
- For the GC to take dependent memory in its automatic speed setting,
+ For the GC to take dependent memory into account when computing
+ its automatic speed setting,
you must call [caml_alloc_dependent_memory] when you alloate some
dependent memory, and [caml_free_dependent_memory] when you
- free it. In both cases, you pass as argument the size of the
- block being allocated or freed.
+ free it. In both cases, you pass as argument the size (in bytes)
+ of the block being allocated or freed.
*/
CAMLexport void caml_alloc_dependent_memory (mlsize_t nbytes)
{
/* */
/***********************************************************************/
-/* $Id: memory.h,v 1.50.2.2 2004/11/22 11:16:03 doligez Exp $ */
+/* $Id: memory.h,v 1.54 2005/10/14 16:40:48 xleroy Exp $ */
/* Allocation macros and functions */
#ifdef DEBUG
#define DEBUG_clear(result, wosize) do{ \
- unsigned long caml__DEBUG_i; \
+ uintnat caml__DEBUG_i; \
for (caml__DEBUG_i = 0; caml__DEBUG_i < (wosize); ++ caml__DEBUG_i){ \
Field ((result), caml__DEBUG_i) = Debug_uninit_minor; \
} \
struct caml__roots_block {
struct caml__roots_block *next;
- long ntables;
- long nitems;
+ intnat ntables;
+ intnat nitems;
value *tables [5];
};
CAMLxparamN (x, (size))
-#if defined (__GNUC__)
+#if defined (__GNUC__) && (__GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ > 7))
#define CAMLunused __attribute__ ((unused))
#else
#define CAMLunused
/* */
/***********************************************************************/
-/* $Id: minor_gc.c,v 1.42 2004/01/05 20:25:59 doligez Exp $ */
+/* $Id: minor_gc.c,v 1.43 2005/09/22 14:21:50 xleroy Exp $ */
#include <string.h>
#include "config.h"
*/
CAMLexport void caml_minor_collection (void)
{
- long prev_alloc_words = caml_allocated_words;
+ intnat prev_alloc_words = caml_allocated_words;
caml_empty_minor_heap ();
ref_table_size *= 2;
sz = (ref_table_size + ref_table_reserve) * sizeof (value *);
- caml_gc_message (0x08, "Growing ref_table to %ldk bytes\n", (long) sz/1024);
+ 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){
caml_fatal_error ("Fatal error: ref_table overflow\n");
/* */
/***********************************************************************/
-/* $Id: misc.c,v 1.26 2004/04/01 13:07:57 xleroy Exp $ */
+/* $Id: misc.c,v 1.28 2005/10/18 14:03:43 xleroy Exp $ */
#include <stdio.h>
#include "config.h"
#endif /* DEBUG */
-unsigned long caml_verb_gc = 0;
+uintnat caml_verb_gc = 0;
-void caml_gc_message (int level, char *msg, unsigned long arg)
+void caml_gc_message (int level, char *msg, uintnat arg)
{
if (level < 0 || (caml_verb_gc & level) != 0){
fprintf (stderr, msg, arg);
char *caml_aligned_malloc (asize_t size, int modulo, void **block)
{
char *raw_mem;
- unsigned long aligned_mem;
+ uintnat aligned_mem;
Assert (modulo < Page_size);
raw_mem = (char *) malloc (size + Page_size);
if (raw_mem == NULL) return NULL;
*block = raw_mem;
raw_mem += modulo; /* Address to be aligned */
- aligned_mem = (((unsigned long) raw_mem / Page_size + 1) * Page_size);
+ aligned_mem = (((uintnat) raw_mem / Page_size + 1) * Page_size);
#ifdef DEBUG
{
- unsigned long *p;
- unsigned long *p0 = (void *) *block,
- *p1 = (void *) (aligned_mem - modulo),
- *p2 = (void *) (aligned_mem - modulo + size),
- *p3 = (void *) ((char *) *block + size + Page_size);
+ 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;
/* */
/***********************************************************************/
-/* $Id: misc.h,v 1.30 2004/05/17 17:09:59 doligez Exp $ */
+/* $Id: misc.h,v 1.31 2005/09/22 14:21:50 xleroy Exp $ */
/* Miscellaneous macros and variables. */
/* GC flags and messages */
-extern unsigned long caml_verb_gc;
-void caml_gc_message (int, char *, unsigned long);
+extern uintnat caml_verb_gc;
+void caml_gc_message (int, char *, uintnat);
/* Memory routines */
#ifdef DEBUG
#ifdef ARCH_SIXTYFOUR
#define Debug_tag(x) (0xD700D7D7D700D6D7ul \
- | ((unsigned long) (x) << 16) \
- | ((unsigned long) (x) << 48))
+ | ((uintnat) (x) << 16) \
+ | ((uintnat) (x) << 48))
#else
-#define Debug_tag(x) (0xD700D6D7ul | ((unsigned long) (x) << 16))
+#define Debug_tag(x) (0xD700D6D7ul | ((uintnat) (x) << 16))
#endif /* ARCH_SIXTYFOUR */
/*
/* */
/***********************************************************************/
-/* $Id: mlvalues.h,v 1.48.6.1 2004/07/07 01:14:43 garrigue Exp $ */
+/* $Id: mlvalues.h,v 1.51 2005/09/22 14:21:50 xleroy Exp $ */
#ifndef CAML_MLVALUES_H
#define CAML_MLVALUES_H
word: Four bytes on 32 and 16 bit architectures,
eight bytes on 64 bit architectures.
- long: A C long integer.
+ long: A C integer having the same number of bytes as a word.
val: The ML representation of something. A long or a block or a pointer
outside the heap. If it is a block, it is the (encoded) address
of an object. If it is a long, it is encoded as well.
This is for use only by the GC.
*/
-typedef long value;
-typedef unsigned long header_t;
-typedef unsigned long mlsize_t;
+typedef intnat value;
+typedef uintnat header_t;
+typedef uintnat mlsize_t;
typedef unsigned int tag_t; /* Actually, an unsigned char */
-typedef unsigned long color_t;
-typedef unsigned long mark_t;
+typedef uintnat color_t;
+typedef uintnat mark_t;
/* Longs vs blocks. */
#define Is_long(x) (((x) & 1) != 0)
/* Conversion macro names are always of the form "to_from". */
/* Example: Val_long as in "Val from long" or "Val of long". */
-#define Val_long(x) (((long)(x) << 1) + 1)
+#define Val_long(x) (((intnat)(x) << 1) + 1)
#define Long_val(x) ((x) >> 1)
#define Max_long ((1L << (8 * sizeof(value) - 2)) - 1)
#define Min_long (-(1L << (8 * sizeof(value) - 2)))
#define Val_int(x) Val_long(x)
#define Int_val(x) ((int) Long_val(x))
-#define Unsigned_long_val(x) ((unsigned long)(x) >> 1)
+#define Unsigned_long_val(x) ((uintnat)(x) >> 1)
#define Unsigned_int_val(x) ((int) Unsigned_long_val(x))
/* Structure of the header:
/* Int32.t, Int64.t and Nativeint.t are represented as custom blocks. */
#define Int32_val(v) (*((int32 *) Data_custom_val(v)))
-#define Nativeint_val(v) (*((long *) Data_custom_val(v)))
+#define Nativeint_val(v) (*((intnat *) Data_custom_val(v)))
#ifndef ARCH_ALIGN_INT64
#define Int64_val(v) (*((int64 *) Data_custom_val(v)))
#else
/* */
/***********************************************************************/
-/* $Id: obj.c,v 1.34.2.3 2005/01/04 16:29:27 doligez Exp $ */
+/* $Id: obj.c,v 1.39 2005/01/04 16:29:33 doligez Exp $ */
/* Operations on objects */
}
}
#endif /*CAML_JIT*/
-
-/* eof $Id: obj.c,v 1.34.2.3 2005/01/04 16:29:27 doligez Exp $ */
/* */
/***********************************************************************/
-/* $Id: roots.c,v 1.28 2004/01/05 20:25:59 doligez Exp $ */
+/* $Id: roots.c,v 1.29 2005/09/22 14:21:50 xleroy Exp $ */
/* To walk the memory roots for garbage collection */
register value * sp;
struct global_root * gr;
struct caml__roots_block *lr;
- long i, j;
+ intnat i, j;
/* The stack */
for (sp = caml_extern_sp; sp < caml_stack_high; sp++) {
/* */
/***********************************************************************/
-/* $Id: roots.h,v 1.18 2004/01/01 16:42:37 doligez Exp $ */
+/* $Id: roots.h,v 1.19 2005/09/22 14:21:50 xleroy Exp $ */
#ifndef CAML_ROOTS_H
#define CAML_ROOTS_H
struct caml__roots_block *);
#else
CAMLextern void caml_do_local_roots(scanning_action f, char * bottom_of_stack,
- unsigned long last_retaddr, value * gc_regs,
+ uintnat last_retaddr, value * gc_regs,
struct caml__roots_block * local_roots);
#endif
/* */
/***********************************************************************/
-/* $Id: signals.c,v 1.46 2004/01/08 22:28:48 doligez Exp $ */
+/* $Id: signals.c,v 1.51 2005/10/12 12:33:47 xleroy Exp $ */
#include <signal.h>
#include "alloc.h"
#include "mlvalues.h"
#include "roots.h"
#include "signals.h"
+#include "signals_machdep.h"
#include "sys.h"
+#ifndef NSIG
+#define NSIG 64
+#endif
+
#ifdef _WIN32
typedef void (*sighandler)(int sig);
extern sighandler caml_win32_signal(int sig, sighandler action);
#define signal(sig,act) caml_win32_signal(sig,act)
#endif
-CAMLexport int volatile caml_async_signal_mode = 0;
-CAMLexport int volatile caml_pending_signal = 0;
+CAMLexport intnat volatile caml_pending_signals[NSIG];
CAMLexport int volatile caml_something_to_do = 0;
int volatile caml_force_major_slice = 0;
value caml_signal_handlers = 0;
-CAMLexport void (*caml_enter_blocking_section_hook)(void) = NULL;
-CAMLexport void (*caml_leave_blocking_section_hook)(void) = NULL;
CAMLexport void (* volatile caml_async_action_hook)(void) = NULL;
+static void caml_process_pending_signals(void)
+{
+ int signal_num;
+ intnat signal_state;
+
+ for (signal_num = 0; signal_num < NSIG; signal_num++) {
+ Read_and_clear(signal_state, caml_pending_signals[signal_num]);
+ if (signal_state) caml_execute_signal(signal_num, 0);
+ }
+}
+
void caml_process_event(void)
{
- int signal_number;
void (*async_action)(void);
+
if (caml_force_major_slice) caml_minor_collection ();
/* FIXME should be [caml_check_urgent_gc] */
- /* If a signal arrives between the following two instructions,
- it will be lost. To do: use atomic swap or atomic read-and-clear
- for processors that support it? */
- signal_number = caml_pending_signal;
- caml_pending_signal = 0;
- if (signal_number) caml_execute_signal(signal_number, 0);
- /* If an async action is scheduled between the following two instructions,
- it will be lost. */
- async_action = caml_async_action_hook;
- caml_async_action_hook = NULL;
+ caml_process_pending_signals();
+ Read_and_clear(async_action, caml_async_action_hook);
if (async_action != NULL) (*async_action)();
}
-static int rev_convert_signal_number(int signo);
+static intnat volatile caml_async_signal_mode = 0;
+
+static void caml_enter_blocking_section_default(void)
+{
+ Assert (caml_async_signal_mode == 0);
+ caml_async_signal_mode = 1;
+}
+
+static void caml_leave_blocking_section_default(void)
+{
+ Assert (caml_async_signal_mode == 1);
+ caml_async_signal_mode = 0;
+}
+
+static int caml_try_leave_blocking_section_default(void)
+{
+ intnat res;
+ Read_and_clear(res, caml_async_signal_mode);
+ return res;
+}
+
+CAMLexport void (*caml_enter_blocking_section_hook)(void) =
+ caml_enter_blocking_section_default;
+CAMLexport void (*caml_leave_blocking_section_hook)(void) =
+ caml_leave_blocking_section_default;
+CAMLexport int (*caml_try_leave_blocking_section_hook)(void) =
+ caml_try_leave_blocking_section_default;
+
+CAMLexport int caml_rev_convert_signal_number(int signo);
+
+/* Execute a signal handler immediately */
void caml_execute_signal(int signal_number, int in_signal_handler)
{
sigaddset(&sigs, signal_number);
sigprocmask(SIG_BLOCK, &sigs, &sigs);
#endif
- res = caml_callback_exn(Field(caml_signal_handlers, signal_number),
- Val_int(rev_convert_signal_number(signal_number)));
+ res = caml_callback_exn(
+ Field(caml_signal_handlers, signal_number),
+ Val_int(caml_rev_convert_signal_number(signal_number)));
#ifdef POSIX_SIGNALS
if (! in_signal_handler) {
/* Restore the original signal mask */
if (Is_exception_result(res)) caml_raise(Extract_exception(res));
}
+/* Record the delivery of a signal, and arrange so that caml_process_event
+ is called as soon as possible. */
+
+void caml_record_signal(int signal_number)
+{
+ caml_pending_signals[signal_number] = 1;
+ caml_something_to_do = 1;
+}
+
static void handle_signal(int signal_number)
{
#if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS)
signal(signal_number, handle_signal);
#endif
- if (caml_async_signal_mode){
- caml_leave_blocking_section ();
+ if (signal_number < 0 || signal_number >= NSIG) return;
+ if (caml_try_leave_blocking_section_hook()) {
caml_execute_signal(signal_number, 1);
- caml_enter_blocking_section ();
+ caml_enter_blocking_section_hook();
}else{
- caml_pending_signal = signal_number;
- caml_something_to_do = 1;
- }
+ caml_record_signal(signal_number);
+ }
}
void caml_urge_major_slice (void)
CAMLexport void caml_enter_blocking_section(void)
{
- int temp;
+ int i;
+ intnat pending;
while (1){
- Assert (!caml_async_signal_mode);
- /* If a signal arrives between the next two instructions,
- it will be lost. */
- temp = caml_pending_signal; caml_pending_signal = 0;
- if (temp) caml_execute_signal(temp, 0);
- caml_async_signal_mode = 1;
- if (!caml_pending_signal) break;
- caml_async_signal_mode = 0;
- }
- if (caml_enter_blocking_section_hook != NULL){
- caml_enter_blocking_section_hook();
+ /* Process all pending signals now */
+ caml_process_pending_signals();
+ caml_enter_blocking_section_hook ();
+ /* Check again for pending signals. */
+ pending = 0;
+ for (i = 0; i < NSIG; i++) pending |= caml_pending_signals[i];
+ /* If none, done; otherwise, try again */
+ if (!pending) break;
+ caml_leave_blocking_section_hook ();
}
}
CAMLexport void caml_leave_blocking_section(void)
{
-#ifdef _WIN32
- int signal_number;
-#endif
-
- if (caml_leave_blocking_section_hook != NULL){
- caml_leave_blocking_section_hook();
- }
-#ifdef _WIN32
- /* Under Win32, asynchronous signals such as ctrl-C are not processed
- immediately (see ctrl_handler in win32.c), but simply set
- [caml_pending_signal] and let the system call run to completion.
- Hence, test [caml_pending_signal] here and act upon it, before we get
- a chance to process the result of the system call. */
- signal_number = caml_pending_signal;
- caml_pending_signal = 0;
- if (signal_number) caml_execute_signal(signal_number, 1);
-#endif
- Assert(caml_async_signal_mode);
- caml_async_signal_mode = 0;
+ caml_leave_blocking_section_hook ();
+ caml_process_pending_signals();
}
#ifndef SIGABRT
return signo;
}
-static int rev_convert_signal_number(int signo)
+CAMLexport int caml_rev_convert_signal_number(int signo)
{
int i;
for (i = 0; i < sizeof(posix_signals) / sizeof(int); i++)
return signo;
}
-#ifndef NSIG
-#define NSIG 64
-#endif
-
CAMLprim value caml_install_signal_handler(value signal_number, value action)
{
CAMLparam2 (signal_number, action);
}
caml_modify(&Field(caml_signal_handlers, sig), Field(action, 0));
}
+ caml_process_pending_signals();
CAMLreturn (res);
}
/* */
/***********************************************************************/
-/* $Id: signals.h,v 1.21 2004/01/01 16:42:37 doligez Exp $ */
+/* $Id: signals.h,v 1.25 2005/10/12 12:33:47 xleroy Exp $ */
#ifndef CAML_SIGNALS_H
#define CAML_SIGNALS_H
/* <private> */
extern value caml_signal_handlers;
-CAMLextern int volatile caml_pending_signal;
+CAMLextern intnat volatile caml_pending_signals[];
CAMLextern int volatile caml_something_to_do;
extern int volatile caml_force_major_slice;
-CAMLextern int volatile caml_async_signal_mode;
/* </private> */
CAMLextern void caml_enter_blocking_section (void);
/* <private> */
void caml_urge_major_slice (void);
CAMLextern int caml_convert_signal_number (int);
+CAMLextern int caml_rev_convert_signal_number (int);
void caml_execute_signal(int signal_number, int in_signal_handler);
+void caml_record_signal(int signal_number);
void caml_process_event(void);
CAMLextern void (*caml_enter_blocking_section_hook)(void);
CAMLextern void (*caml_leave_blocking_section_hook)(void);
+CAMLextern int (*caml_try_leave_blocking_section_hook)(void);
CAMLextern void (* volatile caml_async_action_hook)(void);
/* </private> */
--- /dev/null
+/***********************************************************************/
+/* */
+/* Objective Caml */
+/* */
+/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */
+/* */
+/* Copyright 1996 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the GNU Library General Public License, with */
+/* the special exception on linking described in file ../LICENSE. */
+/* */
+/***********************************************************************/
+
+/* $Id: signals_machdep.h,v 1.2 2005/07/29 12:47:45 doligez Exp $ */
+
+/* Processor-specific operation: atomic "read and clear" */
+
+#ifndef CAML_SIGNALS_MACHDEP_H
+#define CAML_SIGNALS_MACHDEP_H
+
+#if defined(__GNUC__) && defined(__i386__)
+
+#define Read_and_clear(dst,src) \
+ asm("xorl %0, %0; xchgl %0, %1" \
+ : "=r" (dst), "=m" (src) \
+ : "m" (src))
+
+#elif defined(__GNUC__) && defined(__x86_64__)
+
+#define Read_and_clear(dst,src) \
+ asm("xorq %0, %0; xchgq %0, %1" \
+ : "=r" (dst), "=m" (src) \
+ : "m" (src))
+
+#elif defined(__GNUC__) && defined(__ppc__)
+
+#define Read_and_clear(dst,src) \
+ asm("0: lwarx %0, 0, %1\n\t" \
+ "stwcx. %2, 0, %1\n\t" \
+ "bne- 0b" \
+ : "=&r" (dst) \
+ : "r" (&(src)), "r" (0) \
+ : "cr0", "memory")
+
+#else
+
+/* Default, non-atomic implementation */
+#define Read_and_clear(dst,src) ((dst) = (src), (src) = 0)
+
+#endif
+
+#endif /* CAML_SIGNALS_MACHDEP_H */
/* */
/***********************************************************************/
-/* $Id: stacks.c,v 1.21 2004/01/01 16:42:37 doligez Exp $ */
+/* $Id: stacks.c,v 1.22 2005/09/22 14:21:50 xleroy Exp $ */
/* To initialize and resize the stacks */
CAMLexport value * caml_trap_barrier;
value caml_global_data;
-unsigned long caml_max_stack_size; /* also used in gc_ctrl.c */
+uintnat caml_max_stack_size; /* also used in gc_ctrl.c */
-void caml_init_stack (long unsigned int initial_max_size)
+void caml_init_stack (uintnat initial_max_size)
{
caml_stack_low = (value *) caml_stat_alloc(Stack_size);
caml_stack_high = caml_stack_low + Stack_size / sizeof (value);
if (size >= caml_max_stack_size) caml_raise_stack_overflow();
size *= 2;
} while (size < caml_stack_high - caml_extern_sp + required_space);
- caml_gc_message (0x08, "Growing stack to %luk bytes\n",
- (unsigned long) size * sizeof(value) / 1024);
+ caml_gc_message (0x08, "Growing stack to %"
+ ARCH_INTNAT_PRINTF_FORMAT "uk bytes\n",
+ (uintnat) size * sizeof(value) / 1024);
new_low = (value *) caml_stat_alloc(size * sizeof(value));
new_high = new_low + size;
return Val_unit;
}
-void caml_change_max_stack_size (long unsigned int new_max_size)
+void caml_change_max_stack_size (uintnat new_max_size)
{
asize_t size = caml_stack_high - caml_extern_sp
+ Stack_threshold / sizeof (value);
/* */
/***********************************************************************/
-/* $Id: stacks.h,v 1.13 2004/01/01 16:42:37 doligez Exp $ */
+/* $Id: stacks.h,v 1.14 2005/09/22 14:21:50 xleroy Exp $ */
/* structure of the stacks */
#define Trap_pc(tp) (((code_t *)(tp))[0])
#define Trap_link(tp) (((value **)(tp))[1])
-void caml_init_stack (unsigned long init_max_size);
+void caml_init_stack (uintnat init_max_size);
void caml_realloc_stack (asize_t required_size);
-void caml_change_max_stack_size (unsigned long new_max_size);
+void caml_change_max_stack_size (uintnat new_max_size);
#endif /* CAML_STACKS_H */
/* */
/***********************************************************************/
-/* $Id: startup.c,v 1.64.4.1 2004/07/03 10:01:00 doligez Exp $ */
+/* $Id: startup.c,v 1.68 2005/09/22 14:21:50 xleroy Exp $ */
/* Start-up code */
#include "stacks.h"
#include "sys.h"
#include "startup.h"
+#include "version.h"
#ifndef O_BINARY
#define O_BINARY 0
truename = caml_search_exe_in_path(*name);
*name = truename;
caml_gc_message(0x100, "Opening bytecode executable %s\n",
- (unsigned long) truename);
+ (uintnat) truename);
fd = open(truename, O_RDONLY | O_BINARY);
if (fd == -1) {
caml_gc_message(0x100, "Cannot open file\n", 0);
/* Configuration parameters and flags */
-static unsigned long percent_free_init = Percent_free_def;
-static unsigned long max_percent_free_init = Max_percent_free_def;
-static unsigned long minor_heap_init = Minor_heap_def;
-static unsigned long heap_chunk_init = Heap_chunk_def;
-static unsigned long heap_size_init = Init_heap_def;
-static unsigned long max_stack_init = Max_stack_def;
+static uintnat percent_free_init = Percent_free_def;
+static uintnat max_percent_free_init = Max_percent_free_def;
+static uintnat minor_heap_init = Minor_heap_def;
+static uintnat heap_chunk_init = Heap_chunk_def;
+static uintnat heap_size_init = Init_heap_def;
+static uintnat max_stack_init = Max_stack_def;
/* Parse options on the command line */
break;
#endif
case 'v':
- caml_verb_gc = 0x001+0x004+0x008+0x010+0x020;
+ if (!strcmp (argv[i], "-version")){
+ printf ("The Objective Caml runtime, version " OCAML_VERSION "\n");
+ exit (0);
+ }else{
+ caml_verb_gc = 0x001+0x004+0x008+0x010+0x020;
+ }
break;
case 'p':
for (j = 0; caml_names_of_builtin_cprim[j] != NULL; j++)
/* If you change these functions, see also their copy in asmrun/startup.c */
-static void scanmult (char *opt, long unsigned int *var)
+static void scanmult (char *opt, uintnat *var)
{
char mult = ' ';
- sscanf (opt, "=%lu%c", var, &mult);
- sscanf (opt, "=0x%lx%c", var, &mult);
- if (mult == 'k') *var = *var * 1024;
- if (mult == 'M') *var = *var * 1024 * 1024;
- if (mult == 'G') *var = *var * 1024 * 1024 * 1024;
+ int val;
+ sscanf (opt, "=%u%c", &val, &mult);
+ sscanf (opt, "=0x%x%c", &val, &mult);
+ switch (mult) {
+ case 'k': *var = (uintnat) val * 1024; break;
+ case 'M': *var = (uintnat) val * 1024 * 1024; break;
+ case 'G': *var = (uintnat) val * 1024 * 1024 * 1024; break;
+ default: *var = (uintnat) val; break;
+ }
}
static void parse_camlrunparam(void)
/* */
/***********************************************************************/
-/* $Id: str.c,v 1.26 2004/05/17 17:09:59 doligez Exp $ */
+/* $Id: str.c,v 1.27 2005/09/22 14:21:50 xleroy Exp $ */
/* Operations on strings */
CAMLprim value caml_string_get(value str, value index)
{
- long idx = Long_val(index);
+ intnat idx = Long_val(index);
if (idx < 0 || idx >= caml_string_length(str)) caml_array_bound_error();
return Val_int(Byte_u(str, idx));
}
CAMLprim value caml_string_set(value str, value index, value newval)
{
- long idx = Long_val(index);
+ intnat idx = Long_val(index);
if (idx < 0 || idx >= caml_string_length(str)) caml_array_bound_error();
Byte_u(str, idx) = Int_val(newval);
return Val_unit;
/* */
/***********************************************************************/
-/* $Id: sys.c,v 1.76 2004/05/18 08:50:22 xleroy Exp $ */
+/* $Id: sys.c,v 1.78 2005/10/13 14:47:05 xleroy Exp $ */
/* Basic system calls */
O_BINARY, O_TEXT, O_NONBLOCK
};
-CAMLprim value caml_sys_open(value path, value flags, value perm)
+CAMLprim value caml_sys_open(value path, value vflags, value vperm)
{
- CAMLparam3(path, flags, perm);
- int fd;
+ CAMLparam3(path, vflags, vperm);
+ int fd, flags, perm;
char * p;
p = caml_stat_alloc(caml_string_length(path) + 1);
strcpy(p, String_val(path));
+ flags = caml_convert_flag_list(vflags, sys_open_flags);
+ perm = Int_val(vperm);
/* open on a named FIFO can block (PR#1533) */
caml_enter_blocking_section();
- fd = open(p, caml_convert_flag_list(flags, sys_open_flags), Int_val(perm));
+ fd = open(p, flags, perm);
caml_leave_blocking_section();
caml_stat_free(p);
if (fd == -1) caml_sys_error(path);
CAMLparam1 (command);
int status, retcode;
char *buf;
- unsigned long len;
+ intnat len;
len = caml_string_length (command);
buf = caml_stat_alloc (len + 1);
CAMLprim value caml_sys_random_seed (value unit)
{
- long seed;
+ intnat seed;
#ifdef HAS_GETTIMEOFDAY
struct timeval tv;
gettimeofday(&tv, NULL);
/* */
/***********************************************************************/
-/* $Id: unix.c,v 1.21.6.1 2004/08/18 05:01:22 garrigue Exp $ */
+/* $Id: unix.c,v 1.25 2005/09/22 14:21:50 xleroy Exp $ */
/* Unix-specific stuff */
char *caml_aligned_mmap (asize_t size, int modulo, void **block)
{
char *raw_mem;
- unsigned long aligned_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 = (((unsigned long) raw_mem / Page_size + 1) * Page_size);
+ aligned_mem = (((uintnat) raw_mem / Page_size + 1) * Page_size);
#ifdef DEBUG
{
- unsigned long *p;
- unsigned long *p0 = (void *) *block,
- *p1 = (void *) (aligned_mem - modulo),
- *p2 = (void *) (aligned_mem - modulo + size),
- *p3 = (void *) ((char *) *block + size + Page_size);
+ 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;
/* */
/***********************************************************************/
-/* $Id: win32.c,v 1.23.6.1 2004/11/08 13:08:00 xleroy Exp $ */
+/* $Id: win32.c,v 1.26 2005/10/12 12:33:47 xleroy Exp $ */
/* Win32-specific stuff */
strcpy(fullname, (char *)(path->contents[i]));
strcat(fullname, "\\");
strcat(fullname, name);
- caml_gc_message(0x100, "Searching %s\n", (unsigned long) fullname);
+ caml_gc_message(0x100, "Searching %s\n", (uintnat) fullname);
if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname;
caml_stat_free(fullname);
}
not_found:
- caml_gc_message(0x100, "%s not found in search path\n", (unsigned long) name);
+ caml_gc_message(0x100, "%s not found in search path\n", (uintnat) name);
fullname = caml_stat_alloc(strlen(name) + 1);
strcpy(fullname, name);
return fullname;
&filepart);
if (retcode == 0) {
caml_gc_message(0x100, "%s not found in search path\n",
- (unsigned long) name);
+ (uintnat) name);
strcpy(fullname, name);
break;
}
static BOOL WINAPI ctrl_handler(DWORD event)
{
int saved_mode;
- sighandler action;
/* Only ctrl-C and ctrl-Break are handled */
if (event != CTRL_C_EVENT && event != CTRL_BREAK_EVENT) return FALSE;
/* Ignore behavior is to do nothing, which we get by claiming that we
have handled the event */
if (ctrl_handler_action == SIG_IGN) return TRUE;
- /* Reset handler to default action for consistency with signal() */
- action = ctrl_handler_action;
- ctrl_handler_action = SIG_DFL;
- /* Call user-provided signal handler. Win32 doesn't like it when
- we do a longjmp() at this point (it looks like we're running in
- a different thread than the main program!). So, pretend we are not in
- async signal mode, so that the handler simply records the signal. */
- saved_mode = caml_async_signal_mode;
- caml_async_signal_mode = 0;
- action(SIGINT);
- caml_async_signal_mode = saved_mode;
+ /* Win32 doesn't like it when we do a longjmp() at this point
+ (it looks like we're running in a different thread than
+ the main program!). So, just record the signal. */
+ caml_record_signal(SIGINT);
/* We have handled the event */
return TRUE;
}
int caml_read_directory(char * dirname, struct ext_table * contents)
{
char * template;
- long h;
+ intptr_t h;
struct _finddata_t fileinfo;
char * p;
if (!ret || numread != 1) caml_sys_exit(Val_int(2));
switch (iobuf[0]) {
case 'C':
- caml_pending_signal = SIGINT;
- caml_something_to_do = 1;
+ caml_record_signal(SIGINT);
break;
case 'T':
raise(SIGTERM);
+- [29 Jun 05] Add private row types. Make "private" a type constructor
+ "TyPrv" rather than a flag. (Jacques)
+
+- [09 Jun 04] Moved "-no_quot" option from pa_o to camlp4, enabling to
+ use it indepently fom pa_o.cmo.
+
+- [17 Nov 04] Renamed "loc" into "_loc", introducing an incompatibility
+ with existing code (3.08.x and before). Such code can generally run
+ unmodified using the -loc option (camlp4 -loc "loc").
+
Camlp4 Version 3.08.2
------------------------
- [07 Oct 04] Changes in the interfaces plexer.mli and pcaml.mli:
-# $Id: Makefile,v 1.22.2.3 2004/07/07 16:41:58 mauny Exp $
+# $Id: Makefile,v 1.23 2004/07/13 12:19:10 xleroy Exp $
include config/Makefile
-# $Id: Makefile,v 1.20.2.8 2005/01/31 10:38:53 mauny Exp $
+# $Id: Makefile,v 1.27 2005/01/31 10:38:19 mauny Exp $
include ../config/Makefile
(* camlp4r q_MLast.cmo *)
-(* $Id: argl.ml,v 1.14.2.2 2004/10/07 09:18:13 mauny Exp $ *)
+(* $Id: argl.ml,v 1.18 2005/10/21 10:55:32 mauny Exp $ *)
open Printf;
value print_location loc =
if Pcaml.input_file.val <> "-" then
let (fname, line, bp, ep) = Stdpp.line_of_loc Pcaml.input_file.val loc in
- eprintf loc_fmt Pcaml.input_file.val line bp ep
+ eprintf loc_fmt fname line bp ep
else eprintf "At location %d-%d\n" (fst loc).Lexing.pos_cnum (snd loc).Lexing.pos_cnum
;
("-v", Arg.Unit print_version,
"Print Camlp4 version and exit.");
("-version", Arg.Unit print_version_string,
- "Print Camlp4 version number and exit.")
+ "Print Camlp4 version number and exit.");
+ ("-no_quot", Arg.Set Plexer.no_quotations,
+ " Don't parse quotations, allowing to use, e.g. \"<:>\" as token")
]
;
(* *)
(***********************************************************************)
-(* $Id: ast2pt.ml,v 1.31.2.1 2005/06/01 18:22:24 mauny Exp $ *)
+(* $Id: ast2pt.ml,v 1.36 2005/06/29 04:11:26 garrigue Exp $ *)
open Stdpp;
open MLast;
value long_id_of_string_list loc sl =
match List.rev sl with
- [ [] -> error loc "bad ast"
+ [ [] -> error loc "bad ast in long ident"
| [s :: sl] -> mkli s (List.rev sl) ]
;
| TyOlb loc lab _ -> error loc "labelled type not allowed here"
| TyPol loc pl t -> mktyp loc (Ptyp_poly pl (ctyp t))
| TyQuo loc s -> mktyp loc (Ptyp_var s)
- | TyRec loc _ _ -> error loc "record type not allowed here"
- | TySum loc _ _ -> error loc "sum type not allowed here"
+ | TyRec loc _ -> error loc "record type not allowed here"
+ | TySum loc _ -> error loc "sum type not allowed here"
+ | TyPrv loc _ -> error loc "private type not allowed here"
| TyTup loc tl -> mktyp loc (Ptyp_tuple (List.map ctyp tl))
| TyUid loc s as t -> error (loc_of_ctyp t) "invalid type"
| TyVrn loc catl ool ->
;
value mkmutable m = if m then Mutable else Immutable;
value mkprivate m = if m then Private else Public;
-value mktrecord (_, n, m, t) = (n, mkmutable m, ctyp (mkpolytype t));
-value mkvariant (_, c, tl) = (c, List.map ctyp tl);
-value type_decl tl cl =
+value mktrecord (loc, n, m, t) =
+ (n, mkmutable m, ctyp (mkpolytype t), mkloc loc);
+value mkvariant (loc, c, tl) = (c, List.map ctyp tl, mkloc loc);
+value rec type_decl tl cl loc m pflag =
fun
- [ TyMan loc t (TyRec _ pflag ltl) ->
- mktype loc tl cl (Ptype_record (List.map mktrecord ltl) (mkprivate pflag))
- (Some (ctyp t))
- | TyMan loc t (TySum _ pflag ctl) ->
- mktype loc tl cl (Ptype_variant (List.map mkvariant ctl) (mkprivate pflag))
- (Some (ctyp t))
- | TyRec loc pflag ltl ->
- mktype loc tl cl (Ptype_record (List.map mktrecord ltl) (mkprivate pflag)) None
- | TySum loc pflag ctl ->
- mktype loc tl cl (Ptype_variant (List.map mkvariant ctl) (mkprivate pflag)) None
+ [ TyMan _ t1 t2 ->
+ type_decl tl cl loc (Some (ctyp t1)) pflag t2
+ | TyPrv _ t ->
+ type_decl tl cl loc m True t
+ | TyRec _ ltl ->
+ mktype loc tl cl
+ (Ptype_record (List.map mktrecord ltl) (mkprivate pflag))
+ m
+ | TySum _ ctl ->
+ mktype loc tl cl
+ (Ptype_variant (List.map mkvariant ctl) (mkprivate pflag))
+ m
| t ->
+ if m <> None then
+ error loc "only one manifest type allowed by definition" else
let m =
match t with
[ TyQuo _ s -> if List.mem_assoc s tl then Some (ctyp t) else None
| _ -> Some (ctyp t) ]
in
- mktype (loc_of_ctyp t) tl cl Ptype_abstract m ]
+ let k = if pflag then Ptype_private else Ptype_abstract in
+ mktype loc tl cl k m ]
;
+value type_decl tl cl t = type_decl tl cl (loc_of_ctyp t) None False t;
+
value mkvalue_desc t p = {pval_type = ctyp t; pval_prim = p};
value option f =
let lab =
match (lab, peoo) with
[ ("", Some (PaLid _ i | PaTyc _ (PaLid _ i) _, _)) -> i
- | ("", _) -> error loc "bad ast"
+ | ("", _) -> error loc "bad ast in label"
| _ -> lab ]
in
let (p, eo) =
| PaArr loc pl -> mkpat loc (Ppat_array (List.map patt pl))
| PaChr loc s ->
mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s)))
- | PaInt loc s -> mkpat loc (Ppat_constant (Const_int (int_of_string s)))
- | PaInt32 loc s -> mkpat loc (Ppat_constant (Const_int32 (Int32.of_string s)))
- | PaInt64 loc s -> mkpat loc (Ppat_constant (Const_int64 (Int64.of_string s)))
- | PaNativeInt loc s -> mkpat loc (Ppat_constant (Const_nativeint (Nativeint.of_string s)))
+ | PaInt loc s ->
+ let i = try int_of_string s with [
+ Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int"
+ ] in mkpat loc (Ppat_constant (Const_int i))
+ | PaInt32 loc s ->
+ let i32 = try Int32.of_string s with [
+ Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32"
+ ] in mkpat loc (Ppat_constant (Const_int32 i32))
+ | PaInt64 loc s ->
+ let i64 = try Int64.of_string s with [
+ Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64"
+ ] in mkpat loc (Ppat_constant (Const_int64 i64))
+ | PaNativeInt loc s ->
+ let nati = try Nativeint.of_string s with [
+ Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint"
+ ] in mkpat loc (Ppat_constant (Const_nativeint nati))
| PaFlo loc s -> mkpat loc (Ppat_constant (Const_float s))
| PaLab loc _ _ -> error loc "labeled pattern not allowed here"
| PaLid loc s -> mkpat loc (Ppat_var s)
| [(loc, ml, ExLid _ s) :: l] ->
(mkexp loc (Pexp_ident (mkli s ml)), l)
| [(_, [], e) :: l] -> (expr e, l)
- | _ -> error loc "bad ast" ]
+ | _ -> error loc "bad ast in expression" ]
in
let (_, e) =
List.fold_left
| ExFun loc pel -> mkexp loc (Pexp_function "" None (List.map mkpwe pel))
| ExIfe loc e1 e2 e3 ->
mkexp loc (Pexp_ifthenelse (expr e1) (expr e2) (Some (expr e3)))
- | ExInt loc s -> mkexp loc (Pexp_constant (Const_int (int_of_string s)))
- | ExInt32 loc s -> mkexp loc (Pexp_constant (Const_int32 (Int32.of_string s)))
- | ExInt64 loc s -> mkexp loc (Pexp_constant (Const_int64 (Int64.of_string s)))
- | ExNativeInt loc s -> mkexp loc (Pexp_constant (Const_nativeint (Nativeint.of_string s)))
+ | ExInt loc s ->
+ let i = try int_of_string s with [
+ Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int"
+ ] in mkexp loc (Pexp_constant (Const_int i))
+ | ExInt32 loc s ->
+ let i32 = try Int32.of_string s with [
+ Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32"
+ ] in mkexp loc (Pexp_constant (Const_int32 i32))
+ | ExInt64 loc s ->
+ let i64 = try Int64.of_string s with [
+ Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64"
+ ] in mkexp loc (Pexp_constant (Const_int64 i64))
+ | ExNativeInt loc s ->
+ let nati = try Nativeint.of_string s with [
+ Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint"
+ ] in mkexp loc (Pexp_constant (Const_nativeint nati))
| ExLab loc _ _ -> error loc "labeled expression not allowed here"
| ExLaz loc e -> mkexp loc (Pexp_lazy (expr e))
| ExLet loc rf pel e ->
fun
[ ExLid _ i | ExUid _ i -> [i]
| ExAcc _ e (ExLid _ i) | ExAcc _ e (ExUid _ i) -> loop e @ [i]
- | e -> raise_with_loc (loc_of_expr e) (Failure "bad ast") ]
+ | e -> raise_with_loc (loc_of_expr e) (Failure "bad ast in directive") ]
in
Pdir_ident (long_id_of_string_list loc sl) ]
;
(* *)
(***********************************************************************)
-(* $Id: mLast.mli,v 1.17 2004/05/19 15:00:45 mauny Exp $ *)
+(* $Id: mLast.mli,v 1.18 2005/06/29 04:11:26 garrigue Exp $ *)
(* Module [MLast]: abstract syntax tree
| TyOlb of loc and string and ctyp
| TyPol of loc and list string and ctyp
| TyQuo of loc and string
- | TyRec of loc and bool and list (loc * string * bool * ctyp)
- | TySum of loc and bool and list (loc * string * list ctyp)
+ | TyRec of loc and list (loc * string * bool * ctyp)
+ | TySum of loc and list (loc * string * list ctyp)
+ | TyPrv of loc and ctyp
| TyTup of loc and list ctyp
| TyUid of loc and string
| TyVrn of loc and list row_field and option (option (list string)) ]
(* *)
(***********************************************************************)
-(* $Id: pcaml.ml,v 1.13.2.5 2005/04/14 07:22:06 mauny Exp $ *)
+(* $Id: pcaml.ml,v 1.16 2005/04/14 09:49:17 mauny Exp $ *)
value version = Sys.ocaml_version;
(* *)
(***********************************************************************)
-(* $Id: pcaml.mli,v 1.7.2.4 2004/10/07 09:18:13 mauny Exp $ *)
+(* $Id: pcaml.mli,v 1.9 2005/03/24 17:20:53 doligez Exp $ *)
(** Language grammar, entries and printers.
(* *)
(***********************************************************************)
-(* $Id: reloc.ml,v 1.16.2.1 2005/04/14 07:22:06 mauny Exp $ *)
+(* $Id: reloc.ml,v 1.18 2005/06/29 04:11:26 garrigue Exp $ *)
open MLast;
| TyOlb loc x1 x2 -> TyOlb (floc loc) x1 (self x2)
| TyPol loc x1 x2 -> TyPol (floc loc) x1 (self x2)
| TyQuo loc x1 -> TyQuo (floc loc) x1
- | TyRec loc pflag x1 ->
- TyRec (floc loc) pflag
+ | TyRec loc x1 ->
+ TyRec (floc loc)
(List.map (fun (loc, x1, x2, x3) -> (floc loc, x1, x2, self x3)) x1)
- | TySum loc pflag x1 ->
- TySum (floc loc) pflag
+ | TySum loc x1 ->
+ TySum (floc loc)
(List.map (fun (loc, x1, x2) -> (floc loc, x1, List.map self x2)) x1)
+ | TyPrv loc x1 -> TyPrv (floc loc) (self x1)
| TyTup loc x1 -> TyTup (floc loc) (List.map self x1)
| TyUid loc x1 -> TyUid (floc loc) x1
| TyVrn loc x1 x2 ->
(* *)
(***********************************************************************)
-(* $Id: reloc.mli,v 1.3.2.3 2005/04/14 07:22:06 mauny Exp $ *)
+(* $Id: reloc.mli,v 1.5 2005/04/14 09:49:17 mauny Exp $ *)
value zero_loc : Lexing.position;
value shift_pos : int -> Lexing.position -> Lexing.position;
(* *)
(***********************************************************************)
-(* $Id: spretty.ml,v 1.3 2003/09/23 18:06:18 mauny Exp $ *)
+(* $Id: spretty.ml,v 1.4 2004/11/17 09:07:56 mauny Exp $ *)
type glue = [ LO | RO | LR | NO ];
type pretty =
| SL np LO x -> (n_print_string pos spc np x, 0)
| SL np NO x -> (n_print_string pos 0 np x, 0)
| SL np LR x -> (n_print_string pos spc np x, 1)
- | HL x as p -> print_horiz tab pos spc x
+ | HL x -> print_horiz tab pos spc x
| BL x as p -> print_horiz_vertic tab pos spc (too_long tab (pos, spc) p) x
| PL x as p -> print_paragraph tab pos spc (too_long tab (pos, spc) p) x
| QL x as p -> print_sparagraph tab pos spc (too_long tab (pos, spc) p) x
comp_trail.cmx: ../camlp4/pcaml.cmx
compile.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi
compile.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi
+pa_o_fast.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi
+pa_o_fast.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi
-# $Id: Makefile,v 1.8.4.3 2005/06/22 15:46:42 doligez Exp $
+# $Id: Makefile,v 1.13 2005/08/13 20:59:37 doligez Exp $
include ../config/Makefile
INCLUDES=-I ../camlp4 -I ../boot
-OCAMLCFLAGS=-warn-error A $(INCLUDES)
+OCAMLCFLAGS=-warn-error Ay $(INCLUDES)
SRC=../etc/pa_o.ml ../etc/pa_op.ml
D=o
COMP_OPT=-strict_parsing
(* camlp4r q_MLast.cmo pa_extend.cmo *)
-(* $Id: comp_head.ml,v 1.3.6.1 2005/02/18 09:11:13 mauny Exp $ *)
+(* $Id: comp_head.ml,v 1.4 2005/03/24 17:20:53 doligez Exp $ *)
module P =
struct
(* camlp4r *)
-(* $Id: compile.ml,v 1.13 2004/05/12 15:22:39 mauny Exp $ *)
+(* $Id: compile.ml,v 1.15 2004/11/24 01:55:16 garrigue Exp $ *)
#load "q_MLast.cmo";
value strict_parsing = ref False;
value keywords = ref [];
-value loc =
+value _loc =
let nowhere =
{(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0 } in
(nowhere,nowhere);
let patt_list =
loop e where rec loop =
fun
- [ <:expr< fun (loc : (Lexing.position * Lexing.position)) -> $_$ >> -> []
+ [ <:expr< fun (_loc : (Lexing.position * Lexing.position)) -> $_$ >> ->
+ []
| <:expr< fun ($p$ : $_$) -> $e$ >> -> [p :: loop e]
| <:expr< fun $p$ -> $e$ >> -> [p :: loop e]
| _ -> failwith "nth_patt_of_act" ]
value rec last_patt_of_act =
fun
- [ <:expr< fun ($p$ : $_$) (loc : (Lexing.position * Lexing.position)) -> $_$ >> -> p
+ [ <:expr< fun ($p$ : $_$) (_loc : (Lexing.position * Lexing.position)) ->
+ $_$ >> -> p
| <:expr< fun $_$ -> $e$ >> -> last_patt_of_act e
| _ -> failwith "last_patt_of_act" ]
;
value rec final_action =
fun
- [ <:expr< fun (loc : (Lexing.position * Lexing.position)) -> ($e$ : $_$) >> -> e
+ [ <:expr< fun (_loc : (Lexing.position * Lexing.position)) ->
+ ($e$ : $_$) >> -> e
| <:expr< fun $_$ -> $e$ >> -> final_action e
| _ -> failwith "final_action" ]
;
value rec contain_loc =
fun
- [ <:expr< $lid:s$ >> -> s = "loc"
+ [ <:expr< $lid:s$ >> -> (s = "loc") || (s = "_loc")
| <:expr< $uid:_$ >> -> False
| <:expr< $str:_$ >> -> False
| <:expr< ($list:el$) >> -> List.exists contain_loc el
| _ -> True ]
;
-value gen_let_loc loc e =
- if contain_loc e then <:expr< let loc = P.gloc bp strm__ in $e$ >> else e
+value gen_let_loc _loc e =
+ if contain_loc e then <:expr< let _loc = P.gloc bp strm__ in $e$ >> else e
;
value phony_entry = Grammar.Entry.obj Pcaml.implem;
parse_symbol_no_failure e rkont fkont ending_act
| Stree tree ->
let kont = <:expr< raise Stream.Failure >> in
- let act_kont _ act = gen_let_loc loc (final_action act) in
+ let act_kont _ act = gen_let_loc _loc (final_action act) in
let e = parse_tree phony_entry 0 0 (tree, True) act_kont kont in
parse_standard_symbol <:expr< fun strm__ -> $e$ >> rkont fkont ending_act
| Snterm e ->
(e, pel) ]
in
let act_kont end_with_self act =
- if lev.lsuffix = DeadEnd then gen_let_loc loc (final_action act)
+ if lev.lsuffix = DeadEnd then gen_let_loc _loc (final_action act)
else
let ncont = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in
- gen_let_loc loc
+ gen_let_loc _loc
<:expr< $lid:ncont$ bp $final_action act$ strm__ >>
in
let curr =
[ RightA | NonA ->
<:expr<
let $p$ = a__ in
- $gen_let_loc loc (final_action act)$
+ $gen_let_loc _loc (final_action act)$
>>
| LeftA ->
let ncont =
entry.ename ^ "_" ^ string_of_int clevn ^ "_cont"
in
- gen_let_loc loc
+ gen_let_loc _loc
<:expr<
let $p$ = a__ in
$lid:ncont$ bp $final_action act$ strm__
$OTOP/boot/ocamlrun$EXE $OTOP/boot/ocamlc -I $OTOP/boot -I ../lib -I ../camlp4 -c -impl tmp.ppo
rm tmp.ppo
> tmp.null
-$OTOP/boot/ocamlrun$EXE ../camlp4/camlp4$EXE ./compile.cmo ./tmp.cmo ../etc/pr_r.cmo ../etc/pr_rp.cmo $ARGS -sep "\n\n" -impl tmp.null
-rm tmp.*
+$OTOP/boot/ocamlrun$EXE ../camlp4/camlp4$EXE ./compile.cmo ./tmp.cmo ../etc/pr_r.cmo ../etc/pr_rp.cmo $ARGS -sep "\n\n" -impl tmp.null && rm tmp.*
-# $Id: Makefile.tpl,v 1.4.10.6 2004/07/03 16:53:45 mauny Exp $
+# $Id: Makefile.tpl,v 1.5 2004/07/13 12:19:11 xleroy Exp $
# Change the value of PROFILING to prof for systematically building
# and installing profiled versions of Camlp4 libraries. Then, execute
#! /bin/sh
-# $Id: configure_batch,v 1.5.4.3 2004/07/30 14:59:15 mauny Exp $
+# $Id: configure_batch,v 1.9 2004/08/20 17:04:34 doligez Exp $
prefix=/usr/local
bindir=''
camlp4o
camlp4sch
camlp4o.opt
+version.sh
mkcamlp4.sh
mkcamlp4.mpw
-# $Id: Makefile,v 1.20.2.2 2004/07/07 16:22:23 mauny Exp $
+# $Id: Makefile,v 1.24 2004/11/30 18:57:03 doligez Exp $
include ../config/Makefile
rm -f camlp4o.opt
cd ../camlp4; $(MAKE) optp4 CAMLP4OPT=../etc/camlp4o.opt CAMLP4M="-I ../etc $(CAMLP4OMX)"
-mkcamlp4.sh: mkcamlp4.sh.tpl
- sed -e "s!LIBDIR!$(LIBDIR)!g" mkcamlp4.sh.tpl > mkcamlp4.sh
+mkcamlp4.sh: mkcamlp4.sh.tpl version.sh
+ sed -e "s!LIBDIR!$(LIBDIR)!g" -e "/define VERSION/r version.sh" \
+ mkcamlp4.sh.tpl > mkcamlp4.sh
+
+version.sh : $(OTOP)/stdlib/sys.ml
+ sed -n -e 's/;;//' \
+ -e '/let *ocaml_version *= */s//VERSION=/p' \
+ <$(OTOP)/stdlib/sys.ml >version.sh
bootstrap_l:
../boot/camlp4 ./pa_$Lr.cmo ./q_phony.cmo -I ../boot pa_extend.cmo ./pr_r.cmo ./pr_extend.cmo ./pr_rp.cmo pa_$L.ml > tmp
#!/bin/sh
-# $Id: mkcamlp4.sh.tpl,v 1.7 2003/09/23 18:17:35 mauny Exp $
+# $Id: mkcamlp4.sh.tpl,v 1.8 2004/11/27 01:04:19 doligez Exp $
OLIB="`ocamlc -where`"
LIB="LIBDIR/camlp4"
+# automatically define VERSION here:
+
INTERFACES=
OPTS=
INCL="-I ."
while test "" != "$1"; do
case "$1" in
-I) INCL="$INCL -I $2"; shift;;
+ -version) echo "mkcamlp4, version $VERSION"; exit;;
*)
j=`basename "$1" .cmi`
if test "$j.cmi" = "$1"; then
(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(* $Id: pa_extfold.ml,v 1.1 2002/07/19 14:53:45 mauny Exp $ *)
+(* $Id: pa_extfold.ml,v 1.2 2004/11/17 09:07:56 mauny Exp $ *)
open Pcaml;
open Pa_extend;
-value sfold loc n foldfun f e s =
- let styp = STquo loc (new_type_var ()) in
+value sfold _loc n foldfun f e s =
+ let styp = STquo _loc (new_type_var ()) in
let e = <:expr< Extfold.$lid:foldfun$ $f$ $e$ >> in
- let t = STapp loc (STapp loc (STtyp <:ctyp< Extfold.t _ >>) s.styp) styp in
- {used = s.used; text = TXmeta loc n [s.text] e t; styp = styp}
+ let t = STapp _loc (STapp _loc (STtyp <:ctyp< Extfold.t _ >>) s.styp) styp in
+ {used = s.used; text = TXmeta _loc n [s.text] e t; styp = styp}
;
-value sfoldsep loc n foldfun f e s sep =
- let styp = STquo loc (new_type_var ()) in
+value sfoldsep _loc n foldfun f e s sep =
+ let styp = STquo _loc (new_type_var ()) in
let e = <:expr< Extfold.$lid:foldfun$ $f$ $e$ >> in
let t =
- STapp loc (STapp loc (STtyp <:ctyp< Extfold.tsep _ >>) s.styp) styp
+ STapp _loc (STapp _loc (STtyp <:ctyp< Extfold.tsep _ >>) s.styp) styp
in
- {used = s.used @ sep.used; text = TXmeta loc n [s.text; sep.text] e t;
+ {used = s.used @ sep.used; text = TXmeta _loc n [s.text; sep.text] e t;
styp = styp}
;
GLOBAL: symbol;
symbol: LEVEL "top"
[ [ UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF ->
- sfold loc "FOLD0" "sfold0" f e s
+ sfold _loc "FOLD0" "sfold0" f e s
| UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF ->
- sfold loc "FOLD1" "sfold1" f e s
+ sfold _loc "FOLD1" "sfold1" f e s
| UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF;
UIDENT "SEP"; sep = symbol ->
- sfoldsep loc "FOLD0 SEP" "sfold0sep" f e s sep
+ sfoldsep _loc "FOLD0 SEP" "sfold0sep" f e s sep
| UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF;
UIDENT "SEP"; sep = symbol ->
- sfoldsep loc "FOLD1 SEP" "sfold1sep" f e s sep ] ]
+ sfoldsep _loc "FOLD1 SEP" "sfold1sep" f e s sep ] ]
;
simple_expr:
[ [ i = LIDENT -> <:expr< $lid:i$ >>
(* camlp4r q_MLast.cmo pa_extend.cmo *)
-(* $Id: pa_extfun.ml,v 1.2 2002/07/19 14:53:45 mauny Exp $ *)
+(* $Id: pa_extfun.ml,v 1.3 2004/11/17 09:07:56 mauny Exp $ *)
open Pcaml;
;
value rec mexpr p =
- let loc = MLast.loc_of_patt p in
+ let _loc = MLast.loc_of_patt p in
match p with
[ <:patt< $p1$ $p2$ >> ->
loop <:expr< [$mexpr p2$] >> p1 where rec loop el =
fun
[ <:patt< $p1$ . $p2$ >> -> loop <:expr< [$mexpr p2$ :: $el$] >> p1
| p -> <:expr< Extfun.Eacc [$mexpr p$ :: $el$] >> ]
- | <:patt< ($list:pl$) >> -> <:expr< Extfun.Etup $mexpr_list loc pl$ >>
+ | <:patt< ($list:pl$) >> -> <:expr< Extfun.Etup $mexpr_list _loc pl$ >>
| <:patt< $uid:id$ >> -> <:expr< Extfun.Econ $str:id$ >>
| <:patt< ` $id$ >> -> <:expr< Extfun.Econ $str:id$ >>
| <:patt< $int:s$ >> -> <:expr< Extfun.Eint $str:s$ >>
| <:patt< $lid:_$ >> -> <:expr< Extfun.Evar () >>
| <:patt< _ >> -> <:expr< Extfun.Evar () >>
| <:patt< $p1$ | $p2$ >> ->
- Stdpp.raise_with_loc loc (Failure "or patterns not allowed in extfun")
+ Stdpp.raise_with_loc _loc (Failure "or patterns not allowed in extfun")
| p -> not_impl "mexpr" p ]
-and mexpr_list loc =
+and mexpr_list _loc =
fun
[ [] -> <:expr< [] >>
- | [e :: el] -> <:expr< [$mexpr e$ :: $mexpr_list loc el$] >> ]
+ | [e :: el] -> <:expr< [$mexpr e$ :: $mexpr_list _loc el$] >> ]
;
value rec catch_any =
value conv (p, wo, e) =
let tst = mexpr p in
- let loc = (fst (MLast.loc_of_patt p), snd (MLast.loc_of_expr e)) in
+ let _loc = (fst (MLast.loc_of_patt p), snd (MLast.loc_of_expr e)) in
let e =
if wo = None && catch_any p then <:expr< fun $p$ -> Some $e$ >>
else <:expr< fun [ $p$ $when:wo$ -> Some $e$ | _ -> None ] >>
value rec conv_list tl =
fun
[ [pe :: pel] ->
- let loc = MLast.loc_of_expr tl in
+ let _loc = MLast.loc_of_expr tl in
<:expr< [$conv pe$ :: $conv_list tl pel$] >>
| [] -> tl ]
;
split_or [(p1, wo, e); (p2, wo, e) :: pel]
| [(<:patt< ($p1$ | $p2$ as $p$) >>, wo, e) :: pel] ->
let p1 =
- let loc = MLast.loc_of_patt p1 in
+ let _loc = MLast.loc_of_patt p1 in
<:patt< ($p1$ as $p$) >>
in
let p2 =
- let loc = MLast.loc_of_patt p2 in
+ let _loc = MLast.loc_of_patt p2 in
<:patt< ($p2$ as $p$) >>
in
split_or [(p1, wo, e); (p2, wo, e) :: pel]
(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(* $Id: pa_fstream.ml,v 1.3 2002/07/19 14:53:45 mauny Exp $ *)
+(* $Id: pa_fstream.ml,v 1.4 2004/11/17 09:07:56 mauny Exp $ *)
open Pcaml;
(* parsers *)
value strm_n = "strm__";
-value next_fun loc = <:expr< Fstream.next >>;
+value next_fun _loc = <:expr< Fstream.next >>;
value rec pattern_eq_expression p e =
match (p, e) with
value stream_pattern_component skont =
fun
- [ SpTrm loc p wo ->
+ [ SpTrm _loc p wo ->
let p = <:patt< Some ($p$, $lid:strm_n$) >> in
if wo = None && pattern_eq_expression p skont then
- <:expr< $next_fun loc$ $lid:strm_n$ >>
+ <:expr< $next_fun _loc$ $lid:strm_n$ >>
else
- <:expr< match $next_fun loc$ $lid:strm_n$ with
+ <:expr< match $next_fun _loc$ $lid:strm_n$ with
[ $p$ $when:wo$ -> $skont$
| _ -> None ] >>
- | SpNtr loc p e ->
+ | SpNtr _loc p e ->
let p = <:patt< Some ($p$, $lid:strm_n$) >> in
if pattern_eq_expression p skont then <:expr< $e$ $lid:strm_n$ >>
else
<:expr< match $e$ $lid:strm_n$ with
[ $p$ -> $skont$
| _ -> None ] >>
- | SpStr loc p ->
+ | SpStr _loc p ->
<:expr< let $p$ = $lid:strm_n$ in $skont$ >> ]
;
-value rec stream_pattern loc epo e =
+value rec stream_pattern _loc epo e =
fun
[ [] ->
let e =
in
<:expr< Some ($e$, $lid:strm_n$) >>
| [spc :: spcl] ->
- let skont = stream_pattern loc epo e spcl in
+ let skont = stream_pattern _loc epo e spcl in
stream_pattern_component skont spc ]
;
-value rec parser_cases loc =
+value rec parser_cases _loc =
fun
[ [] -> <:expr< None >>
| [(spcl, epo, e) :: spel] ->
- match parser_cases loc spel with
- [ <:expr< None >> -> stream_pattern loc epo e spcl
+ match parser_cases _loc spel with
+ [ <:expr< None >> -> stream_pattern _loc epo e spcl
| pc ->
- <:expr< match $stream_pattern loc epo e spcl$ with
+ <:expr< match $stream_pattern _loc epo e spcl$ with
[ Some _ as x -> x
| None -> $pc$ ] >> ] ]
;
-value cparser_match loc me bpo pc =
- let pc = parser_cases loc pc in
+value cparser_match _loc me bpo pc =
+ let pc = parser_cases _loc pc in
let e =
match bpo with
[ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
<:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >>
;
-value cparser loc bpo pc =
- let e = parser_cases loc pc in
+value cparser _loc bpo pc =
+ let e = parser_cases _loc pc in
let e =
match bpo with
[ Some bp -> <:expr< let $bp$ = Fstream.count $lid:strm_n$ in $e$ >>
(* streams *)
-value slazy loc x = <:expr< fun () -> $x$ >>;
+value slazy _loc x = <:expr< fun () -> $x$ >>;
-value rec cstream loc =
+value rec cstream _loc =
fun
[ [] -> <:expr< Fstream.nil >>
- | [SeTrm loc e :: sel] ->
- let e2 = cstream loc sel in
+ | [SeTrm _loc e :: sel] ->
+ let e2 = cstream _loc sel in
let x = <:expr< Fstream.cons $e$ $e2$ >> in
- <:expr< Fstream.flazy $slazy loc x$ >>
- | [SeNtr loc e] ->
+ <:expr< Fstream.flazy $slazy _loc x$ >>
+ | [SeNtr _loc e] ->
e
- | [SeNtr loc e :: sel] ->
- let e2 = cstream loc sel in
+ | [SeNtr _loc e :: sel] ->
+ let e2 = cstream _loc sel in
let x = <:expr< Fstream.app $e$ $e2$ >> in
- <:expr< Fstream.flazy $slazy loc x$ >> ]
+ <:expr< Fstream.flazy $slazy _loc x$ >> ]
;
EXTEND
GLOBAL: expr;
expr: LEVEL "top"
[ [ "fparser"; po = OPT ipatt; "["; pcl = LIST0 parser_case SEP "|"; "]" ->
- <:expr< $cparser loc po pcl$ >>
+ <:expr< $cparser _loc po pcl$ >>
| "fparser"; po = OPT ipatt; pc = parser_case ->
- <:expr< $cparser loc po [pc]$ >>
+ <:expr< $cparser _loc po [pc]$ >>
| "match"; e = SELF; "with"; "parser"; po = OPT ipatt; "[";
pcl = LIST0 parser_case SEP "|"; "]" ->
- <:expr< $cparser_match loc e po pcl$ >>
+ <:expr< $cparser_match _loc e po pcl$ >>
| "match"; e = SELF; "with"; "parser"; po = OPT ipatt;
pc = parser_case ->
- <:expr< $cparser_match loc e po [pc]$ >> ] ]
+ <:expr< $cparser_match _loc e po [pc]$ >> ] ]
;
parser_case:
[ [ "[:"; sp = stream_patt; ":]"; po = OPT ipatt; "->"; e = expr ->
| -> [] ] ]
;
stream_patt_comp:
- [ [ "`"; p = patt; eo = OPT [ "when"; e = expr -> e ] -> SpTrm loc p eo
- | p = patt; "="; e = expr -> SpNtr loc p e
- | p = patt -> SpStr loc p ] ]
+ [ [ "`"; p = patt; eo = OPT [ "when"; e = expr -> e ] -> SpTrm _loc p eo
+ | p = patt; "="; e = expr -> SpNtr _loc p e
+ | p = patt -> SpStr _loc p ] ]
;
ipatt:
[ [ i = LIDENT -> <:patt< $lid:i$ >> ] ]
;
expr: LEVEL "simple"
[ [ "fstream"; "[:"; se = LIST0 stream_expr_comp SEP ";"; ":]" ->
- <:expr< $cstream loc se$ >> ] ]
+ <:expr< $cstream _loc se$ >> ] ]
;
stream_expr_comp:
- [ [ "`"; e = expr -> SeTrm loc e
- | e = expr -> SeNtr loc e ] ]
+ [ [ "`"; e = expr -> SeTrm _loc e
+ | e = expr -> SeNtr _loc e ] ]
;
END;
(* camlp4r pa_extend.cmo q_MLast.cmo *)
-(* $Id: pa_ifdef.ml,v 1.1.6.1 2004/07/05 09:48:42 mauny Exp $ *)
+(* $Id: pa_ifdef.ml,v 1.2 2004/07/13 12:19:11 xleroy Exp $ *)
(* This module is deprecated since version 3.07; use pa_macro.ml instead *)
(* *)
(***********************************************************************)
-(* $Id: pa_o.ml,v 1.58.2.5 2005/06/02 10:40:32 mauny Exp $ *)
+(* $Id: pa_o.ml,v 1.66 2005/06/29 04:11:26 garrigue Exp $ *)
open Stdpp;
open Pcaml;
Pcaml.syntax_name.val := "OCaml";
Pcaml.no_constructors_arity.val := True;
-
do {
let odfa = Plexer.dollar_for_antiquotation.val in
Plexer.dollar_for_antiquotation.val := False;
| None -> False ]
;
-value mkumin loc f arg =
+value mkexprident _loc ids = match ids with
+ [ [] -> Stdpp.raise_with_loc _loc (Stream.Error "illegal long identifier")
+ | [ id :: ids ] ->
+ let rec loop m = fun
+ [ [ id :: ids ] -> loop <:expr< $m$ . $id$ >> ids
+ | [] -> m ]
+ in
+ loop id ids ]
+;
+
+value mkumin _loc f arg =
match (f, arg) with
[ ("-", <:expr< $int:n$ >>) when int_of_string n > 0 ->
let n = "-" ^ n in
;
-value mklistexp loc last =
+value mklistexp _loc last =
loop True where rec loop top =
fun
[ [] ->
[ Some e -> e
| None -> <:expr< [] >> ]
| [e1 :: el] ->
- let loc = if top then loc else (fst (MLast.loc_of_expr e1), snd loc) in
+ let _loc = if top then _loc else (fst (MLast.loc_of_expr e1), snd _loc) in
<:expr< [$e1$ :: $loop False el$] >> ]
;
-value mklistpat loc last =
+value mklistpat _loc last =
loop True where rec loop top =
fun
[ [] ->
[ Some p -> p
| None -> <:patt< [] >> ]
| [p1 :: pl] ->
- let loc = if top then loc else (fst (MLast.loc_of_patt p1), snd loc) in
+ let _loc = if top then _loc else (fst (MLast.loc_of_patt p1), snd _loc) in
<:patt< [$p1$ :: $loop False pl$] >> ]
;
| _ -> False ]
;
-value rec constr_expr_arity loc =
+value rec constr_expr_arity _loc =
fun
[ <:expr< $uid:c$ >> ->
try List.assoc c constr_arity.val with [ Not_found -> 0 ]
- | <:expr< $uid:_$.$e$ >> -> constr_expr_arity loc e
+ | <:expr< $uid:_$.$e$ >> -> constr_expr_arity _loc e
| <:expr< $e$ $_$ >> ->
if is_expr_constr_call e then
- Stdpp.raise_with_loc loc (Stream.Error "currified constructor")
+ Stdpp.raise_with_loc _loc (Stream.Error "currified constructor")
else 1
| _ -> 1 ]
;
| _ -> False ]
;
-value rec constr_patt_arity loc =
+value rec constr_patt_arity _loc =
fun
[ <:patt< $uid:c$ >> ->
try List.assoc c constr_arity.val with [ Not_found -> 0 ]
- | <:patt< $uid:_$.$p$ >> -> constr_patt_arity loc p
+ | <:patt< $uid:_$.$p$ >> -> constr_patt_arity _loc p
| <:patt< $p$ $_$ >> ->
if is_patt_constr_call p then
- Stdpp.raise_with_loc loc (Stream.Error "currified constructor")
+ Stdpp.raise_with_loc _loc (Stream.Error "currified constructor")
else 1
| _ -> 1 ]
;
| _ -> None ]
;
-value bigarray_get loc arr arg =
+value bigarray_get _loc arr arg =
let coords =
match arg with
[ <:expr< ($list:el$) >> -> el
| coords -> <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> ]
;
-value bigarray_set loc var newval =
+value bigarray_set _loc var newval =
match var with
[ <:expr< Bigarray.Array1.get $arr$ $c1$ >> ->
Some <:expr< Bigarray.Array1.set $arr$ $c1$ $newval$ >>
| "module"; i = UIDENT; mb = module_binding ->
<:str_item< module $i$ = $mb$ >>
| "module"; "rec"; nmtmes = LIST1 module_rec_binding SEP "and" ->
- MLast.StRecMod loc nmtmes
+ MLast.StRecMod _loc nmtmes
| "module"; "type"; i = UIDENT; "="; mt = module_type ->
<:str_item< module type $i$ = $mt$ >>
| "open"; i = mod_ident -> <:str_item< open $i$ >>
| "module"; i = UIDENT; mt = module_declaration ->
<:sig_item< module $i$ : $mt$ >>
| "module"; "rec"; mds = LIST1 module_rec_declaration SEP "and" ->
- MLast.SgRecMod loc mds
+ MLast.SgRecMod _loc mds
| "module"; "type"; i = UIDENT; "="; mt = module_type ->
<:sig_item< module type $i$ = $mt$ >>
| "module"; "type"; i = UIDENT ->
components) *)
with_constr:
[ [ "type"; tpl = type_parameters; i = mod_ident; "="; t = ctyp ->
- MLast.WcTyp loc i tpl t
+ MLast.WcTyp _loc i tpl t
| "module"; i = mod_ident; "="; me = module_expr ->
- MLast.WcMod loc i me ] ]
+ MLast.WcMod _loc i me ] ]
;
(* Core expressions *)
expr:
<:expr< while $e1$ do { $list:get_seq e2$ } >>
| "object"; cspo = OPT class_self_patt; cf = class_structure; "end" ->
(* <:expr< object $opt:cspo$ $list:cf$ end >> *)
- MLast.ExObj loc cspo cf ]
+ MLast.ExObj _loc cspo cf ]
| [ e = SELF; ","; el = LIST1 NEXT SEP "," ->
<:expr< ( $list:[e :: el]$ ) >> ]
| ":=" NONA
[ e1 = SELF; ":="; e2 = expr LEVEL "expr1" ->
<:expr< $e1$.val := $e2$ >>
| e1 = SELF; "<-"; e2 = expr LEVEL "expr1" ->
- match bigarray_set loc e1 e2 with
+ match bigarray_set _loc e1 e2 with
[ Some e -> e
| None -> <:expr< $e1$ := $e2$ >> ] ]
| "||" RIGHTA
| e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >>
| e1 = SELF; op = infixop4; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ]
| "unary minus" NONA
- [ "-"; e = SELF -> <:expr< $mkumin loc "-" e$ >>
- | "-."; e = SELF -> <:expr< $mkumin loc "-." e$ >> ]
+ [ "-"; e = SELF -> <:expr< $mkumin _loc "-" e$ >>
+ | "-."; e = SELF -> <:expr< $mkumin _loc "-." e$ >> ]
| "apply" LEFTA
[ e1 = SELF; e2 = SELF ->
- match constr_expr_arity loc e1 with
+ match constr_expr_arity _loc e1 with
[ 1 -> <:expr< $e1$ $e2$ >>
| _ ->
match e2 with
| "." LEFTA
[ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >>
| e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >>
- | e1 = SELF; "."; "{"; e2 = SELF; "}" -> bigarray_get loc e1 e2
+ | e1 = SELF; "."; "{"; e2 = SELF; "}" -> bigarray_get _loc e1 e2
| e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ]
| "~-" NONA
[ "!"; e = SELF -> <:expr< $e$ . val>>
| f = prefixop; e = SELF -> <:expr< $lid:f$ $e$ >> ]
| "simple" LEFTA
[ s = INT -> <:expr< $int:s$ >>
- | s = INT32 -> MLast.ExInt32 loc s
- | s = INT64 -> MLast.ExInt64 loc s
- | s = NATIVEINT -> MLast.ExNativeInt loc s
+ | s = INT32 -> MLast.ExInt32 _loc s
+ | s = INT64 -> MLast.ExInt64 _loc s
+ | s = NATIVEINT -> MLast.ExNativeInt _loc s
| s = FLOAT -> <:expr< $flo:s$ >>
| s = STRING -> <:expr< $str:s$ >>
| c = CHAR -> <:expr< $chr:c$ >>
| UIDENT "True" -> <:expr< $uid:" True"$ >>
| UIDENT "False" -> <:expr< $uid:" False"$ >>
- | i = expr_ident -> i
+ | ids = expr_ident -> mkexprident _loc ids
| s = "false" -> <:expr< False >>
| s = "true" -> <:expr< True >>
| "["; "]" -> <:expr< [] >>
- | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp loc None el$ >>
+ | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp _loc None el$ >>
| "[|"; "|]" -> <:expr< [| |] >>
| "[|"; el = expr1_semi_list; "|]" -> <:expr< [| $list:el$ |] >>
| "{"; test_label_eq; lel = lbl_expr_list; "}" ->
with
[ Not_found | Failure _ -> (Token.nowhere, x) ]
in
- Pcaml.handle_expr_locate loc x
+ Pcaml.handle_expr_locate _loc x
| x = QUOTATION ->
let x =
try
with
[ Not_found -> ("", x) ]
in
- Pcaml.handle_expr_quotation loc x ] ]
+ Pcaml.handle_expr_quotation _loc x ] ]
;
let_binding:
[ [ p = patt; e = fun_binding ->
match patt_lid p with
- [ Some (loc, i, pl) ->
+ [ Some (_loc, i, pl) ->
let e =
List.fold_left (fun e p -> <:expr< fun $p$ -> $e$ >>) e pl
in
;
expr_ident:
[ RIGHTA
- [ i = LIDENT -> <:expr< $lid:i$ >>
- | i = UIDENT -> <:expr< $uid:i$ >>
- | i = UIDENT; "."; j = SELF ->
- let rec loop m =
- fun
- [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y
- | e -> <:expr< $m$ . $e$ >> ]
- in
- loop <:expr< $uid:i$ >> j
+ [ i = LIDENT -> [ <:expr< $lid:i$ >> ]
+ | i = UIDENT -> [ <:expr< $uid:i$ >> ]
| i = UIDENT; "."; "("; j = operator_rparen ->
- <:expr< $uid:i$ . $lid:j$ >> ] ]
+ [ <:expr< $uid:i$ >> ; <:expr< $lid:j$ >> ]
+ | i = UIDENT; "."; j = SELF -> [ <:expr< $uid:i$ >> :: j ]
+ ]
+ ]
;
(* Patterns *)
patt:
[ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ]
| LEFTA
[ p1 = SELF; p2 = SELF ->
- match constr_patt_arity loc p1 with
+ match constr_patt_arity _loc p1 with
[ 1 -> <:patt< $p1$ $p2$ >>
| n ->
let p2 =
[ s = LIDENT -> <:patt< $lid:s$ >>
| s = UIDENT -> <:patt< $uid:s$ >>
| s = INT -> <:patt< $int:s$ >>
- | s = INT32 -> MLast.PaInt32 loc s
- | s = INT64 -> MLast.PaInt64 loc s
- | s = NATIVEINT -> MLast.PaNativeInt loc s
+ | s = INT32 -> MLast.PaInt32 _loc s
+ | s = INT64 -> MLast.PaInt64 _loc s
+ | s = NATIVEINT -> MLast.PaNativeInt _loc s
| "-"; s = INT -> <:patt< $int:"-" ^ s$ >>
- | "-"; s = INT32 -> MLast.PaInt32 loc ("-" ^ s)
- | "-"; s = INT64 -> MLast.PaInt64 loc ("-" ^ s)
- | "-"; s = NATIVEINT -> MLast.PaNativeInt loc ("-" ^ s)
+ | "-"; s = INT32 -> MLast.PaInt32 _loc ("-" ^ s)
+ | "-"; s = INT64 -> MLast.PaInt64 _loc ("-" ^ s)
+ | "-"; s = NATIVEINT -> MLast.PaNativeInt _loc ("-" ^ s)
| "-"; s = FLOAT -> <:patt< $flo:"-" ^ s$ >>
| s = FLOAT -> <:patt< $flo:s$ >>
| s = STRING -> <:patt< $str:s$ >>
| s = "false" -> <:patt< False >>
| s = "true" -> <:patt< True >>
| "["; "]" -> <:patt< [] >>
- | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat loc None pl$ >>
+ | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat _loc None pl$ >>
| "[|"; "|]" -> <:patt< [| |] >>
| "[|"; pl = patt_semi_list; "|]" -> <:patt< [| $list:pl$ |] >>
| "{"; lpl = lbl_patt_list; "}" -> <:patt< { $list:lpl$ } >>
with
[ Not_found | Failure _ -> (Token.nowhere, x) ]
in
- Pcaml.handle_patt_locate loc x
+ Pcaml.handle_patt_locate _loc x
| x = QUOTATION ->
let x =
try
with
[ Not_found -> ("", x) ]
in
- Pcaml.handle_patt_quotation loc x ] ]
+ Pcaml.handle_patt_quotation _loc x ] ]
;
patt_semi_list:
(n, tpl, <:ctyp< '$choose_tvar tpl$ >>, cl) ] ]
;
type_patt:
- [ [ n = LIDENT -> (loc, n) ] ]
+ [ [ n = LIDENT -> (_loc, n) ] ]
;
constrain:
[ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ]
;
type_kind:
- [ [ "private"; "{"; ldl = label_declarations; "}" ->
- <:ctyp< private { $list:ldl$ } >>
- | "private"; OPT "|";
- cdl = LIST1 constructor_declaration SEP "|" -> <:ctyp< private [ $list:cdl$ ] >>
+ [ [ "private"; tk = type_kind -> <:ctyp< private $tk$ >>
| test_constr_decl; OPT "|";
cdl = LIST1 constructor_declaration SEP "|" -> <:ctyp< [ $list:cdl$ ] >>
| t = ctyp -> <:ctyp< $t$ >>
- | t = ctyp; "="; "private"; "{"; ldl = label_declarations; "}" ->
- <:ctyp< $t$ == private { $list:ldl$ } >>
+ | t = ctyp; "="; "private"; tk = type_kind ->
+ <:ctyp< $t$ == private $tk$ >>
| t = ctyp; "="; "{"; ldl = label_declarations; "}" ->
<:ctyp< $t$ == { $list:ldl$ } >>
- | t = ctyp; "="; "private"; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" ->
- <:ctyp< $t$ == private [ $list:cdl$ ] >>
| t = ctyp; "="; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" ->
<:ctyp< $t$ == [ $list:cdl$ ] >>
| "{"; ldl = label_declarations; "}" ->
;
constructor_declaration:
[ [ ci = UIDENT; "of"; cal = LIST1 ctyp LEVEL "ctyp1" SEP "*" ->
- (loc, ci, cal)
- | ci = UIDENT -> (loc, ci, []) ] ]
+ (_loc, ci, cal)
+ | ci = UIDENT -> (_loc, ci, []) ] ]
;
label_declarations:
[ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl]
| ld = label_declaration -> [ld] ] ]
;
label_declaration:
- [ [ i = LIDENT; ":"; t = poly_type -> (loc, i, False, t)
- | "mutable"; i = LIDENT; ":"; t = poly_type -> (loc, i, True, t) ] ]
+ [ [ i = LIDENT; ":"; t = poly_type -> (_loc, i, False, t)
+ | "mutable"; i = LIDENT; ":"; t = poly_type -> (_loc, i, True, t) ] ]
;
(* Core types *)
ctyp:
class_declaration:
[ [ vf = OPT "virtual"; ctp = class_type_parameters; i = LIDENT;
cfb = class_fun_binding ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
+ {MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
MLast.ciNam = i; MLast.ciExp = cfb} ] ]
;
class_fun_binding:
<:class_expr< fun $p$ -> $cfb$ >> ] ]
;
class_type_parameters:
- [ [ -> (loc, [])
- | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ]
+ [ [ -> (_loc, [])
+ | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (_loc, tpl) ] ]
;
class_fun_def:
[ [ p = patt LEVEL "simple"; "->"; ce = class_expr ->
| "method"; "virtual"; l = label; ":"; t = poly_type ->
<:class_str_item< method virtual $l$ : $t$ >>
| "method"; "private"; l = label; ":"; t = poly_type; "="; e = expr ->
- MLast.CrMth loc l True e (Some t)
+ MLast.CrMth _loc l True e (Some t)
| "method"; "private"; l = label; sb = fun_binding ->
- MLast.CrMth loc l True sb None
+ MLast.CrMth _loc l True sb None
| "method"; l = label; ":"; t = poly_type; "="; e = expr ->
- MLast.CrMth loc l False e (Some t)
+ MLast.CrMth _loc l False e (Some t)
| "method"; l = label; sb = fun_binding ->
- MLast.CrMth loc l False sb None
+ MLast.CrMth _loc l False sb None
| "constraint"; t1 = ctyp; "="; t2 = ctyp ->
<:class_str_item< type $t1$ = $t2$ >>
| "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ]
class_description:
[ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; ":";
ct = class_type ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
+ {MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
MLast.ciNam = n; MLast.ciExp = ct} ] ]
;
class_type_declaration:
[ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; "=";
cs = class_signature ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
+ {MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
MLast.ciNam = n; MLast.ciExp = cs} ] ]
;
(* Expressions *)
interf:
[ [ si = sig_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
| "#"; n = LIDENT; dp = OPT expr; ";;" ->
- ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True)
+ ([(<:sig_item< # $n$ $opt:dp$ >>, _loc)], True)
| EOI -> ([], False) ] ]
;
sig_item_semi:
- [ [ si = sig_item; OPT ";;" -> (si, loc) ] ]
+ [ [ si = sig_item; OPT ";;" -> (si, _loc) ] ]
;
implem:
[ [ si = str_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
| "#"; n = LIDENT; dp = OPT expr; ";;" ->
- ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True)
+ ([(<:str_item< # $n$ $opt:dp$ >>, _loc)], True)
| EOI -> ([], False) ] ]
;
str_item_semi:
- [ [ si = str_item; OPT ";;" -> (si, loc) ] ]
+ [ [ si = str_item; OPT ";;" -> (si, _loc) ] ]
;
top_phrase:
[ [ ph = phrase; ";;" -> Some ph
| "#"; n = LIDENT; dp = OPT expr -> <:str_item< # $n$ $opt:dp$ >> ] ]
;
END;
-
-Pcaml.add_option "-no_quot" (Arg.Set Plexer.no_quotations)
- "Don't parse quotations, allowing to use, e.g. \"<:>\" as token";
(* *)
(***********************************************************************)
-(* $Id: pa_oop.ml,v 1.4 2004/05/12 15:22:40 mauny Exp $ *)
+(* $Id: pa_oop.ml,v 1.5 2004/11/17 09:07:56 mauny Exp $ *)
open Pcaml;
;
value strm_n = "strm__";
-value peek_fun loc = <:expr< Stream.peek >>;
-value junk_fun loc = <:expr< Stream.junk >>;
+value peek_fun _loc = <:expr< Stream.peek >>;
+value junk_fun _loc = <:expr< Stream.junk >>;
(* Parsers. *)
value stream_pattern_component skont =
fun
- [ SpTrm loc p wo ->
- (<:expr< $peek_fun loc$ $lid:strm_n$ >>, p, wo,
- <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >>)
- | SpNtr loc p e ->
+ [ SpTrm _loc p wo ->
+ (<:expr< $peek_fun _loc$ $lid:strm_n$ >>, p, wo,
+ <:expr< do { $junk_fun _loc$ $lid:strm_n$; $skont$ } >>)
+ | SpNtr _loc p e ->
(<:expr< try Some ($e$ $lid:strm_n$) with
[ Stream.Failure -> None ] >>,
p, None, skont)
- | SpStr loc p ->
+ | SpStr _loc p ->
(<:expr< Some $lid:strm_n$ >>, p, None, skont) ]
;
-value rec stream_pattern loc epo e ekont =
+value rec stream_pattern _loc epo e ekont =
fun
[ [] ->
match epo with
in
<:expr< raise (Stream.Error $str$) >>
in
- stream_pattern loc epo e ekont spcl
+ stream_pattern _loc epo e ekont spcl
in
let (tst, p, wo, e) = stream_pattern_component skont spc in
let ckont = ekont err in
[ Some $p$ $when:wo$ -> $e$ | _ -> $ckont$ ] >> ]
;
-value rec parser_cases loc =
+value rec parser_cases _loc =
fun
[ [] -> <:expr< raise Stream.Failure >>
| [(spcl, epo, e) :: spel] ->
- stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl ]
+ stream_pattern _loc epo e (fun _ -> parser_cases _loc spel) spcl ]
;
-value cparser loc bpo pc =
- let e = parser_cases loc pc in
+value cparser _loc bpo pc =
+ let e = parser_cases _loc pc in
let e =
match bpo with
[ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >>
<:expr< fun $p$ -> $e$ >>
;
-value cparser_match loc me bpo pc =
- let pc = parser_cases loc pc in
+value cparser_match _loc me bpo pc =
+ let pc = parser_cases _loc pc in
let e =
match bpo with
[ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
(* streams *)
-value slazy loc e = <:expr< fun _ -> $e$ >>;
+value slazy _loc e = <:expr< fun _ -> $e$ >>;
value rec cstream gloc =
fun
- [ [] -> let loc = gloc in <:expr< Stream.sempty >>
- | [SeTrm loc e :: secl] ->
- <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >>
- | [SeNtr loc e :: secl] ->
- <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ]
+ [ [] -> let _loc = gloc in <:expr< Stream.sempty >>
+ | [SeTrm _loc e :: secl] ->
+ <:expr< Stream.lcons $slazy _loc e$ $cstream gloc secl$ >>
+ | [SeNtr _loc e :: secl] ->
+ <:expr< Stream.lapp $slazy _loc e$ $cstream gloc secl$ >> ]
;
(* Syntax extensions in Ocaml grammar *)
GLOBAL: expr;
expr: LEVEL "expr1"
[ [ "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" ->
- <:expr< $cparser loc po pcl$ >>
+ <:expr< $cparser _loc po pcl$ >>
| "match"; e = expr; "with"; "parser"; po = OPT ipatt; OPT "|";
pcl = LIST1 parser_case SEP "|" ->
- <:expr< $cparser_match loc e po pcl$ >> ] ]
+ <:expr< $cparser_match _loc e po pcl$ >> ] ]
;
parser_case:
[ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr ->
;
stream_patt_comp:
[ [ "'"; p = patt; eo = OPT [ "when"; e = (expr LEVEL "expr1") -> e ] ->
- SpTrm loc p eo
- | p = patt; "="; e = (expr LEVEL "expr1") -> SpNtr loc p e
- | p = patt -> SpStr loc p ] ]
+ SpTrm _loc p eo
+ | p = patt; "="; e = (expr LEVEL "expr1") -> SpNtr _loc p e
+ | p = patt -> SpStr _loc p ] ]
;
ipatt:
[ [ i = LIDENT -> <:patt< $lid:i$ >> ] ]
expr: LEVEL "simple"
[ [ "[<"; se = LIST0 stream_expr_comp SEP ";"; ">]" ->
- <:expr< $cstream loc se$ >> ] ]
+ <:expr< $cstream _loc se$ >> ] ]
;
stream_expr_comp:
- [ [ "'"; e = expr LEVEL "expr1" -> SeTrm loc e
- | e = expr LEVEL "expr1" -> SeNtr loc e ] ]
+ [ [ "'"; e = expr LEVEL "expr1" -> SeTrm _loc e
+ | e = expr LEVEL "expr1" -> SeNtr _loc e ] ]
;
END;
(* *)
(***********************************************************************)
-(* $Id: pa_op.ml,v 1.6 2003/07/10 12:28:21 michel Exp $ *)
+(* $Id: pa_op.ml,v 1.7 2004/11/17 09:07:56 mauny Exp $ *)
open Pcaml;
;
value strm_n = "strm__";
-value peek_fun loc = <:expr< Stream.peek >>;
-value junk_fun loc = <:expr< Stream.junk >>;
+value peek_fun _loc = <:expr< Stream.peek >>;
+value junk_fun _loc = <:expr< Stream.junk >>;
(* Parsers. *)
(* In syntax generated, many cases are optimisations. *)
;
value rec subst v e =
- let loc = MLast.loc_of_expr e in
+ let _loc = MLast.loc_of_expr e in
match e with
[ <:expr< $lid:x$ >> ->
let x = if x = v then strm_n else x in
value stream_pattern_component skont ckont =
fun
- [ SpTrm loc p wo ->
- <:expr< match $peek_fun loc$ $lid:strm_n$ with
+ [ SpTrm _loc p wo ->
+ <:expr< match $peek_fun _loc$ $lid:strm_n$ with
[ Some $p$ $when:wo$ ->
- do { $junk_fun loc$ $lid:strm_n$; $skont$ }
+ do { $junk_fun _loc$ $lid:strm_n$; $skont$ }
| _ -> $ckont$ ] >>
- | SpNtr loc p e ->
+ | SpNtr _loc p e ->
let e =
match e with
[ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> e
<:expr< match try Some $e$ with [ Stream.Failure -> None ] with
[ Some $p$ -> $skont$
| _ -> $ckont$ ] >>
- | SpStr loc p ->
+ | SpStr _loc p ->
try
match p with
[ <:patt< $lid:v$ >> -> subst v skont
[ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ]
;
-value rec stream_pattern loc epo e ekont =
+value rec stream_pattern _loc epo e ekont =
fun
[ [] ->
match epo with
in
<:expr< raise (Stream.Error $str$) >>
in
- stream_pattern loc epo e ekont spcl
+ stream_pattern _loc epo e ekont spcl
in
let ckont = ekont err in stream_pattern_component skont ckont spc ]
;
-value stream_patterns_term loc ekont tspel =
+value stream_patterns_term _loc ekont tspel =
let pel =
List.map
- (fun (p, w, loc, spcl, epo, e) ->
+ (fun (p, w, _loc, spcl, epo, e) ->
let p = <:patt< Some $p$ >> in
let e =
let ekont err =
in
<:expr< raise (Stream.Error $str$) >>
in
- let skont = stream_pattern loc epo e ekont spcl in
- <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >>
+ let skont = stream_pattern _loc epo e ekont spcl in
+ <:expr< do { $junk_fun _loc$ $lid:strm_n$; $skont$ } >>
in
(p, w, e))
tspel
in
let pel = pel @ [(<:patt< _ >>, None, ekont ())] in
- <:expr< match $peek_fun loc$ $lid:strm_n$ with [ $list:pel$ ] >>
+ <:expr< match $peek_fun _loc$ $lid:strm_n$ with [ $list:pel$ ] >>
;
value rec group_terms =
fun
- [ [([(SpTrm loc p w, None) :: spcl], epo, e) :: spel] ->
+ [ [([(SpTrm _loc p w, None) :: spcl], epo, e) :: spel] ->
let (tspel, spel) = group_terms spel in
- ([(p, w, loc, spcl, epo, e) :: tspel], spel)
+ ([(p, w, _loc, spcl, epo, e) :: tspel], spel)
| spel -> ([], spel) ]
;
-value rec parser_cases loc =
+value rec parser_cases _loc =
fun
[ [] -> <:expr< raise Stream.Failure >>
| spel ->
match group_terms spel with
[ ([], [(spcl, epo, e) :: spel]) ->
- stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl
+ stream_pattern _loc epo e (fun _ -> parser_cases _loc spel) spcl
| (tspel, spel) ->
- stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel ] ]
+ stream_patterns_term _loc (fun _ -> parser_cases _loc spel) tspel ] ]
;
-value cparser loc bpo pc =
- let e = parser_cases loc pc in
+value cparser _loc bpo pc =
+ let e = parser_cases _loc pc in
let e =
match bpo with
[ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >>
<:expr< fun $p$ -> $e$ >>
;
-value cparser_match loc me bpo pc =
- let pc = parser_cases loc pc in
+value cparser_match _loc me bpo pc =
+ let pc = parser_cases _loc pc in
let e =
match bpo with
[ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
| _ -> False ]
;
-value slazy loc e =
+value slazy _loc e =
match e with
[ <:expr< $f$ () >> ->
match f with
value rec cstream gloc =
fun
- [ [] -> let loc = gloc in <:expr< Stream.sempty >>
- | [SeTrm loc e] ->
+ [ [] -> let _loc = gloc in <:expr< Stream.sempty >>
+ | [SeTrm _loc e] ->
if not_computing e then <:expr< Stream.ising $e$ >>
- else <:expr< Stream.lsing $slazy loc e$ >>
- | [SeTrm loc e :: secl] ->
+ else <:expr< Stream.lsing $slazy _loc e$ >>
+ | [SeTrm _loc e :: secl] ->
if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >>
- else <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >>
- | [SeNtr loc e] ->
- if not_computing e then e else <:expr< Stream.slazy $slazy loc e$ >>
- | [SeNtr loc e :: secl] ->
+ else <:expr< Stream.lcons $slazy _loc e$ $cstream gloc secl$ >>
+ | [SeNtr _loc e] ->
+ if not_computing e then e else <:expr< Stream.slazy $slazy _loc e$ >>
+ | [SeNtr _loc e :: secl] ->
if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >>
- else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ]
+ else <:expr< Stream.lapp $slazy _loc e$ $cstream gloc secl$ >> ]
;
(* Syntax extensions in Ocaml grammar *)
GLOBAL: expr;
expr: LEVEL "expr1"
[ [ "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" ->
- <:expr< $cparser loc po pcl$ >>
+ <:expr< $cparser _loc po pcl$ >>
| "match"; e = expr; "with"; "parser"; po = OPT ipatt; OPT "|";
pcl = LIST1 parser_case SEP "|" ->
- <:expr< $cparser_match loc e po pcl$ >> ] ]
+ <:expr< $cparser_match _loc e po pcl$ >> ] ]
;
parser_case:
[ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr ->
;
stream_patt_comp:
[ [ "'"; p = patt; eo = OPT [ "when"; e = (expr LEVEL "expr1") -> e ] ->
- SpTrm loc p eo
- | p = patt; "="; e = (expr LEVEL "expr1") -> SpNtr loc p e
- | p = patt -> SpStr loc p ] ]
+ SpTrm _loc p eo
+ | p = patt; "="; e = (expr LEVEL "expr1") -> SpNtr _loc p e
+ | p = patt -> SpStr _loc p ] ]
;
stream_patt_comp_err:
[ [ spc = stream_patt_comp;
;
expr: LEVEL "simple"
- [ [ "[<"; ">]" -> <:expr< $cstream loc []$ >>
+ [ [ "[<"; ">]" -> <:expr< $cstream _loc []$ >>
| "[<"; sel = stream_expr_comp_list; ">]" ->
- <:expr< $cstream loc sel$ >> ] ]
+ <:expr< $cstream _loc sel$ >> ] ]
;
stream_expr_comp_list:
[ [ se = stream_expr_comp; ";"; sel = stream_expr_comp_list -> [se :: sel]
| se = stream_expr_comp -> [se] ] ]
;
stream_expr_comp:
- [ [ "'"; e = expr LEVEL "expr1" -> SeTrm loc e
- | e = expr LEVEL "expr1" -> SeNtr loc e ] ]
+ [ [ "'"; e = expr LEVEL "expr1" -> SeTrm _loc e
+ | e = expr LEVEL "expr1" -> SeNtr _loc e ] ]
;
END;
(* *)
(***********************************************************************)
-(* $Id: pa_ru.ml,v 1.7 2003/07/10 12:28:21 michel Exp $ *)
+(* $Id: pa_ru.ml,v 1.8 2004/11/17 09:07:56 mauny Exp $ *)
open Pcaml;
in
[<:expr< let $opt:o2b o$ $list:l$ in $e$ >>]
| e = expr; ";"; el = SELF ->
- let e = let loc = MLast.loc_of_expr e in <:expr< ($e$ : unit) >> in
+ let e = let _loc = MLast.loc_of_expr e in <:expr< ($e$ : unit) >> in
[e :: el]
| e = expr; ";" -> [e]
| e = expr -> [e] ] ]
(* camlp4r q_MLast.cmo *)
-(* $Id: parserify.ml,v 1.2 2004/05/12 15:22:40 mauny Exp $ *)
+(* $Id: parserify.ml,v 1.3 2004/11/17 09:07:56 mauny Exp $ *)
-value loc = (Token.nowhere, Token.nowhere);
+value _loc = (Token.nowhere, Token.nowhere);
type spc =
[ SPCterm of (MLast.patt * option MLast.expr)
(* camlp4r *)
-(* $Id: pr_depend.ml,v 1.13 2003/07/23 22:26:17 doligez Exp $ *)
+(* $Id: pr_depend.ml,v 1.14 2005/06/29 04:11:26 garrigue Exp $ *)
open MLast;
| TyMan _ t1 t2 -> do { ctyp t1; ctyp t2; }
| TyOlb _ _ t -> ctyp t
| TyQuo _ _ -> ()
- | TyRec _ _ ldl -> list label_decl ldl
- | TySum _ _ cdl -> list constr_decl cdl
+ | TyRec _ ldl -> list label_decl ldl
+ | TySum _ cdl -> list constr_decl cdl
+ | TyPrv _ t -> ctyp t
| TyTup _ tl -> list ctyp tl
| TyVrn _ sbtll _ -> list variant sbtll
| x -> not_impl "ctyp" x ]
(* *)
(***********************************************************************)
-(* $Id: pr_extend.ml,v 1.13 2004/05/12 15:22:40 mauny Exp $ *)
+(* $Id: pr_extend.ml,v 1.14 2004/11/17 09:07:56 mauny Exp $ *)
open Pcaml;
open Spretty;
let (pl, a) = unaction e in ([p :: pl], a)
| <:expr< fun _ -> $e$ >> ->
let (pl, a) = unaction e in
- (let loc = (Token.nowhere, Token.nowhere) in [<:patt< _ >> :: pl], a)
+ (let _loc = (Token.nowhere, Token.nowhere) in [<:patt< _ >> :: pl], a)
| _ -> raise Not_found ]
;
[ <:expr< ($e1$, Gramext.action $e2$) >> ->
let (pl, a) =
match unaction e2 with
- [ ([], None) -> let loc = (Token.nowhere, Token.nowhere) in ([], Some <:expr< () >>)
+ [ ([], None) -> let _loc = (Token.nowhere, Token.nowhere) in ([], Some <:expr< () >>)
| x -> x ]
in
let sl = unpsymbol_list (List.rev pl) e1 in
(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
-(* $Id: pr_extfun.ml,v 1.3 2004/05/12 15:22:40 mauny Exp $ *)
+(* $Id: pr_extfun.ml,v 1.4 2004/11/17 09:07:56 mauny Exp $ *)
open Pcaml;
open Spretty;
-value loc = (Token.nowhere, Token.nowhere);
+value _loc = (Token.nowhere, Token.nowhere);
value expr e dg k = pr_expr.pr_fun "top" e dg k;
value patt e dg k = pr_patt.pr_fun "top" e dg k;
(* *)
(***********************************************************************)
-(* $Id: pr_o.ml,v 1.45.2.2 2005/06/29 13:37:13 mauny Exp $ *)
+(* $Id: pr_o.ml,v 1.49 2005/08/13 20:59:37 doligez Exp $ *)
open Pcaml;
open Spretty;
(* default global loc *)
-value loc = (Token.nowhere, Token.nowhere);
+value _loc = (Token.nowhere, Token.nowhere);
value id_var s =
if has_special_chars s || is_infix s then
fun curr next dg k -> [: `not_impl "sig_item" si :]
| <:sig_item< exception $c$ of $list:tl$ >> ->
fun curr next dg k ->
- [: `variant [: `S LR "exception" :] (loc, c, tl) "" k :]
+ [: `variant [: `S LR "exception" :] (_loc, c, tl) "" k :]
| <:sig_item< value $s$ : $t$ >> ->
fun curr next dg k -> [: `value_description (s, t) "" k :]
| <:sig_item< external $s$ : $t$ = $list:pl$ >> ->
| <:str_item< exception $c$ of $list:tl$ = $b$ >> ->
fun curr next dg k ->
match b with
- [ [] -> [: `variant [: `S LR "exception" :] (loc, c, tl) "" k :]
+ [ [] -> [: `variant [: `S LR "exception" :] (_loc, c, tl) "" k :]
| _ ->
- [: `variant [: `S LR "exception" :] (loc, c, tl) ""
+ [: `variant [: `S LR "exception" :] (_loc, c, tl) ""
[: `S LR "=" :];
mod_ident b "" k :] ]
| <:str_item< include $me$ >> ->
fun curr next dg k -> [: `S LR "assert"; `next e "" k :]
| <:expr< $lid:n$ $x$ $y$ >> as e ->
fun curr next dg k ->
- let loc = MLast.loc_of_expr e in
+ let _loc = MLast.loc_of_expr e in
if is_infix n then [: `next e "" k :]
else [: curr <:expr< $lid:n$ $x$ >> "" [: :]; `next y "" k :]
| <:expr< $x$ $y$ >> ->
fun curr next dg k -> [: `S LR (var_escaped s); k :]
| <:ctyp< $uid:s$ >> -> fun curr next dg k -> [: `S LR s; k :]
| <:ctyp< _ >> -> fun curr next dg k -> [: `S LR "_"; k :]
- | <:ctyp< private { $list:ftl$ } >> as t ->
- fun curr next dg k ->
- let loc = MLast.loc_of_ctyp t in
- [: `HVbox
- [: `HVbox [:`S LR "private" :];
- `HVbox [: labels loc [:`S LR "{" :]
- ftl "" [: `S LR "}" :] :];
- k :] :]
| <:ctyp< { $list:ftl$ } >> as t ->
fun curr next dg k ->
let loc = MLast.loc_of_ctyp t in
[: `HVbox
[: labels loc [: `S LR "{" :] ftl "" [: `S LR "}" :];
k :] :]
- | <:ctyp< private [ $list:ctl$ ] >> as t ->
+ | <:ctyp< private $ty$ >> ->
fun curr next dg k ->
- let loc = MLast.loc_of_ctyp t in
- [: `Vbox
- [: `HVbox [: `S LR "private" :];
- variants loc [: `S LR " " :] ctl "" [: :];
- k :] :]
+ [: `HVbox
+ [: `HVbox [:`S LR "private" :];
+ `ctyp ty "" k :] :]
| <:ctyp< [ $list:ctl$ ] >> as t ->
fun curr next dg k ->
let loc = MLast.loc_of_ctyp t in
(* *)
(***********************************************************************)
-(* $Id: pr_op.ml,v 1.4 2002/07/19 14:53:47 mauny Exp $ *)
+(* $Id: pr_op.ml,v 1.5 2004/11/17 09:07:56 mauny Exp $ *)
open Pcaml;
open Spretty;
-value loc = (0, 0);
-
value expr e dg k = pr_expr.pr_fun "top" e dg k;
value patt e dg k = pr_patt.pr_fun "top" e dg k;
(* *)
(***********************************************************************)
-(* $Id: pr_op_main.ml,v 1.2 2004/05/12 15:22:40 mauny Exp $ *)
+(* $Id: pr_op_main.ml,v 1.3 2004/11/17 09:07:56 mauny Exp $ *)
open Pcaml;
open Spretty;
-value loc = (Token.nowhere, Token.nowhere);
+value _loc = (Token.nowhere, Token.nowhere);
value expr e dg k = pr_expr.pr_fun "top" e dg k;
value patt e dg k = pr_patt.pr_fun "top" e dg k;
(* *)
(***********************************************************************)
-(* $Id: pr_r.ml,v 1.48.2.2 2005/06/20 16:49:01 mauny Exp $ *)
+(* $Id: pr_r.ml,v 1.53 2005/08/13 20:59:37 doligez Exp $ *)
open Pcaml;
open Spretty;
(* default global loc *)
-value loc = (Token.nowhere, Token.nowhere);
+value _loc = (Token.nowhere, Token.nowhere);
(* extensible printers *)
fun curr next _ k -> [: `not_impl "sig_item1" si :]
| <:sig_item< exception $c$ of $list:tl$ >> ->
fun curr next _ k ->
- [: `variant [: `S LR "exception" :] (loc, c, tl) k :]
+ [: `variant [: `S LR "exception" :] (_loc, c, tl) k :]
| <:sig_item< value $s$ : $t$ >> ->
fun curr next _ k -> [: `value_description s t k :]
| <:sig_item< include $mt$ >> ->
| <:str_item< exception $c$ of $list:tl$ = $b$ >> ->
fun curr next _ k ->
match b with
- [ [] -> [: `variant [: `S LR "exception" :] (loc, c, tl) k :]
+ [ [] -> [: `variant [: `S LR "exception" :] (_loc, c, tl) k :]
| _ ->
- [: `variant [: `S LR "exception" :] (loc, c, tl)
+ [: `variant [: `S LR "exception" :] (_loc, c, tl)
[: `S LR "=" :];
mod_ident b k :] ]
| <:str_item< include $me$ >> ->
else
match uncurry_expr x y with
[ (f, ( [_;_::_] as args )) ->
- fun curr next _ k ->
+ fun curr next _ k ->
[: curr f "" [: :];
`HOVCbox
[: `S LO "(";
fun curr next _ k -> [: `S LR (var_escaped s); k :]
| <:ctyp< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :]
| <:ctyp< _ >> -> fun curr next _ k -> [: `S LR "_"; k :]
- | <:ctyp< private { $list: ftl$ } >> as t ->
- fun curr next _ k ->
- let loc = MLast.loc_of_ctyp t in
- [: `HVbox
- [: `HVbox [:`S LR "private" :];
- `HVbox [: labels loc [:`S LR "{" :]
- ftl [: `S LR "}" :] :];
- k :] :]
+ | <:ctyp< private $ty$ >> ->
+ fun curr next dg k ->
+ [: `HVbox
+ [: `HVbox [:`S LR "private" :];
+ `ctyp ty k :] :]
| <:ctyp< { $list: ftl$ } >> as t ->
fun curr next _ k ->
let loc = MLast.loc_of_ctyp t in
[: `Vbox
[: `HVbox [: :];
variants loc [: `S LR "[" :] ctl [: `S LR "]" :]; k :] :]
- | <:ctyp< private [ $list:ctl$ ] >> as t ->
- fun curr next _ k ->
- let loc = MLast.loc_of_ctyp t in
- [: `Vbox
- [: `HVbox [: `S LR "private" :];
- variants loc [: `S LR "[" :] ctl [: `S LR "]" :]; k :] :]
| <:ctyp< [ = $list:rfl$ ] >> ->
fun curr next _ k ->
[: `HVbox
(* *)
(***********************************************************************)
-(* $Id: pr_rp.ml,v 1.5 2004/05/12 15:22:41 mauny Exp $ *)
+(* $Id: pr_rp.ml,v 1.6 2004/11/17 09:07:56 mauny Exp $ *)
open Pcaml;
open Spretty;
-value loc = (Token.nowhere, Token.nowhere);
+value _loc = (Token.nowhere, Token.nowhere);
value expr e dg k = pr_expr.pr_fun "top" e dg k;
value patt e dg k = pr_patt.pr_fun "top" e dg k;
(* *)
(***********************************************************************)
-(* $Id: pr_rp_main.ml,v 1.2 2004/05/12 15:22:41 mauny Exp $ *)
+(* $Id: pr_rp_main.ml,v 1.3 2004/11/17 09:07:56 mauny Exp $ *)
open Pcaml;
open Spretty;
-value loc = (Token.nowhere, Token.nowhere);
+value _loc = (Token.nowhere, Token.nowhere);
value expr e dg k = pr_expr.pr_fun "top" e dg k;
value patt e dg k = pr_patt.pr_fun "top" e dg k;
(* *)
(***********************************************************************)
-(* $Id: q_phony.ml,v 1.4 2004/05/12 15:22:41 mauny Exp $ *)
+(* $Id: q_phony.ml,v 1.5 2004/11/17 09:07:56 mauny Exp $ *)
open Pcaml;
if t.val = "" then "<<" ^ s ^ ">>"
else "<:" ^ t.val ^ "<" ^ s ^ ">>"
in
- let loc = (Token.nowhere, Token.nowhere) in
+ let _loc = (Token.nowhere, Token.nowhere) in
<:expr< $uid:t$ >>,
fun s ->
let t =
if t.val = "" then "<<" ^ s ^ ">>"
else "<:" ^ t.val ^ "<" ^ s ^ ">>"
in
- let loc = (Token.nowhere, Token.nowhere) in
+ let _loc = (Token.nowhere, Token.nowhere) in
<:patt< $uid:t$ >>))
;
-# $Id: Makefile,v 1.8.2.6 2004/07/28 13:55:43 mauny Exp $
+# $Id: Makefile,v 1.15 2004/11/30 18:57:03 doligez Exp $
include ../config/Makefile
SHELL=/bin/sh
TARGET=gramlib.cma
+.PHONY: opt all clean depend promote compare install installopt
+
all: $(TARGET)
opt: opt$(PROFILING)
(* camlp4r *)
-(* $Id: extfun.ml,v 1.3 2003/07/10 12:28:24 michel Exp $ *)
+(* $Id: extfun.ml,v 1.4 2005/06/29 13:19:14 mauny Exp $ *)
(* Copyright 2001 INRIA *)
(* Extensible Functions *)
let rec loop =
fun
[ [m :: ml] as gml ->
- if m1.has_when && not m.has_when then [m1 :: gml]
- else if not m1.has_when && m.has_when then [m :: loop ml]
- else
- let c = compare m1.patt m.patt in
- if c < 0 then [m1 :: gml]
- else if c > 0 then [m :: loop ml]
- else if m.has_when then [m1 :: gml]
- else [m1 :: ml]
+ if m1.has_when && not m.has_when then [m1 :: gml] else
+ if not m1.has_when && m.has_when then [m :: loop ml] else
+ (* either both or none have a when clause *)
+ if compare m1.patt m.patt = 0 then
+ if not m1.has_when then [m1 :: ml] else [m1 :: gml]
+ else [m :: loop ml]
| [] -> [m1] ]
in
loop matchings
(* *)
(***********************************************************************)
-(* $Id: grammar.ml,v 1.12.2.2 2004/11/22 13:41:24 mauny Exp $ *)
+(* $Id: grammar.ml,v 1.14 2005/03/24 17:20:53 doligez Exp $ *)
open Stdpp;
open Gramext;
value rec get_token_list entry tokl last_tok tree =
match tree with
- [ Node {node = (Stoken tok as s); son = son; brother = DeadEnd} ->
+ [ Node {node = Stoken tok; son = son; brother = DeadEnd} ->
get_token_list entry [last_tok :: tokl] tok son
| _ ->
if tokl = [] then None
(* *)
(***********************************************************************)
-(* $Id: grammar.mli,v 1.6.2.1 2004/11/22 13:41:24 mauny Exp $ *)
+(* $Id: grammar.mli,v 1.7 2005/03/24 17:20:53 doligez Exp $ *)
(** Extensible grammars.
(* *)
(***********************************************************************)
-(* $Id: plexer.ml,v 1.20.2.6 2005/04/14 07:22:06 mauny Exp $ *)
+(* $Id: plexer.ml,v 1.26 2005/10/21 10:55:32 mauny Exp $ *)
open Stdpp;
open Token;
[ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep ->
let id = get_buff len in
match s with parser
- [ [: `':' :] eb -> error_if_keyword (("LABEL", id), (bp, ep))
+ [ [: `':' :] ep -> error_if_keyword (("LABEL", id), (bp, ep))
| [: :] -> error_if_keyword (("TILDEIDENT", id), (bp, ep)) ]
| [: s :] ->
let id = get_buff (ident2 (store 0 c) s) in
[ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep ->
let id = get_buff len in
match s with parser
- [ [: `':' :] eb -> error_if_keyword (("OPTLABEL", id), (bp,ep))
+ [ [: `':' :] ep -> error_if_keyword (("OPTLABEL", id), (bp,ep))
| [: :] -> error_if_keyword (("QUESTIONIDENT", id), (bp, ep)) ]
| [: s :] ->
let id = get_buff (ident2 (store 0 c) s) in
| _ -> False ]
and any_to_nl =
parser
- [ [: `'\010'; s :] ep ->
+ [ [: `'\010'; _s :] ep ->
do { bolpos.val := ep; incr lnum }
| [: `'\013'; s :] ep ->
let ep =
[ [: _ = skip_spaces; n = line_directive_number 0;
_ = skip_spaces; _ = line_directive_string;
_ = any_to_nl :] ep
- -> do { bolpos.val := ep; lnum.val := n }
+ -> do { (* fname has been updated by by line_directive_string *)
+ bolpos.val := ep; lnum.val := n
+ }
]
and skip_spaces = parser
[ [: `' ' | '\t'; s :] -> skip_spaces s
_ =
parser
[ [: `']' | ':' | '=' | '>' :] -> ()
- | [: :] -> () ] :] ep ->
+ | [: :] -> () ] :] ->
()
| [: `'>' | '|';
_ =
(* *)
(***********************************************************************)
-(* $Id: plexer.mli,v 1.7.4.1 2004/10/07 09:18:13 mauny Exp $ *)
+(* $Id: plexer.mli,v 1.8 2005/03/24 17:20:53 doligez Exp $ *)
(** A lexical analyzer. *)
(* *)
(***********************************************************************)
-(* $Id: stdpp.ml,v 1.5 2004/05/12 15:22:42 mauny Exp $ *)
+(* $Id: stdpp.ml,v 1.6 2004/11/17 09:07:56 mauny Exp $ *)
exception Exc_located of Token.flocation and exn;
;
*)
-value loc_name = ref "loc";
+value loc_name = ref "_loc";
(* *)
(***********************************************************************)
-(* $Id: token.ml,v 1.11.2.1 2004/06/28 18:30:48 mauny Exp $ *)
+(* $Id: token.ml,v 1.13 2004/11/06 20:13:41 doligez Exp $ *)
type t = (string * string);
type pattern = (string * string);
| '\\' -> ('\\', i + 1)
| '"' -> ('"', i + 1)
| ''' -> (''', i + 1)
+ | ' ' -> (' ', i + 1)
| '0'..'9' as c -> backslash1 (valch c) s (i + 1)
| 'x' -> backslash1h s (i + 1)
| _ -> raise Not_found ]
-# $Id: Makefile,v 1.15.2.1 2004/07/12 10:05:21 garrigue Exp $
+# $Id: Makefile,v 1.18 2004/11/30 18:57:03 doligez Exp $
include ../config/Makefile
(* *)
(***********************************************************************)
-(* $Id: pa_extend.ml,v 1.33 2004/05/12 15:22:43 mauny Exp $ *)
+(* $Id: pa_extend.ml,v 1.34 2004/11/17 09:07:56 mauny Exp $ *)
open Stdpp;
}
;
-value locate n = let loc = n.loc in <:expr< $n.expr$ >>;
+value locate n = let _loc = n.loc in <:expr< $n.expr$ >>;
value new_type_var =
let i = ref 0 in fun () -> do { incr i; "e__" ^ string_of_int i.val }
rl
;
-value retype_rule_list_without_patterns loc rl =
+value retype_rule_list_without_patterns _loc rl =
try
List.map
(fun
in
failwith (f ^ ", not impl: " ^ desc)
;
- value loc =
+ value _loc =
let nowhere =
{ (Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0 } in
(nowhere, nowhere);
(nowhere, nowhere) >>;
value rec mexpr =
fun
- [ MLast.ExAcc loc e1 e2 ->
+ [ MLast.ExAcc _loc e1 e2 ->
<:expr< MLast.ExAcc $mloc$ $mexpr e1$ $mexpr e2$ >>
- | MLast.ExApp loc e1 e2 ->
+ | MLast.ExApp _loc e1 e2 ->
<:expr< MLast.ExApp $mloc$ $mexpr e1$ $mexpr e2$ >>
- | MLast.ExChr loc s -> <:expr< MLast.ExChr $mloc$ $str:s$ >>
- | MLast.ExFun loc pwel -> <:expr< MLast.ExFun $mloc$ $mlist mpwe pwel$ >>
- | MLast.ExIfe loc e1 e2 e3 ->
+ | MLast.ExChr _loc s -> <:expr< MLast.ExChr $mloc$ $str:s$ >>
+ | MLast.ExFun _loc pwel -> <:expr< MLast.ExFun $mloc$ $mlist mpwe pwel$ >>
+ | MLast.ExIfe _loc e1 e2 e3 ->
<:expr< MLast.ExIfe $mloc$ $mexpr e1$ $mexpr e2$ $mexpr e3$ >>
- | MLast.ExInt loc s -> <:expr< MLast.ExInt $mloc$ $str:s$ >>
- | MLast.ExFlo loc s -> <:expr< MLast.ExFlo $mloc$ $str:s$ >>
- | MLast.ExLet loc rf pel e ->
+ | MLast.ExInt _loc s -> <:expr< MLast.ExInt $mloc$ $str:s$ >>
+ | MLast.ExFlo _loc s -> <:expr< MLast.ExFlo $mloc$ $str:s$ >>
+ | MLast.ExLet _loc rf pel e ->
<:expr< MLast.ExLet $mloc$ $mbool rf$ $mlist mpe pel$ $mexpr e$ >>
- | MLast.ExLid loc s -> <:expr< MLast.ExLid $mloc$ $str:s$ >>
- | MLast.ExMat loc e pwel ->
+ | MLast.ExLid _loc s -> <:expr< MLast.ExLid $mloc$ $str:s$ >>
+ | MLast.ExMat _loc e pwel ->
<:expr< MLast.ExMat $mloc$ $mexpr e$ $mlist mpwe pwel$ >>
- | MLast.ExRec loc pel eo ->
+ | MLast.ExRec _loc pel eo ->
<:expr< MLast.ExRec $mloc$ $mlist mpe pel$ $moption mexpr eo$ >>
- | MLast.ExSeq loc el -> <:expr< MLast.ExSeq $mloc$ $mlist mexpr el$ >>
- | MLast.ExSte loc e1 e2 ->
+ | MLast.ExSeq _loc el -> <:expr< MLast.ExSeq $mloc$ $mlist mexpr el$ >>
+ | MLast.ExSte _loc e1 e2 ->
<:expr< MLast.ExSte $mloc$ $mexpr e1$ $mexpr e2$ >>
- | MLast.ExStr loc s ->
+ | MLast.ExStr _loc s ->
<:expr< MLast.ExStr $mloc$ $str:String.escaped s$ >>
- | MLast.ExTry loc e pwel ->
+ | MLast.ExTry _loc e pwel ->
<:expr< MLast.ExTry $mloc$ $mexpr e$ $mlist mpwe pwel$ >>
- | MLast.ExTup loc el -> <:expr< MLast.ExTup $mloc$ $mlist mexpr el$ >>
- | MLast.ExTyc loc e t ->
+ | MLast.ExTup _loc el -> <:expr< MLast.ExTup $mloc$ $mlist mexpr el$ >>
+ | MLast.ExTyc _loc e t ->
<:expr< MLast.ExTyc $mloc$ $mexpr e$ $mctyp t$ >>
- | MLast.ExUid loc s -> <:expr< MLast.ExUid $mloc$ $str:s$ >>
+ | MLast.ExUid _loc s -> <:expr< MLast.ExUid $mloc$ $str:s$ >>
| x -> not_impl "mexpr" x ]
and mpatt =
fun
- [ MLast.PaAcc loc p1 p2 ->
+ [ MLast.PaAcc _loc p1 p2 ->
<:expr< MLast.PaAcc $mloc$ $mpatt p1$ $mpatt p2$ >>
- | MLast.PaAny loc -> <:expr< MLast.PaAny $mloc$ >>
- | MLast.PaApp loc p1 p2 ->
+ | MLast.PaAny _loc -> <:expr< MLast.PaAny $mloc$ >>
+ | MLast.PaApp _loc p1 p2 ->
<:expr< MLast.PaApp $mloc$ $mpatt p1$ $mpatt p2$ >>
- | MLast.PaInt loc s -> <:expr< MLast.PaInt $mloc$ $str:s$ >>
- | MLast.PaLid loc s -> <:expr< MLast.PaLid $mloc$ $str:s$ >>
- | MLast.PaOrp loc p1 p2 ->
+ | MLast.PaInt _loc s -> <:expr< MLast.PaInt $mloc$ $str:s$ >>
+ | MLast.PaLid _loc s -> <:expr< MLast.PaLid $mloc$ $str:s$ >>
+ | MLast.PaOrp _loc p1 p2 ->
<:expr< MLast.PaOrp $mloc$ $mpatt p1$ $mpatt p2$ >>
- | MLast.PaStr loc s ->
+ | MLast.PaStr _loc s ->
<:expr< MLast.PaStr $mloc$ $str:String.escaped s$ >>
- | MLast.PaTup loc pl -> <:expr< MLast.PaTup $mloc$ $mlist mpatt pl$ >>
- | MLast.PaTyc loc p t ->
+ | MLast.PaTup _loc pl -> <:expr< MLast.PaTup $mloc$ $mlist mpatt pl$ >>
+ | MLast.PaTyc _loc p t ->
<:expr< MLast.PaTyc $mloc$ $mpatt p$ $mctyp t$ >>
- | MLast.PaUid loc s -> <:expr< MLast.PaUid $mloc$ $str:s$ >>
+ | MLast.PaUid _loc s -> <:expr< MLast.PaUid $mloc$ $str:s$ >>
| x -> not_impl "mpatt" x ]
and mctyp =
fun
- [ MLast.TyAcc loc t1 t2 ->
+ [ MLast.TyAcc _loc t1 t2 ->
<:expr< MLast.TyAcc $mloc$ $mctyp t1$ $mctyp t2$ >>
| MLast.TyApp loc t1 t2 ->
<:expr< MLast.TyApp $mloc$ $mctyp t1$ $mctyp t2$ >>
- | MLast.TyLid loc s -> <:expr< MLast.TyLid $mloc$ $str:s$ >>
- | MLast.TyQuo loc s -> <:expr< MLast.TyQuo $mloc$ $str:s$ >>
- | MLast.TyTup loc tl -> <:expr< MLast.TyTup $mloc$ $mlist mctyp tl$ >>
- | MLast.TyUid loc s -> <:expr< MLast.TyUid $mloc$ $str:s$ >>
+ | MLast.TyLid _loc s -> <:expr< MLast.TyLid $mloc$ $str:s$ >>
+ | MLast.TyQuo _loc s -> <:expr< MLast.TyQuo $mloc$ $str:s$ >>
+ | MLast.TyTup _loc tl -> <:expr< MLast.TyTup $mloc$ $mlist mctyp tl$ >>
+ | MLast.TyUid _loc s -> <:expr< MLast.TyUid $mloc$ $str:s$ >>
| x -> not_impl "mctyp" x ]
and mpe (p, e) = <:expr< ($mpatt p$, $mexpr e$) >>
and mpwe (p, w, e) = <:expr< ($mpatt p$, $moption mexpr w$, $mexpr e$) >>
end
;
-value mklistexp loc =
+value mklistexp _loc =
loop True where rec loop top =
fun
[ [] -> <:expr< [] >>
| [e1 :: el] ->
- let loc =
- if top then loc else (fst (MLast.loc_of_expr e1), snd loc)
+ let _loc =
+ if top then _loc else (fst (MLast.loc_of_expr e1), snd _loc)
in
<:expr< [$e1$ :: $loop False el$] >> ]
;
-value mklistpat loc =
+value mklistpat _loc =
loop True where rec loop top =
fun
[ [] -> <:patt< [] >>
| [p1 :: pl] ->
- let loc =
- if top then loc else (fst (MLast.loc_of_patt p1), snd loc)
+ let _loc =
+ if top then _loc else (fst (MLast.loc_of_patt p1), snd _loc)
in
<:patt< [$p1$ :: $loop False pl$] >> ]
;
;
value rec quot_expr e =
- let loc = MLast.loc_of_expr e in
+ let _loc = MLast.loc_of_expr e in
match e with
[ <:expr< None >> -> <:expr< Qast.Option None >>
| <:expr< Some $e$ >> -> <:expr< Qast.Option (Some $quot_expr e$) >>
match f with
[ <:expr< $uid:c$ >> ->
let al = List.map quot_expr al in
- <:expr< Qast.Node $str:c$ $mklistexp loc al$ >>
+ <:expr< Qast.Node $str:c$ $mklistexp _loc al$ >>
| <:expr< MLast.$uid:c$ >> ->
let al = List.map quot_expr al in
- <:expr< Qast.Node $str:c$ $mklistexp loc al$ >>
+ <:expr< Qast.Node $str:c$ $mklistexp _loc al$ >>
| <:expr< $uid:m$.$uid:c$ >> ->
let al = List.map quot_expr al in
- <:expr< Qast.Node $str:m ^ "." ^ c$ $mklistexp loc al$ >>
+ <:expr< Qast.Node $str:m ^ "." ^ c$ $mklistexp _loc al$ >>
| <:expr< $lid:f$ >> ->
let al = List.map quot_expr al in
List.fold_left (fun f e -> <:expr< $f$ $e$ >>)
<:expr< ($lab$, $quot_expr e$) >>)
pel
in
- <:expr< Qast.Record $mklistexp loc lel$>>
+ <:expr< Qast.Record $mklistexp _loc lel$>>
with
[ Not_found -> e ]
| <:expr< $lid:s$ >> ->
| <:expr< $str:s$ >> -> <:expr< Qast.Str $str:s$ >>
| <:expr< ($list:el$) >> ->
let el = List.map quot_expr el in
- <:expr< Qast.Tuple $mklistexp loc el$ >>
+ <:expr< Qast.Tuple $mklistexp _loc el$ >>
| <:expr< let $opt:r$ $list:pel$ in $e$ >> ->
let pel = List.map (fun (p, e) -> (p, quot_expr e)) pel in
<:expr< let $opt:r$ $list:pel$ in $quot_expr e$ >>
(fun e ps ->
match ps.pattern with
[ Some <:patt< ($list:pl$) >> ->
- let loc =
+ let _loc =
let nowhere =
{ (Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0 } in
(nowhere, nowhere) in
<:expr<
let ($list:pl$) =
match $lid:pname$ with
- [ Qast.Tuple $mklistpat loc pl1$ -> ($list:el1$)
+ [ Qast.Tuple $mklistpat _loc pl1$ -> ($list:el1$)
| _ -> match () with [] ]
in $e$ >>
| _ -> e ])
value rec make_ctyp styp tvar =
match styp with
- [ STlid loc s -> <:ctyp< $lid:s$ >>
- | STapp loc t1 t2 -> <:ctyp< $make_ctyp t1 tvar$ $make_ctyp t2 tvar$ >>
- | STquo loc s -> <:ctyp< '$s$ >>
- | STself loc x ->
+ [ STlid _loc s -> <:ctyp< $lid:s$ >>
+ | STapp _loc t1 t2 -> <:ctyp< $make_ctyp t1 tvar$ $make_ctyp t2 tvar$ >>
+ | STquo _loc s -> <:ctyp< '$s$ >>
+ | STself _loc x ->
if tvar = "" then
- Stdpp.raise_with_loc loc
+ Stdpp.raise_with_loc _loc
(Stream.Error ("'" ^ x ^ "' illegal in anonymous entry level"))
else <:ctyp< '$tvar$ >>
| STtyp t -> t ]
value rec make_expr gmod tvar =
fun
- [ TXmeta loc n tl e t ->
+ [ TXmeta _loc n tl e t ->
let el =
List.fold_right
(fun t el -> <:expr< [$make_expr gmod "" t$ :: $el$] >>)
in
<:expr<
Gramext.Smeta $str:n$ $el$ (Obj.repr ($e$ : $make_ctyp t tvar$)) >>
- | TXlist loc min t ts ->
+ | TXlist _loc min t ts ->
let txt = make_expr gmod "" t in
match (min, ts) with
[ (False, None) -> <:expr< Gramext.Slist0 $txt$ >>
| (True, Some s) ->
let x = make_expr gmod tvar s in
<:expr< Gramext.Slist1sep $txt$ $x$ >> ]
- | TXnext loc -> <:expr< Gramext.Snext >>
- | TXnterm loc n lev ->
+ | TXnext _loc -> <:expr< Gramext.Snext >>
+ | TXnterm _loc n lev ->
match lev with
[ Some lab ->
<:expr<
Gramext.Snterm
($uid:gmod$.Entry.obj
($n.expr$ : $uid:gmod$.Entry.e '$n.tvar$)) >> ]
- | TXopt loc t -> <:expr< Gramext.Sopt $make_expr gmod "" t$ >>
- | TXrules loc rl ->
- <:expr< Gramext.srules $make_expr_rules loc gmod rl ""$ >>
- | TXself loc -> <:expr< Gramext.Sself >>
- | TXtok loc s e -> <:expr< Gramext.Stoken ($str:s$, $e$) >> ]
-and make_expr_rules loc gmod rl tvar =
+ | TXopt _loc t -> <:expr< Gramext.Sopt $make_expr gmod "" t$ >>
+ | TXrules _loc rl ->
+ <:expr< Gramext.srules $make_expr_rules _loc gmod rl ""$ >>
+ | TXself _loc -> <:expr< Gramext.Sself >>
+ | TXtok _loc s e -> <:expr< Gramext.Stoken ($str:s$, $e$) >> ]
+and make_expr_rules _loc gmod rl tvar =
List.fold_left
(fun txt (sl, ac) ->
let sl =
<:expr< [] >> rl
;
-value text_of_action loc psl rtvar act tvar =
+value text_of_action _loc psl rtvar act tvar =
let locid = <:patt< $lid:Stdpp.loc_name.val$ >> in
let act =
match act with
rl
;
-value expr_of_delete_rule loc gmod n sl =
+value expr_of_delete_rule _loc gmod n sl =
let sl =
List.fold_right
(fun s e -> <:expr< [$make_expr gmod "" s.text$ :: $e$] >>) sl
TXlist loc min symb.text t
;
-value sstoken loc s =
- let n = mk_name loc <:expr< $lid:"a_" ^ s$ >> in
- TXnterm loc n None
+value sstoken _loc s =
+ let n = mk_name _loc <:expr< $lid:"a_" ^ s$ >> in
+ TXnterm _loc n None
;
value mk_psymbol p s t =
{pattern = Some p; symbol = symb}
;
-value sslist loc min sep s =
+value sslist _loc min sep s =
let rl =
let r1 =
let prod =
- let n = mk_name loc <:expr< a_list >> in
- [mk_psymbol <:patt< a >> (TXnterm loc n None) (STquo loc "a_list")]
+ let n = mk_name _loc <:expr< a_list >> in
+ [mk_psymbol <:patt< a >> (TXnterm _loc n None) (STquo _loc "a_list")]
in
let act = <:expr< a >> in
{prod = prod; action = Some act}
in
let r2 =
let prod =
- [mk_psymbol <:patt< a >> (slist loc min sep s)
- (STapp loc (STlid loc "list") s.styp)]
+ [mk_psymbol <:patt< a >> (slist _loc min sep s)
+ (STapp _loc (STlid _loc "list") s.styp)]
in
let act = <:expr< Qast.List a >> in
{prod = prod; action = Some act}
| None -> s.used ]
in
let used = ["a_list" :: used] in
- let text = TXrules loc (srules loc "a_list" rl "") in
- let styp = STquo loc "a_list" in
+ let text = TXrules _loc (srules _loc "a_list" rl "") in
+ let styp = STquo _loc "a_list" in
{used = used; text = text; styp = styp}
;
-value ssopt loc s =
+value ssopt _loc s =
let rl =
let r1 =
let prod =
- let n = mk_name loc <:expr< a_opt >> in
- [mk_psymbol <:patt< a >> (TXnterm loc n None) (STquo loc "a_opt")]
+ let n = mk_name _loc <:expr< a_opt >> in
+ [mk_psymbol <:patt< a >> (TXnterm _loc n None) (STquo _loc "a_opt")]
in
let act = <:expr< a >> in
{prod = prod; action = Some act}
let r2 =
let s =
match s.text with
- [ TXtok loc "" <:expr< $str:_$ >> ->
+ [ TXtok _loc "" <:expr< $str:_$ >> ->
let rl =
[{prod = [{pattern = Some <:patt< x >>; symbol = s}];
action = Some <:expr< Qast.Str x >>}]
in
let t = new_type_var () in
- {used = []; text = TXrules loc (srules loc t rl "");
- styp = STquo loc t}
+ {used = []; text = TXrules _loc (srules _loc t rl "");
+ styp = STquo _loc t}
| _ -> s ]
in
let prod =
- [mk_psymbol <:patt< a >> (TXopt loc s.text)
- (STapp loc (STlid loc "option") s.styp)]
+ [mk_psymbol <:patt< a >> (TXopt _loc s.text)
+ (STapp _loc (STlid _loc "option") s.styp)]
in
let act = <:expr< Qast.Option a >> in
{prod = prod; action = Some act}
[r1; r2]
in
let used = ["a_opt" :: s.used] in
- let text = TXrules loc (srules loc "a_opt" rl "") in
- let styp = STquo loc "a_opt" in
+ let text = TXrules _loc (srules _loc "a_opt" rl "") in
+ let styp = STquo _loc "a_opt" in
{used = used; text = text; styp = styp}
;
-value text_of_entry loc gmod e =
+value text_of_entry _loc gmod e =
let ent =
let x = e.name in
- let loc = e.name.loc in
+ let _loc = e.name.loc in
<:expr< ($x.expr$ : $uid:gmod$.Entry.e '$x.tvar$) >>
in
let pos =
| None -> <:expr< None >> ]
in
let txt =
- let rl = srules loc e.name.tvar level.rules e.name.tvar in
- let e = make_expr_rules loc gmod rl e.name.tvar in
+ let rl = srules _loc e.name.tvar level.rules e.name.tvar in
+ let e = make_expr_rules _loc gmod rl e.name.tvar in
<:expr< [($lab$, $ass$, $e$) :: $txt$] >>
in
txt)
(ent, pos, txt)
;
-value let_in_of_extend loc gmod functor_version gl el args =
+value let_in_of_extend _loc gmod functor_version gl el args =
match gl with
[ Some ([n1 :: _] as nl) ->
do {
in
let globals =
List.map
- (fun {expr = e; tvar = x; loc = loc} ->
+ (fun {expr = e; tvar = x; loc = _loc} ->
(<:patt< _ >>, <:expr< ($e$ : $uid:gmod$.Entry.e '$x$) >>))
nl
in
let locals =
List.map
- (fun {expr = e; tvar = x; loc = loc} ->
+ (fun {expr = e; tvar = x; loc = _loc} ->
let i =
match e with
[ <:expr< $lid:i$ >> -> i
| _ -> args ]
;
-value text_of_extend loc gmod gl el f =
+value text_of_extend _loc gmod gl el f =
if split_ext.val then
let args =
List.map
el
in
let args = <:expr< do { $list:args$ } >> in
- let_in_of_extend loc gmod False gl el args
+ let_in_of_extend _loc gmod False gl el args
else
let args =
List.fold_right
<:expr< [$e$ :: $el$] >>)
el <:expr< [] >>
in
- let args = let_in_of_extend loc gmod False gl el args in
+ let args = let_in_of_extend _loc gmod False gl el args in
<:expr< $f$ $args$ >>
;
-value text_of_functorial_extend loc gmod gl el =
+value text_of_functorial_extend _loc gmod gl el =
let args =
let el =
List.map
in
<:expr< do { $list:el$ } >>
in
- let_in_of_extend loc gmod True gl el args
+ let_in_of_extend _loc gmod True gl el args
;
value zero_loc = {(Lexing.dummy_pos) with Lexing.pos_cnum = 0};
extend_body:
[ [ f = efunction; sl = OPT global;
el = LIST1 [ e = entry; semi_sep -> e ] ->
- text_of_extend loc "Grammar" sl el f ] ]
+ text_of_extend _loc "Grammar" sl el f ] ]
;
gextend_body:
[ [ g = UIDENT; sl = OPT global; el = LIST1 [ e = entry; semi_sep -> e ] ->
- text_of_functorial_extend loc g sl el ] ]
+ text_of_functorial_extend _loc g sl el ] ]
;
delete_rule_body:
[ [ n = name; ":"; sl = LIST1 symbol SEP semi_sep ->
- let (e, b) = expr_of_delete_rule loc "Grammar" n sl in
+ let (e, b) = expr_of_delete_rule _loc "Grammar" n sl in
<:expr< Grammar.delete_rule $e$ $b$ >> ] ]
;
gdelete_rule_body:
[ [ g = UIDENT; n = name; ":"; sl = LIST1 symbol SEP semi_sep ->
- let (e, b) = expr_of_delete_rule loc g n sl in
+ let (e, b) = expr_of_delete_rule _loc g n sl in
<:expr< $uid:g$.delete_rule $e$ $b$ >> ] ]
;
efunction:
rule_list:
[ [ "["; "]" -> []
| "["; rules = LIST1 rule SEP "|"; "]" ->
- retype_rule_list_without_patterns loc rules ] ]
+ retype_rule_list_without_patterns _loc rules ] ]
;
rule:
[ [ psl = LIST0 psymbol SEP semi_sep; "->"; act = expr ->
[ [ p = LIDENT; "="; s = symbol ->
{pattern = Some <:patt< $lid:p$ >>; symbol = s}
| i = LIDENT; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
- let name = mk_name loc <:expr< $lid:i$ >> in
- let text = TXnterm loc name lev in
- let styp = STquo loc i in
+ let name = mk_name _loc <:expr< $lid:i$ >> in
+ let text = TXnterm _loc name lev in
+ let styp = STquo _loc i in
let symb = {used = [i]; text = text; styp = styp} in
{pattern = None; symbol = symb}
| p = pattern; "="; s = symbol -> {pattern = Some p; symbol = s}
[ "top" NONA
[ UIDENT "LIST0"; s = SELF;
sep = OPT [ UIDENT "SEP"; t = symbol -> t ] ->
- if quotify.val then sslist loc False sep s
+ if quotify.val then sslist _loc False sep s
else
let used =
match sep with
[ Some symb -> symb.used @ s.used
| None -> s.used ]
in
- let styp = STapp loc (STlid loc "list") s.styp in
- let text = slist loc False sep s in
+ let styp = STapp _loc (STlid _loc "list") s.styp in
+ let text = slist _loc False sep s in
{used = used; text = text; styp = styp}
| UIDENT "LIST1"; s = SELF;
sep = OPT [ UIDENT "SEP"; t = symbol -> t ] ->
- if quotify.val then sslist loc True sep s
+ if quotify.val then sslist _loc True sep s
else
let used =
match sep with
[ Some symb -> symb.used @ s.used
| None -> s.used ]
in
- let styp = STapp loc (STlid loc "list") s.styp in
- let text = slist loc True sep s in
+ let styp = STapp _loc (STlid _loc "list") s.styp in
+ let text = slist _loc True sep s in
{used = used; text = text; styp = styp}
| UIDENT "OPT"; s = SELF ->
- if quotify.val then ssopt loc s
+ if quotify.val then ssopt _loc s
else
- let styp = STapp loc (STlid loc "option") s.styp in
- let text = TXopt loc s.text in
+ let styp = STapp _loc (STlid _loc "option") s.styp in
+ let text = TXopt _loc s.text in
{used = s.used; text = text; styp = styp} ]
| [ UIDENT "SELF" ->
- {used = []; text = TXself loc; styp = STself loc "SELF"}
+ {used = []; text = TXself _loc; styp = STself _loc "SELF"}
| UIDENT "NEXT" ->
- {used = []; text = TXnext loc; styp = STself loc "NEXT"}
+ {used = []; text = TXnext _loc; styp = STself _loc "NEXT"}
| "["; rl = LIST0 rule SEP "|"; "]" ->
- let rl = retype_rule_list_without_patterns loc rl in
+ let rl = retype_rule_list_without_patterns _loc rl in
let t = new_type_var () in
{used = used_of_rule_list rl;
- text = TXrules loc (srules loc t rl "");
- styp = STquo loc t}
+ text = TXrules _loc (srules _loc t rl "");
+ styp = STquo _loc t}
| x = UIDENT ->
let text =
- if quotify.val then sstoken loc x
- else TXtok loc x <:expr< "" >>
+ if quotify.val then sstoken _loc x
+ else TXtok _loc x <:expr< "" >>
in
- {used = []; text = text; styp = STlid loc "string"}
+ {used = []; text = text; styp = STlid _loc "string"}
| x = UIDENT; e = string ->
- let text = TXtok loc x e in
- {used = []; text = text; styp = STlid loc "string"}
+ let text = TXtok _loc x e in
+ {used = []; text = text; styp = STlid _loc "string"}
| e = string ->
- let text = TXtok loc "" e in
- {used = []; text = text; styp = STlid loc "string"}
+ let text = TXtok _loc "" e in
+ {used = []; text = text; styp = STlid _loc "string"}
| i = UIDENT; "."; e = qualid;
lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
- let n = mk_name loc <:expr< $uid:i$ . $e$ >> in
- {used = [n.tvar]; text = TXnterm loc n lev;
- styp = STquo loc n.tvar}
+ let n = mk_name _loc <:expr< $uid:i$ . $e$ >> in
+ {used = [n.tvar]; text = TXnterm _loc n lev;
+ styp = STquo _loc n.tvar}
| n = name; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
- {used = [n.tvar]; text = TXnterm loc n lev;
- styp = STquo loc n.tvar}
+ {used = [n.tvar]; text = TXnterm _loc n lev;
+ styp = STquo _loc n.tvar}
| "("; s_t = SELF; ")" -> s_t ] ]
;
pattern:
| [ p = pattern -> [p] ] ]
;
name:
- [ [ e = qualid -> mk_name loc e ] ]
+ [ [ e = qualid -> mk_name _loc e ] ]
;
qualid:
[ [ e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ]
string:
[ [ s = STRING -> <:expr< $str:s$ >>
| i = ANTIQUOT ->
- let shift = Reloc.shift_pos (String.length "$") (fst loc) in
+ let shift = Reloc.shift_pos (String.length "$") (fst _loc) in
let e =
try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string i) with
[ Exc_located (bp, ep) exc ->
(* *)
(***********************************************************************)
-(* $Id: pa_extend_m.ml,v 1.8 2002/07/19 14:53:50 mauny Exp $ *)
+(* $Id: pa_extend_m.ml,v 1.9 2004/11/17 09:07:56 mauny Exp $ *)
open Pa_extend;
[ NONA
[ min = [ UIDENT "SLIST0" -> False | UIDENT "SLIST1" -> True ];
s = SELF; sep = OPT [ UIDENT "SEP"; t = symbol -> t ] ->
- sslist loc min sep s
+ sslist _loc min sep s
| UIDENT "SOPT"; s = SELF ->
- ssopt loc s ] ]
+ ssopt _loc s ] ]
;
END;
(* camlp4r *)
-(* $Id: pa_macro.ml,v 1.2.4.6 2004/07/02 09:37:16 doligez Exp $ *)
+(* $Id: pa_macro.ml,v 1.5 2005/10/21 10:55:32 mauny Exp $ *)
(*
Added statements:
value is_defined i = List.mem_assoc i defined.val;
-value loc =
+value _loc =
let nowhere =
{ (Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0 } in
(nowhere, nowhere);
[ Some ([], e) ->
EXTEND
expr: LEVEL "simple"
- [ [ UIDENT $x$ -> Pcaml.expr_reloc (fun _ -> loc) (fst loc) e ] ]
+ [ [ UIDENT $x$ -> Pcaml.expr_reloc (fun _ -> _loc) (fst _loc) e ] ]
;
patt: LEVEL "simple"
[ [ UIDENT $x$ ->
- let p = substp loc [] e in
- Pcaml.patt_reloc (fun _ -> loc) (fst loc) p ] ]
+ let p = substp _loc [] e in
+ Pcaml.patt_reloc (fun _ -> _loc) (fst _loc) p ] ]
;
END
| Some (sl, e) ->
in
if List.length el = List.length sl then
let env = List.combine sl el in
- let e = subst loc env e in
- Pcaml.expr_reloc (fun _ -> loc) (fst loc) e
+ let e = subst _loc env e in
+ Pcaml.expr_reloc (fun _ -> _loc) (fst _loc) e
else
- incorrect_number loc el sl ] ]
+ incorrect_number _loc el sl ] ]
;
patt: LEVEL "simple"
[ [ UIDENT $x$; param = SELF ->
in
if List.length pl = List.length sl then
let env = List.combine sl pl in
- let p = substp loc env e in
- Pcaml.patt_reloc (fun _ -> loc) (fst loc) p
+ let p = substp _loc env e in
+ Pcaml.patt_reloc (fun _ -> _loc) (fst _loc) p
else
- incorrect_number loc pl sl ] ]
+ incorrect_number _loc pl sl ] ]
;
END
| None -> () ];
try (List.find (dir_ok file) (include_dirs.val @ ["./"])) ^ file
with [ Not_found -> file ]
in
- let st = Stream.of_channel (open_in file) in
+ let ch = open_in file in
+ let st = Stream.of_channel ch in
let old_input = Pcaml.input_file.val in
+ let (bol_ref, lnum_ref, name_ref) = Pcaml.position.val in
+ let (old_bol, old_lnum, old_name) = (bol_ref.val, lnum_ref.val, name_ref.val) in
+ let restore () =
+ do {
+ close_in ch;
+ bol_ref.val := old_bol;
+ lnum_ref.val := old_lnum;
+ name_ref.val := old_name;
+ Pcaml.input_file.val := old_input;
+ }
+ in
do {
+ bol_ref.val := 0;
+ lnum_ref.val := 1;
+ name_ref.val := file;
Pcaml.input_file.val := file;
- let items = Grammar.Entry.parse smlist st in
- do { Pcaml.input_file.val := old_input; items } }
+ try
+ let items = Grammar.Entry.parse smlist st in
+ do { restore (); items }
+ with [ exn -> do { restore (); raise exn } ] }
;
value rec execute_macro = fun
expr: LEVEL "simple"
[ [ LIDENT "__FILE__" -> <:expr< $str:Pcaml.input_file.val$ >>
| LIDENT "__LOCATION__" ->
- let bp = string_of_int ((fst loc).Lexing.pos_cnum) in
- let ep = string_of_int ((snd loc).Lexing.pos_cnum) in
+ let bp = string_of_int ((fst _loc).Lexing.pos_cnum) in
+ let ep = string_of_int ((snd _loc).Lexing.pos_cnum) in
<:expr< ($int:bp$, $int:ep$) >> ] ]
;
patt:
(* *)
(***********************************************************************)
-(* $Id: pa_r.ml,v 1.59.2.3 2005/06/02 10:40:32 mauny Exp $ *)
+(* $Id: pa_r.ml,v 1.64 2005/06/29 04:11:26 garrigue Exp $ *)
open Stdpp;
open Pcaml;
| None -> False ]
;
-value mksequence loc =
+value mksequence _loc =
fun
[ [e] -> e
| el -> <:expr< do { $list:el$ } >> ]
;
-value mkmatchcase loc p aso w e =
+value mkmatchcase _loc p aso w e =
let p =
match aso with
[ Some p2 -> <:patt< ($p$ as $p2$) >>
else "-" ^ n
;
-value mkumin loc f arg =
+value mkumin _loc f arg =
match arg with
[ <:expr< $int:n$ >> -> <:expr< $int:neg_string n$ >>
| MLast.ExInt32 loc n -> MLast.ExInt32 loc (neg_string n)
<:expr< $lid:f$ $arg$ >> ]
;
-value mklistexp loc last =
+value mklistexp _loc last =
loop True where rec loop top =
fun
[ [] ->
[ Some e -> e
| None -> <:expr< [] >> ]
| [e1 :: el] ->
- let loc =
- if top then loc else (fst (MLast.loc_of_expr e1), snd loc)
+ let _loc =
+ if top then _loc else (fst (MLast.loc_of_expr e1), snd _loc)
in
<:expr< [$e1$ :: $loop False el$] >> ]
;
-value mklistpat loc last =
+value mklistpat _loc last =
loop True where rec loop top =
fun
[ [] ->
[ Some p -> p
| None -> <:patt< [] >> ]
| [p1 :: pl] ->
- let loc =
- if top then loc else (fst (MLast.loc_of_patt p1), snd loc)
+ let _loc =
+ if top then _loc else (fst (MLast.loc_of_patt p1), snd _loc)
in
<:patt< [$p1$ :: $loop False pl$] >> ]
;
-value mkexprident loc i j =
- let rec loop m =
- fun
- [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y
- | e -> <:expr< $m$ . $e$ >> ]
+value mkexprident _loc ids = match ids with
+ [ [] -> Stdpp.raise_with_loc _loc (Stream.Error "illegal long identifier")
+ | [ id :: ids ] ->
+ let rec loop m = fun
+ [ [ id :: ids ] -> loop <:expr< $m$ . $id$ >> ids
+ | [] -> m ]
in
- loop <:expr< $uid:i$ >> j
+ loop id ids ]
;
-value mkassert loc e =
+value mkassert _loc e =
match e with
- [ <:expr< False >> -> MLast.ExAsf loc
- | _ -> MLast.ExAsr loc e ]
+ [ <:expr< False >> -> MLast.ExAsf _loc
+ | _ -> MLast.ExAsr _loc e ]
;
value append_elem el e = el @ [e];
| "module"; i = UIDENT; mb = module_binding ->
<:str_item< module $i$ = $mb$ >>
| "module"; "rec"; nmtmes = LIST1 module_rec_binding SEP "and" ->
- MLast.StRecMod loc nmtmes
+ MLast.StRecMod _loc nmtmes
| "module"; "type"; i = UIDENT; "="; mt = module_type ->
<:str_item< module type $i$ = $mt$ >>
| "open"; i = mod_ident -> <:str_item< open $i$ >>
| "module"; i = UIDENT; mt = module_declaration ->
<:sig_item< module $i$ : $mt$ >>
| "module"; "rec"; mds = LIST1 module_rec_declaration SEP "and" ->
- MLast.SgRecMod loc mds
+ MLast.SgRecMod _loc mds
| "module"; "type"; i = UIDENT; "="; mt = module_type ->
<:sig_item< module type $i$ = $mt$ >>
| "open"; i = mod_ident -> <:sig_item< open $i$ >>
<:expr< try $e$ with $p1$ -> $e1$ >>
| "if"; e1 = SELF; "then"; e2 = SELF; "else"; e3 = SELF ->
<:expr< if $e1$ then $e2$ else $e3$ >>
- | "do"; "{"; seq = sequence; "}" -> mksequence loc seq
+ | "do"; "{"; seq = sequence; "}" -> mksequence _loc seq
| "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF;
"do"; "{"; seq = sequence; "}" ->
<:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:seq$ } >>
<:expr< while $e$ do { $list:seq$ } >>
| "object"; cspo = OPT class_self_patt; cf = class_structure; "end" ->
(* <:expr< object $opt:cspo$ $list:cf$ end >> *)
- MLast.ExObj loc cspo cf ]
+ MLast.ExObj _loc cspo cf ]
| "where"
[ e = SELF; "where"; rf = OPT "rec"; lb = let_binding ->
<:expr< let $opt:o2b rf$ $list:[lb]$ in $e$ >> ]
| e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >>
| e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >> ]
| "unary minus" NONA
- [ "-"; e = SELF -> mkumin loc "-" e
- | "-."; e = SELF -> mkumin loc "-." e ]
+ [ "-"; e = SELF -> mkumin _loc "-" e
+ | "-."; e = SELF -> mkumin _loc "-." e ]
| "apply" LEFTA
[ e1 = SELF; e2 = SELF -> <:expr< $e1$ $e2$ >>
- | "assert"; e = SELF -> mkassert loc e
+ | "assert"; e = SELF -> mkassert _loc e
| "lazy"; e = SELF -> <:expr< lazy ($e$) >> ]
| "." LEFTA
[ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >>
| "~-."; e = SELF -> <:expr< ~-. $e$ >> ]
| "simple"
[ s = INT -> <:expr< $int:s$ >>
- | s = INT32 -> MLast.ExInt32 loc s
- | s = INT64 -> MLast.ExInt64 loc s
- | s = NATIVEINT -> MLast.ExNativeInt loc s
+ | s = INT32 -> MLast.ExInt32 _loc s
+ | s = INT64 -> MLast.ExInt64 _loc s
+ | s = NATIVEINT -> MLast.ExNativeInt _loc s
| s = FLOAT -> <:expr< $flo:s$ >>
| s = STRING -> <:expr< $str:s$ >>
| s = CHAR -> <:expr< $chr:s$ >>
- | i = expr_ident -> i
+ | ids = expr_ident -> mkexprident _loc ids
| "["; "]" -> <:expr< [] >>
| "["; el = LIST1 expr SEP ";"; last = cons_expr_opt; "]" ->
- mklistexp loc last el
+ mklistexp _loc last el
| "[|"; el = LIST0 expr SEP ";"; "|]" -> <:expr< [| $list:el$ |] >>
| "{"; lel = LIST1 label_expr SEP ";"; "}" -> <:expr< { $list:lel$ } >>
| "{"; "("; e = SELF; ")"; "with"; lel = LIST1 label_expr SEP ";"; "}"
sequence:
[ [ "let"; rf = OPT "rec"; l = LIST1 let_binding SEP "and"; [ "in" | ";" ];
el = SELF ->
- [<:expr< let $opt:o2b rf$ $list:l$ in $mksequence loc el$ >>]
+ [<:expr< let $opt:o2b rf$ $list:l$ in $mksequence _loc el$ >>]
| e = expr; ";"; el = SELF -> [e :: el]
| e = expr; ";" -> [e]
| e = expr -> [e] ] ]
;
match_case:
[ [ p = patt; aso = as_patt_opt; w = when_expr_opt; "->"; e = expr ->
- mkmatchcase loc p aso w e ] ]
+ mkmatchcase _loc p aso w e ] ]
;
as_patt_opt:
[ [ "as"; p = patt -> Some p
;
expr_ident:
[ RIGHTA
- [ i = LIDENT -> <:expr< $lid:i$ >>
- | i = UIDENT -> <:expr< $uid:i$ >>
- | i = UIDENT; "."; j = SELF -> mkexprident loc i j ] ]
+ [ i = LIDENT -> [ <:expr< $lid:i$ >> ]
+ | i = UIDENT -> [ <:expr< $uid:i$ >> ]
+ | i = UIDENT; "."; j = SELF -> [ <:expr< $uid:i$ >> :: j ] ] ]
;
fun_def:
[ RIGHTA
[ s = LIDENT -> <:patt< $lid:s$ >>
| s = UIDENT -> <:patt< $uid:s$ >>
| s = INT -> <:patt< $int:s$ >>
- | s = INT32 -> MLast.PaInt32 loc s
- | s = INT64 -> MLast.PaInt64 loc s
- | s = NATIVEINT -> MLast.PaNativeInt loc s
+ | s = INT32 -> MLast.PaInt32 _loc s
+ | s = INT64 -> MLast.PaInt64 _loc s
+ | s = NATIVEINT -> MLast.PaNativeInt _loc s
| s = FLOAT -> <:patt< $flo:s$ >>
| s = STRING -> <:patt< $str:s$ >>
| s = CHAR -> <:patt< $chr:s$ >>
- | "-"; s = INT -> MLast.PaInt loc (neg_string s)
- | "-"; s = INT32 -> MLast.PaInt32 loc (neg_string s)
- | "-"; s = INT64 -> MLast.PaInt64 loc (neg_string s)
- | "-"; s = NATIVEINT -> MLast.PaNativeInt loc (neg_string s)
+ | "-"; s = INT -> MLast.PaInt _loc (neg_string s)
+ | "-"; s = INT32 -> MLast.PaInt32 _loc (neg_string s)
+ | "-"; s = INT64 -> MLast.PaInt64 _loc (neg_string s)
+ | "-"; s = NATIVEINT -> MLast.PaNativeInt _loc (neg_string s)
| "-"; s = FLOAT -> <:patt< $flo:neg_string s$ >>
| "["; "]" -> <:patt< [] >>
| "["; pl = LIST1 patt SEP ";"; last = cons_patt_opt; "]" ->
- mklistpat loc last pl
+ mklistpat _loc last pl
| "[|"; pl = LIST0 patt SEP ";"; "|]" -> <:patt< [| $list:pl$ |] >>
| "{"; lpl = LIST1 label_patt SEP ";"; "}" -> <:patt< { $list:lpl$ } >>
| "("; ")" -> <:patt< () >>
(n, tpl, tk, cl) ] ]
;
type_patt:
- [ [ n = LIDENT -> (loc, n) ] ]
+ [ [ n = LIDENT -> (_loc, n) ] ]
;
constrain:
[ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ]
ctyp:
[ LEFTA
[ t1 = SELF; "=="; t2 = SELF -> <:ctyp< $t1$ == $t2$ >> ]
- | LEFTA
+ | NONA
+ [ "private"; t = ctyp LEVEL "alias" -> <:ctyp< private $t$ >> ]
+ | "alias" LEFTA
[ t1 = SELF; "as"; t2 = SELF -> <:ctyp< $t1$ as $t2$ >> ]
| LEFTA
[ "!"; pl = LIST1 typevar; "."; t = ctyp ->
| "("; t = SELF; "*"; tl = LIST1 ctyp SEP "*"; ")" ->
<:ctyp< ( $list:[t::tl]$ ) >>
| "("; t = SELF; ")" -> <:ctyp< $t$ >>
- | "private"; "["; cdl = LIST0 constructor_declaration SEP "|"; "]" ->
- <:ctyp< private [ $list:cdl$ ] >>
- | "private"; "{"; ldl = LIST1 label_declaration SEP ";"; "}" ->
- <:ctyp< private { $list:ldl$ } >>
| "["; cdl = LIST0 constructor_declaration SEP "|"; "]" ->
<:ctyp< [ $list:cdl$ ] >>
+ (* MLast.TySum _loc cdl *)
| "{"; ldl = LIST1 label_declaration SEP ";"; "}" ->
- <:ctyp< { $list:ldl$ } >> ] ]
+ <:ctyp< { $list:ldl$ } >>
+ (* MLast.TyRec _loc ldl *) ] ]
;
constructor_declaration:
- [ [ ci = UIDENT; "of"; cal = LIST1 ctyp SEP "and" -> (loc, ci, cal)
- | ci = UIDENT -> (loc, ci, []) ] ]
+ [ [ ci = UIDENT; "of"; cal = LIST1 ctyp SEP "and" -> (_loc, ci, cal)
+ | ci = UIDENT -> (_loc, ci, []) ] ]
;
label_declaration:
[ [ i = LIDENT; ":"; mf = OPT "mutable"; t = ctyp ->
- (loc, i, o2b mf, t) ] ]
+ (_loc, i, o2b mf, t) ] ]
;
ident:
[ [ i = LIDENT -> i
class_declaration:
[ [ vf = OPT "virtual"; i = LIDENT; ctp = class_type_parameters;
cfb = class_fun_binding ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
+ {MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
MLast.ciNam = i; MLast.ciExp = cfb} ] ]
;
class_fun_binding:
| p = ipatt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ]
;
class_type_parameters:
- [ [ -> (loc, [])
- | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ]
+ [ [ -> (_loc, [])
+ | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (_loc, tpl) ] ]
;
class_fun_def:
[ [ p = ipatt; ce = SELF -> <:class_expr< fun $p$ -> $ce$ >>
class_description:
[ [ vf = OPT "virtual"; n = LIDENT; ctp = class_type_parameters; ":";
ct = class_type ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
+ {MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
MLast.ciNam = n; MLast.ciExp = ct} ] ]
;
class_type_declaration:
[ [ vf = OPT "virtual"; n = LIDENT; ctp = class_type_parameters; "=";
cs = class_type ->
- {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
+ {MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
MLast.ciNam = n; MLast.ciExp = cs} ] ]
;
expr: LEVEL "apply"
<:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ]
;
warning_variant:
- [ [ -> warn_variant loc ] ]
+ [ [ -> warn_variant _loc ] ]
;
(* Compatibility old syntax of sequences *)
expr: LEVEL "top"
<:expr< while $e$ do { $list:seq$ } >> ] ]
;
warning_sequence:
- [ [ -> warn_sequence loc ] ]
+ [ [ -> warn_sequence _loc ] ]
;
END;
GLOBAL: interf implem use_file top_phrase expr patt;
interf:
[ [ "#"; n = LIDENT; dp = OPT expr; ";" ->
- ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True)
+ ([(<:sig_item< # $n$ $opt:dp$ >>, _loc)], True)
| si = sig_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
| EOI -> ([], False) ] ]
;
sig_item_semi:
- [ [ si = sig_item; ";" -> (si, loc) ] ]
+ [ [ si = sig_item; ";" -> (si, _loc) ] ]
;
implem:
[ [ "#"; n = LIDENT; dp = OPT expr; ";" ->
- ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True)
+ ([(<:str_item< # $n$ $opt:dp$ >>, _loc)], True)
| si = str_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped)
| EOI -> ([], False) ] ]
;
str_item_semi:
- [ [ si = str_item; ";" -> (si, loc) ] ]
+ [ [ si = str_item; ";" -> (si, _loc) ] ]
;
top_phrase:
[ [ ph = phrase -> Some ph
with
[ Not_found | Failure _ -> ({(Lexing.dummy_pos) with Lexing.pos_cnum = 0}, x) ]
in
- Pcaml.handle_expr_locate loc x
+ Pcaml.handle_expr_locate _loc x
| x = QUOTATION ->
let x =
try
with
[ Not_found -> ("", x) ]
in
- Pcaml.handle_expr_quotation loc x ] ]
+ Pcaml.handle_expr_quotation _loc x ] ]
;
patt: LEVEL "simple"
[ [ x = LOCATE ->
with
[ Not_found | Failure _ -> ({(Lexing.dummy_pos) with Lexing.pos_cnum = 0}, x) ]
in
- Pcaml.handle_patt_locate loc x
+ Pcaml.handle_patt_locate _loc x
| x = QUOTATION ->
let x =
try
with
[ Not_found -> ("", x) ]
in
- Pcaml.handle_patt_quotation loc x ] ]
+ Pcaml.handle_patt_quotation _loc x ] ]
;
END;
(* *)
(***********************************************************************)
-(* $Id: pa_rp.ml,v 1.7 2003/07/10 12:28:27 michel Exp $ *)
+(* $Id: pa_rp.ml,v 1.8 2004/11/17 09:07:56 mauny Exp $ *)
open Pcaml;
;
value strm_n = "strm__";
-value peek_fun loc = <:expr< Stream.peek >>;
-value junk_fun loc = <:expr< Stream.junk >>;
+value peek_fun _loc = <:expr< Stream.peek >>;
+value junk_fun _loc = <:expr< Stream.junk >>;
(* Parsers. *)
(* In syntax generated, many cases are optimisations. *)
;
value rec subst v e =
- let loc = MLast.loc_of_expr e in
+ let _loc = MLast.loc_of_expr e in
match e with
[ <:expr< $lid:x$ >> ->
let x = if x = v then strm_n else x in <:expr< $lid:x$ >>
value stream_pattern_component skont ckont =
fun
- [ SpTrm loc p wo ->
- <:expr< match $peek_fun loc$ $lid:strm_n$ with
+ [ SpTrm _loc p wo ->
+ <:expr< match $peek_fun _loc$ $lid:strm_n$ with
[ Some $p$ $when:wo$ ->
- do { $junk_fun loc$ $lid:strm_n$; $skont$ }
+ do { $junk_fun _loc$ $lid:strm_n$; $skont$ }
| _ -> $ckont$ ] >>
- | SpNtr loc p e ->
+ | SpNtr _loc p e ->
let e =
match e with
[ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> e
<:expr< match try Some $e$ with [ Stream.Failure -> None ] with
[ Some $p$ -> $skont$
| _ -> $ckont$ ] >>
- | SpStr loc p ->
+ | SpStr _loc p ->
try
match p with
[ <:patt< $lid:v$ >> -> subst v skont
[ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ]
;
-value rec stream_pattern loc epo e ekont =
+value rec stream_pattern _loc epo e ekont =
fun
[ [] ->
match epo with
in
<:expr< raise (Stream.Error $str$) >>
in
- stream_pattern loc epo e ekont spcl
+ stream_pattern _loc epo e ekont spcl
in
let ckont = ekont err in stream_pattern_component skont ckont spc ]
;
-value stream_patterns_term loc ekont tspel =
+value stream_patterns_term _loc ekont tspel =
let pel =
List.map
- (fun (p, w, loc, spcl, epo, e) ->
+ (fun (p, w, _loc, spcl, epo, e) ->
let p = <:patt< Some $p$ >> in
let e =
let ekont err =
in
<:expr< raise (Stream.Error $str$) >>
in
- let skont = stream_pattern loc epo e ekont spcl in
- <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >>
+ let skont = stream_pattern _loc epo e ekont spcl in
+ <:expr< do { $junk_fun _loc$ $lid:strm_n$; $skont$ } >>
in
(p, w, e))
tspel
in
let pel = pel @ [(<:patt< _ >>, None, ekont ())] in
- <:expr< match $peek_fun loc$ $lid:strm_n$ with [ $list:pel$ ] >>
+ <:expr< match $peek_fun _loc$ $lid:strm_n$ with [ $list:pel$ ] >>
;
value rec group_terms =
fun
- [ [([(SpTrm loc p w, None) :: spcl], epo, e) :: spel] ->
+ [ [([(SpTrm _loc p w, None) :: spcl], epo, e) :: spel] ->
let (tspel, spel) = group_terms spel in
- ([(p, w, loc, spcl, epo, e) :: tspel], spel)
+ ([(p, w, _loc, spcl, epo, e) :: tspel], spel)
| spel -> ([], spel) ]
;
-value rec parser_cases loc =
+value rec parser_cases _loc =
fun
[ [] -> <:expr< raise Stream.Failure >>
| spel ->
match group_terms spel with
[ ([], [(spcl, epo, e) :: spel]) ->
- stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl
+ stream_pattern _loc epo e (fun _ -> parser_cases _loc spel) spcl
| (tspel, spel) ->
- stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel ] ]
+ stream_patterns_term _loc (fun _ -> parser_cases _loc spel) tspel ] ]
;
-value cparser loc bpo pc =
- let e = parser_cases loc pc in
+value cparser _loc bpo pc =
+ let e = parser_cases _loc pc in
let e =
match bpo with
[ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >>
let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in <:expr< fun $p$ -> $e$ >>
;
-value cparser_match loc me bpo pc =
- let pc = parser_cases loc pc in
+value cparser_match _loc me bpo pc =
+ let pc = parser_cases _loc pc in
let e =
match bpo with
[ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
| _ -> False ]
;
-value slazy loc e =
+value slazy _loc e =
match e with
[ <:expr< $f$ () >> ->
match f with
value rec cstream gloc =
fun
- [ [] -> let loc = gloc in <:expr< Stream.sempty >>
- | [SeTrm loc e] ->
+ [ [] -> let _loc = gloc in <:expr< Stream.sempty >>
+ | [SeTrm _loc e] ->
if not_computing e then <:expr< Stream.ising $e$ >>
- else <:expr< Stream.lsing $slazy loc e$ >>
- | [SeTrm loc e :: secl] ->
+ else <:expr< Stream.lsing $slazy _loc e$ >>
+ | [SeTrm _loc e :: secl] ->
if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >>
- else <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >>
- | [SeNtr loc e] ->
- if not_computing e then e else <:expr< Stream.slazy $slazy loc e$ >>
- | [SeNtr loc e :: secl] ->
+ else <:expr< Stream.lcons $slazy _loc e$ $cstream gloc secl$ >>
+ | [SeNtr _loc e] ->
+ if not_computing e then e else <:expr< Stream.slazy $slazy _loc e$ >>
+ | [SeNtr _loc e :: secl] ->
if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >>
- else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ]
+ else <:expr< Stream.lapp $slazy _loc e$ $cstream gloc secl$ >> ]
;
(* Syntax extensions in Revised Syntax grammar *)
GLOBAL: expr;
expr: LEVEL "top"
[ [ "parser"; po = OPT ipatt; "["; pcl = LIST0 parser_case SEP "|"; "]" ->
- <:expr< $cparser loc po pcl$ >>
+ <:expr< $cparser _loc po pcl$ >>
| "parser"; po = OPT ipatt; pc = parser_case ->
- <:expr< $cparser loc po [pc]$ >>
+ <:expr< $cparser _loc po [pc]$ >>
| "match"; e = SELF; "with"; "parser"; po = OPT ipatt; "[";
pcl = LIST0 parser_case SEP "|"; "]" ->
- <:expr< $cparser_match loc e po pcl$ >>
+ <:expr< $cparser_match _loc e po pcl$ >>
| "match"; e = SELF; "with"; "parser"; po = OPT ipatt;
pc = parser_case ->
- <:expr< $cparser_match loc e po [pc]$ >> ] ]
+ <:expr< $cparser_match _loc e po [pc]$ >> ] ]
;
parser_case:
[ [ "[:"; sp = stream_patt; ":]"; po = OPT ipatt; "->"; e = expr ->
(spc, eo) ] ]
;
stream_patt_comp:
- [ [ "`"; p = patt; eo = OPT [ "when"; e = expr -> e ] -> SpTrm loc p eo
- | p = patt; "="; e = expr -> SpNtr loc p e
- | p = patt -> SpStr loc p ] ]
+ [ [ "`"; p = patt; eo = OPT [ "when"; e = expr -> e ] -> SpTrm _loc p eo
+ | p = patt; "="; e = expr -> SpNtr _loc p e
+ | p = patt -> SpStr _loc p ] ]
;
ipatt:
[ [ i = LIDENT -> <:patt< $lid:i$ >> ] ]
;
expr: LEVEL "simple"
[ [ "[:"; se = LIST0 stream_expr_comp SEP ";"; ":]" ->
- <:expr< $cstream loc se$ >> ] ]
+ <:expr< $cstream _loc se$ >> ] ]
;
stream_expr_comp:
- [ [ "`"; e = expr -> SeTrm loc e | e = expr -> SeNtr loc e ] ]
+ [ [ "`"; e = expr -> SeTrm _loc e | e = expr -> SeNtr _loc e ] ]
;
END;
(* *)
(***********************************************************************)
-(* $Id: q_MLast.ml,v 1.56.2.2 2005/06/17 12:25:57 mauny Exp $ *)
+(* $Id: q_MLast.ml,v 1.60 2005/06/29 04:11:26 garrigue Exp $ *)
value (gram, q_position) =
let (lexer,pos) = Plexer.make_lexer () in
| Loc
| Antiquot of MLast.loc and string ]
;
- value loc =
+ value _loc =
let nowhere =
{(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0 } in
(nowhere,nowhere);
ctyp:
[ LEFTA
[ t1 = SELF; "=="; t2 = SELF -> Qast.Node "TyMan" [Qast.Loc; t1; t2] ]
- | LEFTA
+ | NONA
+ [ "private"; t = ctyp LEVEL "alias" -> Qast.Node "TyPrv" [Qast.Loc; t] ]
+ | "alias" LEFTA
[ t1 = SELF; "as"; t2 = SELF -> Qast.Node "TyAli" [Qast.Loc; t1; t2] ]
| LEFTA
[ "!"; pl = SLIST1 typevar; "."; t = SELF ->
| "("; t = SELF; "*"; tl = SLIST1 ctyp SEP "*"; ")" ->
Qast.Node "TyTup" [Qast.Loc; Qast.Cons t tl]
| "("; t = SELF; ")" -> t
- | "private"; "["; cdl = SLIST0 constructor_declaration SEP "|"; "]" ->
- Qast.Node "TySum" [Qast.Loc; Qast.Bool True; cdl]
- | "private"; "{"; ldl = SLIST1 label_declaration SEP ";"; "}" ->
- Qast.Node "TyRec" [Qast.Loc; Qast.Bool True; ldl]
| "["; cdl = SLIST0 constructor_declaration SEP "|"; "]" ->
- Qast.Node "TySum" [Qast.Loc; Qast.Bool False; cdl]
+ Qast.Node "TySum" [Qast.Loc; cdl]
| "{"; ldl = SLIST1 label_declaration SEP ";"; "}" ->
- Qast.Node "TyRec" [Qast.Loc; Qast.Bool False; ldl] ] ]
+ Qast.Node "TyRec" [Qast.Loc; ldl] ] ]
;
constructor_declaration:
[ [ ci = a_UIDENT; "of"; cal = SLIST1 ctyp SEP "and" ->
;
(* Antiquotations for local entries *)
sequence:
- [ [ a = ANTIQUOT "list" -> antiquot "list" loc a ] ]
+ [ [ a = ANTIQUOT "list" -> antiquot "list" _loc a ] ]
;
expr_ident:
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
+ [ [ a = ANTIQUOT -> antiquot "" _loc a ] ]
;
patt_label_ident: LEVEL "simple"
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
+ [ [ a = ANTIQUOT -> antiquot "" _loc a ] ]
;
when_expr_opt:
- [ [ a = ANTIQUOT "when" -> antiquot "when" loc a ] ]
+ [ [ a = ANTIQUOT "when" -> antiquot "when" _loc a ] ]
;
mod_ident:
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
+ [ [ a = ANTIQUOT -> antiquot "" _loc a ] ]
;
clty_longident:
[ [ a = a_list -> a ] ]
[ [ a = a_list -> a ] ]
;
direction_flag:
- [ [ a = ANTIQUOT "to" -> antiquot "to" loc a ] ]
+ [ [ a = ANTIQUOT "to" -> antiquot "to" _loc a ] ]
;
(* deprecated since version 3.05; code for compatibility *)
class_expr: LEVEL "simple"
[ [ "object"; x = ANTIQUOT; cf = class_structure; "end" ->
- let _ = warn_antiq loc "3.05" in
- Qast.Node "CeStr" [Qast.Loc; antiquot "" loc x; cf]
+ let _ = warn_antiq _loc "3.05" in
+ Qast.Node "CeStr" [Qast.Loc; antiquot "" _loc x; cf]
| "object"; x = ANTIQUOT; ";";
csl = SLIST0 [ cf = class_str_item; ";" -> cf ] ; "end" ->
- let _ = warn_antiq loc "3.05" in
+ let _ = warn_antiq _loc "3.05" in
Qast.Node "CeStr"
[Qast.Loc; Qast.Option None;
- Qast.Cons (antiquot "" loc x) csl] ] ]
+ Qast.Cons (antiquot "" _loc x) csl] ] ]
;
class_type:
[ [ "object"; x = ANTIQUOT;
csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" ->
- let _ = warn_antiq loc "3.05" in
- Qast.Node "CtSig" [Qast.Loc; antiquot "" loc x; csf]
+ let _ = warn_antiq _loc "3.05" in
+ Qast.Node "CtSig" [Qast.Loc; antiquot "" _loc x; csf]
| "object"; x = ANTIQUOT; ";";
csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" ->
- let _ = warn_antiq loc "3.05" in
+ let _ = warn_antiq _loc "3.05" in
Qast.Node "CtSig"
[Qast.Loc; Qast.Option None;
- Qast.Cons (antiquot "" loc x) csf] ] ]
+ Qast.Cons (antiquot "" _loc x) csf] ] ]
;
(* deprecated since version 3.06+18; code for compatibility *)
expr: LEVEL "top"
[ [ "let"; r = ANTIQUOT "rec"; l = SLIST1 let_binding SEP "and"; "in";
x = SELF ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "ExLet" [Qast.Loc; antiquot "rec" loc r; l; x] ] ]
+ let _ = warn_antiq _loc "3.06+18" in
+ Qast.Node "ExLet" [Qast.Loc; antiquot "rec" _loc r; l; x] ] ]
;
str_item: LEVEL "top"
[ [ "value"; r = ANTIQUOT "rec"; l = SLIST1 let_binding SEP "and" ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "StVal" [Qast.Loc; antiquot "rec" loc r; l] ] ]
+ let _ = warn_antiq _loc "3.06+18" in
+ Qast.Node "StVal" [Qast.Loc; antiquot "rec" _loc r; l] ] ]
;
class_expr: LEVEL "top"
[ [ "let"; r = ANTIQUOT "rec"; lb = SLIST1 let_binding SEP "and"; "in";
ce = SELF ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "CeLet" [Qast.Loc; antiquot "rec" loc r; lb; ce] ] ]
+ let _ = warn_antiq _loc "3.06+18" in
+ Qast.Node "CeLet" [Qast.Loc; antiquot "rec" _loc r; lb; ce] ] ]
;
class_str_item:
[ [ "inherit"; ce = class_expr; pb = ANTIQUOT "as" ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "CrInh" [Qast.Loc; ce; antiquot "as" loc pb]
+ let _ = warn_antiq _loc "3.06+18" in
+ Qast.Node "CrInh" [Qast.Loc; ce; antiquot "as" _loc pb]
| "value"; mf = ANTIQUOT "mut"; lab = label; e = cvalue_binding ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "CrVal" [Qast.Loc; lab; antiquot "mut" loc mf; e] ] ]
+ let _ = warn_antiq _loc "3.06+18" in
+ Qast.Node "CrVal" [Qast.Loc; lab; antiquot "mut" _loc mf; e] ] ]
;
class_sig_item:
[ [ "value"; mf = ANTIQUOT "mut"; l = label; ":"; t = ctyp ->
- let _ = warn_antiq loc "3.06+18" in
- Qast.Node "CgVal" [Qast.Loc; l; antiquot "mut" loc mf; t] ] ]
+ let _ = warn_antiq _loc "3.06+18" in
+ Qast.Node "CgVal" [Qast.Loc; l; antiquot "mut" _loc mf; t] ] ]
;
END;
Qast.Node "SgDir" [Qast.Loc; n; dp] ] ]
;
dir_param:
- [ [ a = ANTIQUOT "opt" -> antiquot "opt" loc a
+ [ [ a = ANTIQUOT "opt" -> antiquot "opt" _loc a
| e = expr -> Qast.Option (Some e)
| -> Qast.Option None ] ]
;
EXTEND
module_expr: LEVEL "simple"
- [ [ a = ANTIQUOT "mexp" -> antiquot "mexp" loc a
- | a = ANTIQUOT -> antiquot "" loc a ] ]
+ [ [ a = ANTIQUOT "mexp" -> antiquot "mexp" _loc a
+ | a = ANTIQUOT -> antiquot "" _loc a ] ]
;
str_item: LEVEL "top"
- [ [ a = ANTIQUOT "stri" -> antiquot "stri" loc a
- | a = ANTIQUOT -> antiquot "" loc a ] ]
+ [ [ a = ANTIQUOT "stri" -> antiquot "stri" _loc a
+ | a = ANTIQUOT -> antiquot "" _loc a ] ]
;
module_type: LEVEL "simple"
- [ [ a = ANTIQUOT "mtyp" -> antiquot "mtyp" loc a
- | a = ANTIQUOT -> antiquot "" loc a ] ]
+ [ [ a = ANTIQUOT "mtyp" -> antiquot "mtyp" _loc a
+ | a = ANTIQUOT -> antiquot "" _loc a ] ]
;
sig_item: LEVEL "top"
- [ [ a = ANTIQUOT "sigi" -> antiquot "sigi" loc a
- | a = ANTIQUOT -> antiquot "" loc a ] ]
+ [ [ a = ANTIQUOT "sigi" -> antiquot "sigi" _loc a
+ | a = ANTIQUOT -> antiquot "" _loc a ] ]
;
expr: LEVEL "simple"
- [ [ a = ANTIQUOT "exp" -> antiquot "exp" loc a
- | a = ANTIQUOT -> antiquot "" loc a
+ [ [ a = ANTIQUOT "exp" -> antiquot "exp" _loc a
+ | a = ANTIQUOT -> antiquot "" _loc a
| a = ANTIQUOT "anti" ->
- Qast.Node "ExAnt" [Qast.Loc; antiquot "anti" loc a]
+ Qast.Node "ExAnt" [Qast.Loc; antiquot "anti" _loc a]
| "("; el = a_list; ")" -> Qast.Node "ExTup" [Qast.Loc; el] ] ]
;
patt: LEVEL "simple"
- [ [ a = ANTIQUOT "pat" -> antiquot "pat" loc a
- | a = ANTIQUOT -> antiquot "" loc a
+ [ [ a = ANTIQUOT "pat" -> antiquot "pat" _loc a
+ | a = ANTIQUOT -> antiquot "" _loc a
| a = ANTIQUOT "anti" ->
- Qast.Node "PaAnt" [Qast.Loc; antiquot "anti" loc a]
+ Qast.Node "PaAnt" [Qast.Loc; antiquot "anti" _loc a]
| "("; pl = a_list; ")" -> Qast.Node "PaTup" [Qast.Loc; pl] ] ]
;
ipatt:
- [ [ a = ANTIQUOT "pat" -> antiquot "pat" loc a
- | a = ANTIQUOT -> antiquot "" loc a
+ [ [ a = ANTIQUOT "pat" -> antiquot "pat" _loc a
+ | a = ANTIQUOT -> antiquot "" _loc a
| a = ANTIQUOT "anti" ->
- Qast.Node "PaAnt" [Qast.Loc; antiquot "anti" loc a]
+ Qast.Node "PaAnt" [Qast.Loc; antiquot "anti" _loc a]
| "("; pl = a_list; ")" -> Qast.Node "PaTup" [Qast.Loc; pl] ] ]
;
ctyp: LEVEL "simple"
- [ [ a = ANTIQUOT "typ" -> antiquot "typ" loc a
- | a = ANTIQUOT -> antiquot "" loc a
+ [ [ a = ANTIQUOT "typ" -> antiquot "typ" _loc a
+ | a = ANTIQUOT -> antiquot "" _loc a
| "("; tl = a_list; ")" -> Qast.Node "TyTup" [Qast.Loc; tl] ] ]
;
class_expr: LEVEL "simple"
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
+ [ [ a = ANTIQUOT -> antiquot "" _loc a ] ]
;
class_str_item:
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
+ [ [ a = ANTIQUOT -> antiquot "" _loc a ] ]
;
class_sig_item:
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
+ [ [ a = ANTIQUOT -> antiquot "" _loc a ] ]
;
class_type:
- [ [ a = ANTIQUOT -> antiquot "" loc a ] ]
+ [ [ a = ANTIQUOT -> antiquot "" _loc a ] ]
;
expr: LEVEL "simple"
[ [ "{<"; fel = a_list; ">}" -> Qast.Node "ExOvr" [Qast.Loc; fel] ] ]
[ [ "#"; a = a_list -> Qast.Node "PaTyp" [Qast.Loc; a] ] ]
;
a_list:
- [ [ a = ANTIQUOT "list" -> antiquot "list" loc a ] ]
+ [ [ a = ANTIQUOT "list" -> antiquot "list" _loc a ] ]
;
a_opt:
- [ [ a = ANTIQUOT "opt" -> antiquot "opt" loc a ] ]
+ [ [ a = ANTIQUOT "opt" -> antiquot "opt" _loc a ] ]
;
a_UIDENT:
- [ [ a = ANTIQUOT "uid" -> antiquot "uid" loc a
- | a = ANTIQUOT -> antiquot "" loc a
+ [ [ a = ANTIQUOT "uid" -> antiquot "uid" _loc a
+ | a = ANTIQUOT -> antiquot "" _loc a
| i = UIDENT -> Qast.Str i ] ]
;
a_LIDENT:
- [ [ a = ANTIQUOT "lid" -> antiquot "lid" loc a
- | a = ANTIQUOT -> antiquot "" loc a
+ [ [ a = ANTIQUOT "lid" -> antiquot "lid" _loc a
+ | a = ANTIQUOT -> antiquot "" _loc a
| i = LIDENT -> Qast.Str i ] ]
;
a_INT:
- [ [ a = ANTIQUOT "int" -> antiquot "int" loc a
- | a = ANTIQUOT -> antiquot "" loc a
+ [ [ a = ANTIQUOT "int" -> antiquot "int" _loc a
+ | a = ANTIQUOT -> antiquot "" _loc a
| s = INT -> Qast.Str s ] ]
;
a_INT32:
- [ [ a = ANTIQUOT "int32" -> antiquot "int32" loc a
- | a = ANTIQUOT -> antiquot "" loc a
+ [ [ a = ANTIQUOT "int32" -> antiquot "int32" _loc a
+ | a = ANTIQUOT -> antiquot "" _loc a
| s = INT32 -> Qast.Str s ] ]
;
a_INT64:
- [ [ a = ANTIQUOT "int64" -> antiquot "int64" loc a
- | a = ANTIQUOT -> antiquot "" loc a
+ [ [ a = ANTIQUOT "int64" -> antiquot "int64" _loc a
+ | a = ANTIQUOT -> antiquot "" _loc a
| s = INT64 -> Qast.Str s ] ]
;
a_NATIVEINT:
- [ [ a = ANTIQUOT "nativeint" -> antiquot "nativeint" loc a
- | a = ANTIQUOT -> antiquot "" loc a
+ [ [ a = ANTIQUOT "nativeint" -> antiquot "nativeint" _loc a
+ | a = ANTIQUOT -> antiquot "" _loc a
| s = NATIVEINT -> Qast.Str s ] ]
;
a_FLOAT:
- [ [ a = ANTIQUOT "flo" -> antiquot "flo" loc a
- | a = ANTIQUOT -> antiquot "" loc a
+ [ [ a = ANTIQUOT "flo" -> antiquot "flo" _loc a
+ | a = ANTIQUOT -> antiquot "" _loc a
| s = FLOAT -> Qast.Str s ] ]
;
a_STRING:
- [ [ a = ANTIQUOT "str" -> antiquot "str" loc a
- | a = ANTIQUOT -> antiquot "" loc a
+ [ [ a = ANTIQUOT "str" -> antiquot "str" _loc a
+ | a = ANTIQUOT -> antiquot "" _loc a
| s = STRING -> Qast.Str s ] ]
;
a_CHAR:
- [ [ a = ANTIQUOT "chr" -> antiquot "chr" loc a
- | a = ANTIQUOT -> antiquot "" loc a
+ [ [ a = ANTIQUOT "chr" -> antiquot "chr" _loc a
+ | a = ANTIQUOT -> antiquot "" _loc a
| s = CHAR -> Qast.Str s ] ]
;
a_TILDEIDENT:
- [ [ "~"; a = ANTIQUOT -> antiquot "" loc a
+ [ [ "~"; a = ANTIQUOT -> antiquot "" _loc a
| s = TILDEIDENT -> Qast.Str s ] ]
;
a_LABEL:
[ [ s = LABEL -> Qast.Str s ] ]
;
a_QUESTIONIDENT:
- [ [ "?"; a = ANTIQUOT -> antiquot "" loc a
+ [ [ "?"; a = ANTIQUOT -> antiquot "" _loc a
| s = QUESTIONIDENT -> Qast.Str s ] ]
;
a_OPTLABEL:
let print_location loc =
if !(Pcaml.input_file) <> "-" then
let (fname, line, bp, ep) = Stdpp.line_of_loc !(Pcaml.input_file) loc in
- eprintf loc_fmt !(Pcaml.input_file) line bp ep
+ eprintf loc_fmt fname line bp ep
else
eprintf "At location %d-%d\n" (fst loc).Lexing.pos_cnum
(snd loc).Lexing.pos_cnum
"<file> Output on <file> instead of standard output.";
"-v", Arg.Unit print_version, "Print Camlp4 version and exit.";
"-version", Arg.Unit print_version_string,
- "Print Camlp4 version number and exit."]
+ "Print Camlp4 version number and exit.";
+ "-no_quot", Arg.Set Plexer.no_quotations,
+ " Don't parse quotations, allowing to use, e.g. \"<:>\" as token"]
;;
let anon_fun x = Pcaml.input_file := x; file_kind := file_kind_of_name x;;
let long_id_of_string_list loc sl =
match List.rev sl with
- [] -> error loc "bad ast"
+ [] -> error loc "bad ast in long ident"
| s :: sl -> mkli s (List.rev sl)
;;
| TyOlb (loc, lab, _) -> error loc "labelled type not allowed here"
| TyPol (loc, pl, t) -> mktyp loc (Ptyp_poly (pl, ctyp t))
| TyQuo (loc, s) -> mktyp loc (Ptyp_var s)
- | TyRec (loc, _, _) -> error loc "record type not allowed here"
- | TySum (loc, _, _) -> error loc "sum type not allowed here"
+ | TyRec (loc, _) -> error loc "record type not allowed here"
+ | TySum (loc, _) -> error loc "sum type not allowed here"
+ | TyPrv (loc, _) -> error loc "private type not allowed here"
| TyTup (loc, tl) -> mktyp loc (Ptyp_tuple (List.map ctyp tl))
| TyUid (loc, s) as t -> error (loc_of_ctyp t) "invalid type"
| TyVrn (loc, catl, ool) ->
;;
let mkmutable m = if m then Mutable else Immutable;;
let mkprivate m = if m then Private else Public;;
-let mktrecord (_, n, m, t) = n, mkmutable m, ctyp (mkpolytype t);;
-let mkvariant (_, c, tl) = c, List.map ctyp tl;;
-let type_decl tl cl =
+let mktrecord (loc, n, m, t) =
+ n, mkmutable m, ctyp (mkpolytype t), mkloc loc
+;;
+let mkvariant (loc, c, tl) = c, List.map ctyp tl, mkloc loc;;
+let rec type_decl tl cl loc m pflag =
function
- TyMan (loc, t, TyRec (_, pflag, ltl)) ->
- mktype loc tl cl
- (Ptype_record (List.map mktrecord ltl, mkprivate pflag))
- (Some (ctyp t))
- | TyMan (loc, t, TySum (_, pflag, ctl)) ->
+ TyMan (_, t1, t2) -> type_decl tl cl loc (Some (ctyp t1)) pflag t2
+ | TyPrv (_, t) -> type_decl tl cl loc m true t
+ | TyRec (_, ltl) ->
mktype loc tl cl
- (Ptype_variant (List.map mkvariant ctl, mkprivate pflag))
- (Some (ctyp t))
- | TyRec (loc, pflag, ltl) ->
+ (Ptype_record (List.map mktrecord ltl, mkprivate pflag)) m
+ | TySum (_, ctl) ->
mktype loc tl cl
- (Ptype_record (List.map mktrecord ltl, mkprivate pflag)) None
- | TySum (loc, pflag, ctl) ->
- mktype loc tl cl
- (Ptype_variant (List.map mkvariant ctl, mkprivate pflag)) None
+ (Ptype_variant (List.map mkvariant ctl, mkprivate pflag)) m
| t ->
- let m =
- match t with
- TyQuo (_, s) -> if List.mem_assoc s tl then Some (ctyp t) else None
- | _ -> Some (ctyp t)
- in
- mktype (loc_of_ctyp t) tl cl Ptype_abstract m
+ if m <> None then
+ error loc "only one manifest type allowed by definition"
+ else
+ let m =
+ match t with
+ TyQuo (_, s) ->
+ if List.mem_assoc s tl then Some (ctyp t) else None
+ | _ -> Some (ctyp t)
+ in
+ let k = if pflag then Ptype_private else Ptype_abstract in
+ mktype loc tl cl k m
;;
+let type_decl tl cl t = type_decl tl cl (loc_of_ctyp t) None false t;;
+
let mkvalue_desc t p = {pval_type = ctyp t; pval_prim = p};;
let option f =
let lab =
match lab, peoo with
"", Some ((PaLid (_, i) | PaTyc (_, PaLid (_, i), _)), _) -> i
- | "", _ -> error loc "bad ast"
+ | "", _ -> error loc "bad ast in label"
| _ -> lab
in
let (p, eo) =
| PaArr (loc, pl) -> mkpat loc (Ppat_array (List.map patt pl))
| PaChr (loc, s) ->
mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s)))
- | PaInt (loc, s) -> mkpat loc (Ppat_constant (Const_int (int_of_string s)))
+ | PaInt (loc, s) ->
+ let i =
+ try int_of_string s with
+ Failure _ ->
+ error loc "Integer literal exceeds the range of representable integers of type int"
+ in
+ mkpat loc (Ppat_constant (Const_int i))
| PaInt32 (loc, s) ->
- mkpat loc (Ppat_constant (Const_int32 (Int32.of_string s)))
+ let i32 =
+ try Int32.of_string s with
+ Failure _ ->
+ error loc "Integer literal exceeds the range of representable integers of type int32"
+ in
+ mkpat loc (Ppat_constant (Const_int32 i32))
| PaInt64 (loc, s) ->
- mkpat loc (Ppat_constant (Const_int64 (Int64.of_string s)))
+ let i64 =
+ try Int64.of_string s with
+ Failure _ ->
+ error loc "Integer literal exceeds the range of representable integers of type int64"
+ in
+ mkpat loc (Ppat_constant (Const_int64 i64))
| PaNativeInt (loc, s) ->
- mkpat loc (Ppat_constant (Const_nativeint (Nativeint.of_string s)))
+ let nati =
+ try Nativeint.of_string s with
+ Failure _ ->
+ error loc "Integer literal exceeds the range of representable integers of type nativeint"
+ in
+ mkpat loc (Ppat_constant (Const_nativeint nati))
| PaFlo (loc, s) -> mkpat loc (Ppat_constant (Const_float s))
| PaLab (loc, _, _) -> error loc "labeled pattern not allowed here"
| PaLid (loc, s) -> mkpat loc (Ppat_var s)
| (loc, ml, ExLid (_, s)) :: l ->
mkexp loc (Pexp_ident (mkli s ml)), l
| (_, [], e) :: l -> expr e, l
- | _ -> error loc "bad ast"
+ | _ -> error loc "bad ast in expression"
in
let (_, e) =
List.fold_left
mkexp loc (Pexp_function ("", None, List.map mkpwe pel))
| ExIfe (loc, e1, e2, e3) ->
mkexp loc (Pexp_ifthenelse (expr e1, expr e2, Some (expr e3)))
- | ExInt (loc, s) -> mkexp loc (Pexp_constant (Const_int (int_of_string s)))
+ | ExInt (loc, s) ->
+ let i =
+ try int_of_string s with
+ Failure _ ->
+ error loc "Integer literal exceeds the range of representable integers of type int"
+ in
+ mkexp loc (Pexp_constant (Const_int i))
| ExInt32 (loc, s) ->
- mkexp loc (Pexp_constant (Const_int32 (Int32.of_string s)))
+ let i32 =
+ try Int32.of_string s with
+ Failure _ ->
+ error loc "Integer literal exceeds the range of representable integers of type int32"
+ in
+ mkexp loc (Pexp_constant (Const_int32 i32))
| ExInt64 (loc, s) ->
- mkexp loc (Pexp_constant (Const_int64 (Int64.of_string s)))
+ let i64 =
+ try Int64.of_string s with
+ Failure _ ->
+ error loc "Integer literal exceeds the range of representable integers of type int64"
+ in
+ mkexp loc (Pexp_constant (Const_int64 i64))
| ExNativeInt (loc, s) ->
- mkexp loc (Pexp_constant (Const_nativeint (Nativeint.of_string s)))
+ let nati =
+ try Nativeint.of_string s with
+ Failure _ ->
+ error loc "Integer literal exceeds the range of representable integers of type nativeint"
+ in
+ mkexp loc (Pexp_constant (Const_nativeint nati))
| ExLab (loc, _, _) -> error loc "labeled expression not allowed here"
| ExLaz (loc, e) -> mkexp loc (Pexp_lazy (expr e))
| ExLet (loc, rf, pel, e) ->
ExLid (_, i) | ExUid (_, i) -> [i]
| ExAcc (_, e, ExLid (_, i)) | ExAcc (_, e, ExUid (_, i)) ->
loop e @ [i]
- | e -> raise_with_loc (loc_of_expr e) (Failure "bad ast")
+ | e ->
+ raise_with_loc (loc_of_expr e) (Failure "bad ast in directive")
in
loop e
in
| TyOlb of loc * string * ctyp
| TyPol of loc * string list * ctyp
| TyQuo of loc * string
- | TyRec of loc * bool * (loc * string * bool * ctyp) list
- | TySum of loc * bool * (loc * string * ctyp list) list
+ | TyRec of loc * (loc * string * bool * ctyp) list
+ | TySum of loc * (loc * string * ctyp list) list
+ | TyPrv of loc * ctyp
| TyTup of loc * ctyp list
| TyUid of loc * string
| TyVrn of loc * row_field list * string list option option
[[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
Gramext.Stoken ("EOI", "")],
Gramext.action
- (fun _ (x : 'expr) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (x : 'expr) (_loc : Lexing.position * Lexing.position) ->
(x : 'expr_eoi))]];
Grammar.Entry.obj (patt_eoi : 'patt_eoi Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
Gramext.Stoken ("EOI", "")],
Gramext.action
- (fun _ (x : 'patt) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (x : 'patt) (_loc : Lexing.position * Lexing.position) ->
(x : 'patt_eoi))]]];;
let handle_expr_quotation loc x =
| TyOlb (loc, x1, x2) -> TyOlb (floc loc, x1, self x2)
| TyPol (loc, x1, x2) -> TyPol (floc loc, x1, self x2)
| TyQuo (loc, x1) -> TyQuo (floc loc, x1)
- | TyRec (loc, pflag, x1) ->
+ | TyRec (loc, x1) ->
TyRec
- (floc loc, pflag,
+ (floc loc,
List.map (fun (loc, x1, x2, x3) -> floc loc, x1, x2, self x3) x1)
- | TySum (loc, pflag, x1) ->
+ | TySum (loc, x1) ->
TySum
- (floc loc, pflag,
+ (floc loc,
List.map (fun (loc, x1, x2) -> floc loc, x1, List.map self x2) x1)
+ | TyPrv (loc, x1) -> TyPrv (floc loc, self x1)
| TyTup (loc, x1) -> TyTup (floc loc, List.map self x1)
| TyUid (loc, x1) -> TyUid (floc loc, x1)
| TyVrn (loc, x1, x2) ->
| SL (np, LO, x) -> n_print_string pos spc np x, 0
| SL (np, NO, x) -> n_print_string pos 0 np x, 0
| SL (np, LR, x) -> n_print_string pos spc np x, 1
- | HL x as p -> print_horiz tab pos spc x
+ | HL x -> print_horiz tab pos spc x
| BL x as p -> print_horiz_vertic tab pos spc (too_long tab (pos, spc) p) x
| PL x as p -> print_paragraph tab pos spc (too_long tab (pos, spc) p) x
| QL x as p -> print_sparagraph tab pos spc (too_long tab (pos, spc) p) x
SHELL=/bin/sh
TARGET=gramlib.cma
+.PHONY: opt all clean depend promote compare install installopt
+
all: $(TARGET)
opt: opt$(PROFILING)
m :: ml as gml ->
if m1.has_when && not m.has_when then m1 :: gml
else if not m1.has_when && m.has_when then m :: loop ml
- else
- let c = compare m1.patt m.patt in
- if c < 0 then m1 :: gml
- else if c > 0 then m :: loop ml
- else if m.has_when then m1 :: gml
- else m1 :: ml
+ else if compare m1.patt m.patt = 0 then
+ if not m1.has_when then m1 :: ml else m1 :: gml
+ else m :: loop ml
| [] -> [m1]
in
loop matchings
let rec get_token_list entry tokl last_tok tree =
match tree with
- Node {node = Stoken tok as s; son = son; brother = DeadEnd} ->
+ Node {node = Stoken tok; son = son; brother = DeadEnd} ->
get_token_list entry (last_tok :: tokl) tok son
| _ ->
if tokl = [] then None
begin match Stream.peek strm__ with
Some ':' ->
Stream.junk strm__;
- let eb = Stream.count strm__ in
+ let ep = Stream.count strm__ in
error_if_keyword (("LABEL", id), (bp, ep))
| _ -> error_if_keyword (("TILDEIDENT", id), (bp, ep))
end
begin match Stream.peek strm__ with
Some ':' ->
Stream.junk strm__;
- let eb = Stream.count strm__ in
+ let ep = Stream.count strm__ in
error_if_keyword (("OPTLABEL", id), (bp, ep))
| _ -> error_if_keyword (("QUESTIONIDENT", id), (bp, ep))
end
match Stream.peek strm__ with
Some '\010' ->
Stream.junk strm__;
- let s = strm__ in
+ let _s = strm__ in
let ep = Stream.count strm__ in bolpos := ep; incr lnum
| Some '\013' ->
Stream.junk strm__;
with
Stream.Failure -> raise (Stream.Error "")
in
- let ep = Stream.count strm__ in ()
+ ()
| Some ('>' | '|') ->
Stream.junk strm__;
let _ =
let id_table = Hashtbl.create 301 in
let glexr =
ref
- {tok_func = (fun _ -> raise (Match_failure ("", 772, 17)));
- tok_using = (fun _ -> raise (Match_failure ("", 772, 37)));
- tok_removing = (fun _ -> raise (Match_failure ("", 772, 60)));
- tok_match = (fun _ -> raise (Match_failure ("", 773, 18)));
- tok_text = (fun _ -> raise (Match_failure ("", 773, 37)));
+ {tok_func = (fun _ -> raise (Match_failure ("", 774, 17)));
+ tok_using = (fun _ -> raise (Match_failure ("", 774, 37)));
+ tok_removing = (fun _ -> raise (Match_failure ("", 774, 60)));
+ tok_match = (fun _ -> raise (Match_failure ("", 775, 18)));
+ tok_text = (fun _ -> raise (Match_failure ("", 775, 37)));
tok_comm = None}
in
let (f, pos) = func kwd_table glexr in
let id_table = Hashtbl.create 301 in
let glexr =
ref
- {tok_func = (fun _ -> raise (Match_failure ("", 806, 17)));
- tok_using = (fun _ -> raise (Match_failure ("", 806, 37)));
- tok_removing = (fun _ -> raise (Match_failure ("", 806, 60)));
- tok_match = (fun _ -> raise (Match_failure ("", 807, 18)));
- tok_text = (fun _ -> raise (Match_failure ("", 807, 37)));
+ {tok_func = (fun _ -> raise (Match_failure ("", 808, 17)));
+ tok_using = (fun _ -> raise (Match_failure ("", 808, 37)));
+ tok_removing = (fun _ -> raise (Match_failure ("", 808, 60)));
+ tok_match = (fun _ -> raise (Match_failure ("", 809, 18)));
+ tok_text = (fun _ -> raise (Match_failure ("", 809, 37)));
tok_comm = None}
in
{func = fst (func kwd_table glexr); using = using_token kwd_table id_table;
;
*)
-let loc_name = ref "loc";;
+let loc_name = ref "_loc";;
| '\\' -> '\\', i + 1
| '\"' -> '\"', i + 1
| '\'' -> '\'', i + 1
+ | ' ' -> ' ', i + 1
| '0'..'9' as c -> backslash1 (valch c) s (i + 1)
| 'x' -> backslash1h s (i + 1)
| _ -> raise Not_found
ht
;;
-let locate n = let loc = n.loc in n.expr;;
+let locate n = let _loc = n.loc in n.expr;;
let new_type_var =
let i = ref 0 in fun () -> incr i; "e__" ^ string_of_int !i
rl
;;
-let retype_rule_list_without_patterns loc rl =
+let retype_rule_list_without_patterns _loc rl =
try
List.map
(function
{prod = [{pattern = None; symbol = s}]; action = None} ->
- {prod = [{pattern = Some (MLast.PaLid (loc, "x")); symbol = s}];
- action = Some (MLast.ExLid (loc, "x"))}
+ {prod = [{pattern = Some (MLast.PaLid (_loc, "x")); symbol = s}];
+ action = Some (MLast.ExLid (_loc, "x"))}
| {prod = []; action = Some _} as r -> r
| _ -> raise Exit)
rl
in
failwith (f ^ ", not impl: " ^ desc)
;;
- let loc =
+ let _loc =
let nowhere =
{(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0}
in
;;
let rec mlist mf =
function
- [] -> MLast.ExUid (loc, "[]")
+ [] -> MLast.ExUid (_loc, "[]")
| x :: l ->
MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), mf x),
+ (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), mf x),
mlist mf l)
;;
let moption mf =
function
- None -> MLast.ExUid (loc, "None")
- | Some x -> MLast.ExApp (loc, MLast.ExUid (loc, "Some"), mf x)
+ None -> MLast.ExUid (_loc, "None")
+ | Some x -> MLast.ExApp (_loc, MLast.ExUid (_loc, "Some"), mf x)
;;
let mbool =
function
- false -> MLast.ExUid (loc, "False")
- | true -> MLast.ExUid (loc, "True")
+ false -> MLast.ExUid (_loc, "False")
+ | true -> MLast.ExUid (_loc, "True")
;;
let mloc =
MLast.ExLet
- (loc, false,
- [MLast.PaLid (loc, "nowhere"),
+ (_loc, false,
+ [MLast.PaLid (_loc, "nowhere"),
MLast.ExRec
- (loc,
+ (_loc,
[MLast.PaAcc
- (loc, MLast.PaUid (loc, "Lexing"),
- MLast.PaLid (loc, "pos_lnum")),
- MLast.ExInt (loc, "1");
+ (_loc, MLast.PaUid (_loc, "Lexing"),
+ MLast.PaLid (_loc, "pos_lnum")),
+ MLast.ExInt (_loc, "1");
MLast.PaAcc
- (loc, MLast.PaUid (loc, "Lexing"),
- MLast.PaLid (loc, "pos_cnum")),
- MLast.ExInt (loc, "0")],
+ (_loc, MLast.PaUid (_loc, "Lexing"),
+ MLast.PaLid (_loc, "pos_cnum")),
+ MLast.ExInt (_loc, "0")],
Some
(MLast.ExAcc
- (loc, MLast.ExUid (loc, "Lexing"),
- MLast.ExLid (loc, "dummy_pos"))))],
+ (_loc, MLast.ExUid (_loc, "Lexing"),
+ MLast.ExLid (_loc, "dummy_pos"))))],
MLast.ExTup
- (loc,
- [MLast.ExLid (loc, "nowhere"); MLast.ExLid (loc, "nowhere")]))
+ (_loc,
+ [MLast.ExLid (_loc, "nowhere"); MLast.ExLid (_loc, "nowhere")]))
;;
let rec mexpr =
function
- MLast.ExAcc (loc, e1, e2) ->
+ MLast.ExAcc (_loc, e1, e2) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExAcc")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExAcc")),
mloc),
mexpr e1),
mexpr e2)
- | MLast.ExApp (loc, e1, e2) ->
+ | MLast.ExApp (_loc, e1, e2) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExApp")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExApp")),
mloc),
mexpr e1),
mexpr e2)
- | MLast.ExChr (loc, s) ->
+ | MLast.ExChr (_loc, s) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExChr")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExChr")),
mloc),
- MLast.ExStr (loc, s))
- | MLast.ExFun (loc, pwel) ->
+ MLast.ExStr (_loc, s))
+ | MLast.ExFun (_loc, pwel) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExFun")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExFun")),
mloc),
mlist mpwe pwel)
- | MLast.ExIfe (loc, e1, e2, e3) ->
+ | MLast.ExIfe (_loc, e1, e2, e3) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExIfe")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExIfe")),
mloc),
mexpr e1),
mexpr e2),
mexpr e3)
- | MLast.ExInt (loc, s) ->
+ | MLast.ExInt (_loc, s) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExInt")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExInt")),
mloc),
- MLast.ExStr (loc, s))
- | MLast.ExFlo (loc, s) ->
+ MLast.ExStr (_loc, s))
+ | MLast.ExFlo (_loc, s) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExFlo")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExFlo")),
mloc),
- MLast.ExStr (loc, s))
- | MLast.ExLet (loc, rf, pel, e) ->
+ MLast.ExStr (_loc, s))
+ | MLast.ExLet (_loc, rf, pel, e) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExLet")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExLet")),
mloc),
mbool rf),
mlist mpe pel),
mexpr e)
- | MLast.ExLid (loc, s) ->
+ | MLast.ExLid (_loc, s) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExLid")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExLid")),
mloc),
- MLast.ExStr (loc, s))
- | MLast.ExMat (loc, e, pwel) ->
+ MLast.ExStr (_loc, s))
+ | MLast.ExMat (_loc, e, pwel) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExMat")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExMat")),
mloc),
mexpr e),
mlist mpwe pwel)
- | MLast.ExRec (loc, pel, eo) ->
+ | MLast.ExRec (_loc, pel, eo) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExRec")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExRec")),
mloc),
mlist mpe pel),
moption mexpr eo)
- | MLast.ExSeq (loc, el) ->
+ | MLast.ExSeq (_loc, el) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExSeq")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExSeq")),
mloc),
mlist mexpr el)
- | MLast.ExSte (loc, e1, e2) ->
+ | MLast.ExSte (_loc, e1, e2) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExSte")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExSte")),
mloc),
mexpr e1),
mexpr e2)
- | MLast.ExStr (loc, s) ->
+ | MLast.ExStr (_loc, s) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExStr")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExStr")),
mloc),
- MLast.ExStr (loc, String.escaped s))
- | MLast.ExTry (loc, e, pwel) ->
+ MLast.ExStr (_loc, String.escaped s))
+ | MLast.ExTry (_loc, e, pwel) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExTry")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExTry")),
mloc),
mexpr e),
mlist mpwe pwel)
- | MLast.ExTup (loc, el) ->
+ | MLast.ExTup (_loc, el) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExTup")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExTup")),
mloc),
mlist mexpr el)
- | MLast.ExTyc (loc, e, t) ->
+ | MLast.ExTyc (_loc, e, t) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExTyc")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExTyc")),
mloc),
mexpr e),
mctyp t)
- | MLast.ExUid (loc, s) ->
+ | MLast.ExUid (_loc, s) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "ExUid")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "ExUid")),
mloc),
- MLast.ExStr (loc, s))
+ MLast.ExStr (_loc, s))
| x -> not_impl "mexpr" x
and mpatt =
function
- MLast.PaAcc (loc, p1, p2) ->
+ MLast.PaAcc (_loc, p1, p2) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaAcc")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "PaAcc")),
mloc),
mpatt p1),
mpatt p2)
- | MLast.PaAny loc ->
+ | MLast.PaAny _loc ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"), MLast.ExUid (loc, "PaAny")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "PaAny")),
mloc)
- | MLast.PaApp (loc, p1, p2) ->
+ | MLast.PaApp (_loc, p1, p2) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaApp")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "PaApp")),
mloc),
mpatt p1),
mpatt p2)
- | MLast.PaInt (loc, s) ->
+ | MLast.PaInt (_loc, s) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaInt")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "PaInt")),
mloc),
- MLast.ExStr (loc, s))
- | MLast.PaLid (loc, s) ->
+ MLast.ExStr (_loc, s))
+ | MLast.PaLid (_loc, s) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaLid")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "PaLid")),
mloc),
- MLast.ExStr (loc, s))
- | MLast.PaOrp (loc, p1, p2) ->
+ MLast.ExStr (_loc, s))
+ | MLast.PaOrp (_loc, p1, p2) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaOrp")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "PaOrp")),
mloc),
mpatt p1),
mpatt p2)
- | MLast.PaStr (loc, s) ->
+ | MLast.PaStr (_loc, s) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaStr")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "PaStr")),
mloc),
- MLast.ExStr (loc, String.escaped s))
- | MLast.PaTup (loc, pl) ->
+ MLast.ExStr (_loc, String.escaped s))
+ | MLast.PaTup (_loc, pl) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaTup")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "PaTup")),
mloc),
mlist mpatt pl)
- | MLast.PaTyc (loc, p, t) ->
+ | MLast.PaTyc (_loc, p, t) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaTyc")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "PaTyc")),
mloc),
mpatt p),
mctyp t)
- | MLast.PaUid (loc, s) ->
+ | MLast.PaUid (_loc, s) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "PaUid")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "PaUid")),
mloc),
- MLast.ExStr (loc, s))
+ MLast.ExStr (_loc, s))
| x -> not_impl "mpatt" x
and mctyp =
function
- MLast.TyAcc (loc, t1, t2) ->
+ MLast.TyAcc (_loc, t1, t2) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "TyAcc")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "TyAcc")),
mloc),
mctyp t1),
mctyp t2)
| MLast.TyApp (loc, t1, t2) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "TyApp")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "TyApp")),
mloc),
mctyp t1),
mctyp t2)
- | MLast.TyLid (loc, s) ->
+ | MLast.TyLid (_loc, s) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "TyLid")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "TyLid")),
mloc),
- MLast.ExStr (loc, s))
- | MLast.TyQuo (loc, s) ->
+ MLast.ExStr (_loc, s))
+ | MLast.TyQuo (_loc, s) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "TyQuo")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "TyQuo")),
mloc),
- MLast.ExStr (loc, s))
- | MLast.TyTup (loc, tl) ->
+ MLast.ExStr (_loc, s))
+ | MLast.TyTup (_loc, tl) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "TyTup")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "TyTup")),
mloc),
mlist mctyp tl)
- | MLast.TyUid (loc, s) ->
+ | MLast.TyUid (_loc, s) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"),
- MLast.ExUid (loc, "TyUid")),
+ (_loc, MLast.ExUid (_loc, "MLast"),
+ MLast.ExUid (_loc, "TyUid")),
mloc),
- MLast.ExStr (loc, s))
+ MLast.ExStr (_loc, s))
| x -> not_impl "mctyp" x
- and mpe (p, e) = MLast.ExTup (loc, [mpatt p; mexpr e])
+ and mpe (p, e) = MLast.ExTup (_loc, [mpatt p; mexpr e])
and mpwe (p, w, e) =
- MLast.ExTup (loc, [mpatt p; moption mexpr w; mexpr e])
+ MLast.ExTup (_loc, [mpatt p; moption mexpr w; mexpr e])
;;
end
;;
-let mklistexp loc =
+let mklistexp _loc =
let rec loop top =
function
- [] -> MLast.ExUid (loc, "[]")
+ [] -> MLast.ExUid (_loc, "[]")
| e1 :: el ->
- let loc = if top then loc else fst (MLast.loc_of_expr e1), snd loc in
+ let _loc =
+ if top then _loc else fst (MLast.loc_of_expr e1), snd _loc
+ in
MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e1), loop false el)
+ (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), e1),
+ loop false el)
in
loop true
;;
-let mklistpat loc =
+let mklistpat _loc =
let rec loop top =
function
- [] -> MLast.PaUid (loc, "[]")
+ [] -> MLast.PaUid (_loc, "[]")
| p1 :: pl ->
- let loc = if top then loc else fst (MLast.loc_of_patt p1), snd loc in
+ let _loc =
+ if top then _loc else fst (MLast.loc_of_patt p1), snd _loc
+ in
MLast.PaApp
- (loc, MLast.PaApp (loc, MLast.PaUid (loc, "::"), p1), loop false pl)
+ (_loc, MLast.PaApp (_loc, MLast.PaUid (_loc, "::"), p1),
+ loop false pl)
in
loop true
;;
;;
let rec quot_expr e =
- let loc = MLast.loc_of_expr e in
+ let _loc = MLast.loc_of_expr e in
match e with
MLast.ExUid (_, "None") ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")),
- MLast.ExUid (loc, "None"))
+ (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Option")),
+ MLast.ExUid (_loc, "None"))
| MLast.ExApp (_, MLast.ExUid (_, "Some"), e) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")),
- MLast.ExApp (loc, MLast.ExUid (loc, "Some"), quot_expr e))
+ (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Option")),
+ MLast.ExApp (_loc, MLast.ExUid (_loc, "Some"), quot_expr e))
| MLast.ExUid (_, "False") ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Bool")),
- MLast.ExUid (loc, "False"))
+ (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Bool")),
+ MLast.ExUid (_loc, "False"))
| MLast.ExUid (_, "True") ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Bool")),
- MLast.ExUid (loc, "True"))
+ (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Bool")),
+ MLast.ExUid (_loc, "True"))
| MLast.ExUid (_, "()") -> e
| MLast.ExApp
(_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "List")),
e
| MLast.ExUid (_, "[]") ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")),
- MLast.ExUid (loc, "[]"))
+ (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "List")),
+ MLast.ExUid (_loc, "[]"))
| MLast.ExApp
(_, MLast.ExApp (_, MLast.ExUid (_, "::"), e), MLast.ExUid (_, "[]")) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")),
+ (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "List")),
MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), quot_expr e),
- MLast.ExUid (loc, "[]")))
+ (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), quot_expr e),
+ MLast.ExUid (_loc, "[]")))
| MLast.ExApp (_, MLast.ExApp (_, MLast.ExUid (_, "::"), e1), e2) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Cons")),
+ (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Cons")),
quot_expr e1),
quot_expr e2)
| MLast.ExApp (_, _, _) ->
MLast.ExUid (_, c) ->
let al = List.map quot_expr al in
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
- MLast.ExStr (loc, c)),
- mklistexp loc al)
+ (_loc, MLast.ExUid (_loc, "Qast"),
+ MLast.ExUid (_loc, "Node")),
+ MLast.ExStr (_loc, c)),
+ mklistexp _loc al)
| MLast.ExAcc (_, MLast.ExUid (_, "MLast"), MLast.ExUid (_, c)) ->
let al = List.map quot_expr al in
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
- MLast.ExStr (loc, c)),
- mklistexp loc al)
+ (_loc, MLast.ExUid (_loc, "Qast"),
+ MLast.ExUid (_loc, "Node")),
+ MLast.ExStr (_loc, c)),
+ mklistexp _loc al)
| MLast.ExAcc (_, MLast.ExUid (_, m), MLast.ExUid (_, c)) ->
let al = List.map quot_expr al in
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
- MLast.ExStr (loc, (m ^ "." ^ c))),
- mklistexp loc al)
+ (_loc, MLast.ExUid (_loc, "Qast"),
+ MLast.ExUid (_loc, "Node")),
+ MLast.ExStr (_loc, (m ^ "." ^ c))),
+ mklistexp _loc al)
| MLast.ExLid (_, f) ->
let al = List.map quot_expr al in
- List.fold_left (fun f e -> MLast.ExApp (loc, f, e))
- (MLast.ExLid (loc, f)) al
+ List.fold_left (fun f e -> MLast.ExApp (_loc, f, e))
+ (MLast.ExLid (_loc, f)) al
| _ -> e
end
| MLast.ExRec (_, pel, None) ->
(fun (p, e) ->
let lab =
match p with
- MLast.PaLid (_, c) -> MLast.ExStr (loc, c)
+ MLast.PaLid (_, c) -> MLast.ExStr (_loc, c)
| MLast.PaAcc (_, _, MLast.PaLid (_, c)) ->
- MLast.ExStr (loc, c)
+ MLast.ExStr (_loc, c)
| _ -> raise Not_found
in
- MLast.ExTup (loc, [lab; quot_expr e]))
+ MLast.ExTup (_loc, [lab; quot_expr e]))
pel
in
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Record")),
- mklistexp loc lel)
+ (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Record")),
+ mklistexp _loc lel)
with
Not_found -> e
end
| MLast.ExLid (_, s) ->
if s = !(Stdpp.loc_name) then
- MLast.ExAcc (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Loc"))
+ MLast.ExAcc
+ (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Loc"))
else e
| MLast.ExAcc (_, MLast.ExUid (_, "MLast"), MLast.ExUid (_, s)) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
- MLast.ExStr (loc, s)),
- MLast.ExUid (loc, "[]"))
+ (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Node")),
+ MLast.ExStr (_loc, s)),
+ MLast.ExUid (_loc, "[]"))
| MLast.ExAcc (_, MLast.ExUid (_, m), MLast.ExUid (_, s)) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
- MLast.ExStr (loc, (m ^ "." ^ s))),
- MLast.ExUid (loc, "[]"))
+ (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Node")),
+ MLast.ExStr (_loc, (m ^ "." ^ s))),
+ MLast.ExUid (_loc, "[]"))
| MLast.ExUid (_, s) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")),
- MLast.ExStr (loc, s)),
- MLast.ExUid (loc, "[]"))
+ (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Node")),
+ MLast.ExStr (_loc, s)),
+ MLast.ExUid (_loc, "[]"))
| MLast.ExStr (_, s) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Str")),
- MLast.ExStr (loc, s))
+ (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Str")),
+ MLast.ExStr (_loc, s))
| MLast.ExTup (_, el) ->
let el = List.map quot_expr el in
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Tuple")),
- mklistexp loc el)
+ (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Tuple")),
+ mklistexp _loc el)
| MLast.ExLet (_, r, pel, e) ->
let pel = List.map (fun (p, e) -> p, quot_expr e) pel in
- MLast.ExLet (loc, r, pel, quot_expr e)
+ MLast.ExLet (_loc, r, pel, quot_expr e)
| _ -> e
;;
(fun e ps ->
match ps.pattern with
Some (MLast.PaTup (_, pl)) ->
- let loc =
+ let _loc =
let nowhere =
{(Lexing.dummy_pos) with Lexing.pos_lnum = 1;
Lexing.pos_cnum = 0}
([], 1) pl
in
let l = List.rev l in
- List.map (fun s -> MLast.PaLid (loc, s)) l,
- List.map (fun s -> MLast.ExLid (loc, s)) l
+ List.map (fun s -> MLast.PaLid (_loc, s)) l,
+ List.map (fun s -> MLast.ExLid (_loc, s)) l
in
MLast.ExLet
- (loc, false,
- [MLast.PaTup (loc, pl),
+ (_loc, false,
+ [MLast.PaTup (_loc, pl),
MLast.ExMat
- (loc, MLast.ExLid (loc, pname),
+ (_loc, MLast.ExLid (_loc, pname),
[MLast.PaApp
- (loc,
+ (_loc,
MLast.PaAcc
- (loc, MLast.PaUid (loc, "Qast"),
- MLast.PaUid (loc, "Tuple")),
- mklistpat loc pl1),
- None, MLast.ExTup (loc, el1);
- MLast.PaAny loc, None,
- MLast.ExMat (loc, MLast.ExUid (loc, "()"), [])])],
+ (_loc, MLast.PaUid (_loc, "Qast"),
+ MLast.PaUid (_loc, "Tuple")),
+ mklistpat _loc pl1),
+ None, MLast.ExTup (_loc, el1);
+ MLast.PaAny _loc, None,
+ MLast.ExMat (_loc, MLast.ExUid (_loc, "()"), [])])],
e)
| _ -> e)
e psl
let rec make_ctyp styp tvar =
match styp with
- STlid (loc, s) -> MLast.TyLid (loc, s)
- | STapp (loc, t1, t2) ->
- MLast.TyApp (loc, make_ctyp t1 tvar, make_ctyp t2 tvar)
- | STquo (loc, s) -> MLast.TyQuo (loc, s)
- | STself (loc, x) ->
+ STlid (_loc, s) -> MLast.TyLid (_loc, s)
+ | STapp (_loc, t1, t2) ->
+ MLast.TyApp (_loc, make_ctyp t1 tvar, make_ctyp t2 tvar)
+ | STquo (_loc, s) -> MLast.TyQuo (_loc, s)
+ | STself (_loc, x) ->
if tvar = "" then
- Stdpp.raise_with_loc loc
+ Stdpp.raise_with_loc _loc
(Stream.Error ("'" ^ x ^ "' illegal in anonymous entry level"))
- else MLast.TyQuo (loc, tvar)
+ else MLast.TyQuo (_loc, tvar)
| STtyp t -> t
;;
let rec make_expr gmod tvar =
function
- TXmeta (loc, n, tl, e, t) ->
+ TXmeta (_loc, n, tl, e, t) ->
let el =
List.fold_right
(fun t el ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc, MLast.ExUid (loc, "::"), make_expr gmod "" t),
+ (_loc, MLast.ExUid (_loc, "::"), make_expr gmod "" t),
el))
- tl (MLast.ExUid (loc, "[]"))
+ tl (MLast.ExUid (_loc, "[]"))
in
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Smeta")),
- MLast.ExStr (loc, n)),
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExUid (_loc, "Smeta")),
+ MLast.ExStr (_loc, n)),
el),
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Obj"), MLast.ExLid (loc, "repr")),
- MLast.ExTyc (loc, e, make_ctyp t tvar)))
- | TXlist (loc, min, t, ts) ->
+ (_loc, MLast.ExUid (_loc, "Obj"), MLast.ExLid (_loc, "repr")),
+ MLast.ExTyc (_loc, e, make_ctyp t tvar)))
+ | TXlist (_loc, min, t, ts) ->
let txt = make_expr gmod "" t in
begin match min, ts with
false, None ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Slist0")),
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExUid (_loc, "Slist0")),
txt)
| true, None ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Slist1")),
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExUid (_loc, "Slist1")),
txt)
| false, Some s ->
let x = make_expr gmod tvar s in
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Slist0sep")),
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExUid (_loc, "Slist0sep")),
txt),
x)
| true, Some s ->
let x = make_expr gmod tvar s in
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Slist1sep")),
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExUid (_loc, "Slist1sep")),
txt),
x)
end
- | TXnext loc ->
+ | TXnext _loc ->
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Snext"))
- | TXnterm (loc, n, lev) ->
+ (_loc, MLast.ExUid (_loc, "Gramext"), MLast.ExUid (_loc, "Snext"))
+ | TXnterm (_loc, n, lev) ->
begin match lev with
Some lab ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Snterml")),
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExUid (_loc, "Snterml")),
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, gmod),
- MLast.ExUid (loc, "Entry")),
- MLast.ExLid (loc, "obj")),
+ (_loc, MLast.ExUid (_loc, gmod),
+ MLast.ExUid (_loc, "Entry")),
+ MLast.ExLid (_loc, "obj")),
MLast.ExTyc
- (loc, n.expr,
+ (_loc, n.expr,
MLast.TyApp
- (loc,
+ (_loc,
MLast.TyAcc
- (loc,
+ (_loc,
MLast.TyAcc
- (loc, MLast.TyUid (loc, gmod),
- MLast.TyUid (loc, "Entry")),
- MLast.TyLid (loc, "e")),
- MLast.TyQuo (loc, n.tvar))))),
- MLast.ExStr (loc, lab))
+ (_loc, MLast.TyUid (_loc, gmod),
+ MLast.TyUid (_loc, "Entry")),
+ MLast.TyLid (_loc, "e")),
+ MLast.TyQuo (_loc, n.tvar))))),
+ MLast.ExStr (_loc, lab))
| None ->
if n.tvar = tvar then
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Sself"))
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExUid (_loc, "Sself"))
else
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Snterm")),
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExUid (_loc, "Snterm")),
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, gmod),
- MLast.ExUid (loc, "Entry")),
- MLast.ExLid (loc, "obj")),
+ (_loc, MLast.ExUid (_loc, gmod),
+ MLast.ExUid (_loc, "Entry")),
+ MLast.ExLid (_loc, "obj")),
MLast.ExTyc
- (loc, n.expr,
+ (_loc, n.expr,
MLast.TyApp
- (loc,
+ (_loc,
MLast.TyAcc
- (loc,
+ (_loc,
MLast.TyAcc
- (loc, MLast.TyUid (loc, gmod),
- MLast.TyUid (loc, "Entry")),
- MLast.TyLid (loc, "e")),
- MLast.TyQuo (loc, n.tvar)))))
+ (_loc, MLast.TyUid (_loc, gmod),
+ MLast.TyUid (_loc, "Entry")),
+ MLast.TyLid (_loc, "e")),
+ MLast.TyQuo (_loc, n.tvar)))))
end
- | TXopt (loc, t) ->
+ | TXopt (_loc, t) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Sopt")),
+ (_loc, MLast.ExUid (_loc, "Gramext"), MLast.ExUid (_loc, "Sopt")),
make_expr gmod "" t)
- | TXrules (loc, rl) ->
+ | TXrules (_loc, rl) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExLid (loc, "srules")),
- make_expr_rules loc gmod rl "")
- | TXself loc ->
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExLid (_loc, "srules")),
+ make_expr_rules _loc gmod rl "")
+ | TXself _loc ->
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Sself"))
- | TXtok (loc, s, e) ->
+ (_loc, MLast.ExUid (_loc, "Gramext"), MLast.ExUid (_loc, "Sself"))
+ | TXtok (_loc, s, e) ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Stoken")),
- MLast.ExTup (loc, [MLast.ExStr (loc, s); e]))
-and make_expr_rules loc gmod rl tvar =
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExUid (_loc, "Stoken")),
+ MLast.ExTup (_loc, [MLast.ExStr (_loc, s); e]))
+and make_expr_rules _loc gmod rl tvar =
List.fold_left
(fun txt (sl, ac) ->
let sl =
(fun t txt ->
let x = make_expr gmod tvar t in
MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), x), txt))
- sl (MLast.ExUid (loc, "[]"))
+ (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), x), txt))
+ sl (MLast.ExUid (_loc, "[]"))
in
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc, MLast.ExUid (loc, "::"), MLast.ExTup (loc, [sl; ac])),
+ (_loc, MLast.ExUid (_loc, "::"), MLast.ExTup (_loc, [sl; ac])),
txt))
- (MLast.ExUid (loc, "[]")) rl
+ (MLast.ExUid (_loc, "[]")) rl
;;
-let text_of_action loc psl rtvar act tvar =
- let locid = MLast.PaLid (loc, !(Stdpp.loc_name)) in
+let text_of_action _loc psl rtvar act tvar =
+ let locid = MLast.PaLid (_loc, !(Stdpp.loc_name)) in
let act =
match act with
Some act -> if !quotify then quotify_action psl act else act
- | None -> MLast.ExUid (loc, "()")
+ | None -> MLast.ExUid (_loc, "()")
in
let e =
MLast.ExFun
- (loc,
+ (_loc,
[MLast.PaTyc
- (loc, locid,
+ (_loc, locid,
MLast.TyTup
- (loc,
+ (_loc,
[MLast.TyAcc
- (loc, MLast.TyUid (loc, "Lexing"),
- MLast.TyLid (loc, "position"));
+ (_loc, MLast.TyUid (_loc, "Lexing"),
+ MLast.TyLid (_loc, "position"));
MLast.TyAcc
- (loc, MLast.TyUid (loc, "Lexing"),
- MLast.TyLid (loc, "position"))])),
- None, MLast.ExTyc (loc, act, MLast.TyQuo (loc, rtvar))])
+ (_loc, MLast.TyUid (_loc, "Lexing"),
+ MLast.TyLid (_loc, "position"))])),
+ None, MLast.ExTyc (_loc, act, MLast.TyQuo (_loc, rtvar))])
in
let txt =
List.fold_left
(fun txt ps ->
match ps.pattern with
- None -> MLast.ExFun (loc, [MLast.PaAny loc, None, txt])
+ None -> MLast.ExFun (_loc, [MLast.PaAny _loc, None, txt])
| Some p ->
let t = make_ctyp ps.symbol.styp tvar in
let p =
match p with
MLast.PaTup (_, pl) when !quotify ->
- MLast.PaLid (loc, pname_of_ptuple pl)
+ MLast.PaLid (_loc, pname_of_ptuple pl)
| _ -> p
in
- MLast.ExFun (loc, [MLast.PaTyc (loc, p, t), None, txt]))
+ MLast.ExFun (_loc, [MLast.PaTyc (_loc, p, t), None, txt]))
e psl
in
let txt =
if !meta_action then
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Obj"), MLast.ExLid (loc, "magic")),
+ (_loc, MLast.ExUid (_loc, "Obj"), MLast.ExLid (_loc, "magic")),
MetaAction.mexpr txt)
else txt
in
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExLid (loc, "action")),
+ (_loc, MLast.ExUid (_loc, "Gramext"), MLast.ExLid (_loc, "action")),
txt)
;;
rl
;;
-let expr_of_delete_rule loc gmod n sl =
+let expr_of_delete_rule _loc gmod n sl =
let sl =
List.fold_right
(fun s e ->
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc, MLast.ExUid (loc, "::"), make_expr gmod "" s.text),
+ (_loc, MLast.ExUid (_loc, "::"), make_expr gmod "" s.text),
e))
- sl (MLast.ExUid (loc, "[]"))
+ sl (MLast.ExUid (_loc, "[]"))
in
n.expr, sl
;;
TXlist (loc, min, symb.text, t)
;;
-let sstoken loc s =
- let n = mk_name loc (MLast.ExLid (loc, ("a_" ^ s))) in
- TXnterm (loc, n, None)
+let sstoken _loc s =
+ let n = mk_name _loc (MLast.ExLid (_loc, ("a_" ^ s))) in
+ TXnterm (_loc, n, None)
;;
let mk_psymbol p s t =
{pattern = Some p; symbol = symb}
;;
-let sslist loc min sep s =
+let sslist _loc min sep s =
let rl =
let r1 =
let prod =
- let n = mk_name loc (MLast.ExLid (loc, "a_list")) in
- [mk_psymbol (MLast.PaLid (loc, "a")) (TXnterm (loc, n, None))
- (STquo (loc, "a_list"))]
+ let n = mk_name _loc (MLast.ExLid (_loc, "a_list")) in
+ [mk_psymbol (MLast.PaLid (_loc, "a")) (TXnterm (_loc, n, None))
+ (STquo (_loc, "a_list"))]
in
- let act = MLast.ExLid (loc, "a") in {prod = prod; action = Some act}
+ let act = MLast.ExLid (_loc, "a") in {prod = prod; action = Some act}
in
let r2 =
let prod =
- [mk_psymbol (MLast.PaLid (loc, "a")) (slist loc min sep s)
- (STapp (loc, STlid (loc, "list"), s.styp))]
+ [mk_psymbol (MLast.PaLid (_loc, "a")) (slist _loc min sep s)
+ (STapp (_loc, STlid (_loc, "list"), s.styp))]
in
let act =
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")),
- MLast.ExLid (loc, "a"))
+ (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "List")),
+ MLast.ExLid (_loc, "a"))
in
{prod = prod; action = Some act}
in
| None -> s.used
in
let used = "a_list" :: used in
- let text = TXrules (loc, srules loc "a_list" rl "") in
- let styp = STquo (loc, "a_list") in {used = used; text = text; styp = styp}
+ let text = TXrules (_loc, srules _loc "a_list" rl "") in
+ let styp = STquo (_loc, "a_list") in {used = used; text = text; styp = styp}
;;
-let ssopt loc s =
+let ssopt _loc s =
let rl =
let r1 =
let prod =
- let n = mk_name loc (MLast.ExLid (loc, "a_opt")) in
- [mk_psymbol (MLast.PaLid (loc, "a")) (TXnterm (loc, n, None))
- (STquo (loc, "a_opt"))]
+ let n = mk_name _loc (MLast.ExLid (_loc, "a_opt")) in
+ [mk_psymbol (MLast.PaLid (_loc, "a")) (TXnterm (_loc, n, None))
+ (STquo (_loc, "a_opt"))]
in
- let act = MLast.ExLid (loc, "a") in {prod = prod; action = Some act}
+ let act = MLast.ExLid (_loc, "a") in {prod = prod; action = Some act}
in
let r2 =
let s =
match s.text with
- TXtok (loc, "", MLast.ExStr (_, _)) ->
+ TXtok (_loc, "", MLast.ExStr (_, _)) ->
let rl =
[{prod =
- [{pattern = Some (MLast.PaLid (loc, "x")); symbol = s}];
+ [{pattern = Some (MLast.PaLid (_loc, "x")); symbol = s}];
action =
Some
(MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"),
- MLast.ExUid (loc, "Str")),
- MLast.ExLid (loc, "x")))}]
+ (_loc, MLast.ExUid (_loc, "Qast"),
+ MLast.ExUid (_loc, "Str")),
+ MLast.ExLid (_loc, "x")))}]
in
let t = new_type_var () in
- {used = []; text = TXrules (loc, srules loc t rl "");
- styp = STquo (loc, t)}
+ {used = []; text = TXrules (_loc, srules _loc t rl "");
+ styp = STquo (_loc, t)}
| _ -> s
in
let prod =
- [mk_psymbol (MLast.PaLid (loc, "a")) (TXopt (loc, s.text))
- (STapp (loc, STlid (loc, "option"), s.styp))]
+ [mk_psymbol (MLast.PaLid (_loc, "a")) (TXopt (_loc, s.text))
+ (STapp (_loc, STlid (_loc, "option"), s.styp))]
in
let act =
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")),
- MLast.ExLid (loc, "a"))
+ (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Option")),
+ MLast.ExLid (_loc, "a"))
in
{prod = prod; action = Some act}
in
[r1; r2]
in
let used = "a_opt" :: s.used in
- let text = TXrules (loc, srules loc "a_opt" rl "") in
- let styp = STquo (loc, "a_opt") in {used = used; text = text; styp = styp}
+ let text = TXrules (_loc, srules _loc "a_opt" rl "") in
+ let styp = STquo (_loc, "a_opt") in {used = used; text = text; styp = styp}
;;
-let text_of_entry loc gmod e =
+let text_of_entry _loc gmod e =
let ent =
let x = e.name in
- let loc = e.name.loc in
+ let _loc = e.name.loc in
MLast.ExTyc
- (loc, x.expr,
+ (_loc, x.expr,
MLast.TyApp
- (loc,
+ (_loc,
MLast.TyAcc
- (loc,
+ (_loc,
MLast.TyAcc
- (loc, MLast.TyUid (loc, gmod), MLast.TyUid (loc, "Entry")),
- MLast.TyLid (loc, "e")),
- MLast.TyQuo (loc, x.tvar)))
+ (_loc, MLast.TyUid (_loc, gmod), MLast.TyUid (_loc, "Entry")),
+ MLast.TyLid (_loc, "e")),
+ MLast.TyQuo (_loc, x.tvar)))
in
let pos =
match e.pos with
- Some pos -> MLast.ExApp (loc, MLast.ExUid (loc, "Some"), pos)
- | None -> MLast.ExUid (loc, "None")
+ Some pos -> MLast.ExApp (_loc, MLast.ExUid (_loc, "Some"), pos)
+ | None -> MLast.ExUid (_loc, "None")
in
let txt =
List.fold_right
match level.label with
Some lab ->
MLast.ExApp
- (loc, MLast.ExUid (loc, "Some"), MLast.ExStr (loc, lab))
- | None -> MLast.ExUid (loc, "None")
+ (_loc, MLast.ExUid (_loc, "Some"), MLast.ExStr (_loc, lab))
+ | None -> MLast.ExUid (_loc, "None")
in
let ass =
match level.assoc with
- Some ass -> MLast.ExApp (loc, MLast.ExUid (loc, "Some"), ass)
- | None -> MLast.ExUid (loc, "None")
+ Some ass -> MLast.ExApp (_loc, MLast.ExUid (_loc, "Some"), ass)
+ | None -> MLast.ExUid (_loc, "None")
in
let txt =
- let rl = srules loc e.name.tvar level.rules e.name.tvar in
- let e = make_expr_rules loc gmod rl e.name.tvar in
+ let rl = srules _loc e.name.tvar level.rules e.name.tvar in
+ let e = make_expr_rules _loc gmod rl e.name.tvar in
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc, MLast.ExUid (loc, "::"),
- MLast.ExTup (loc, [lab; ass; e])),
+ (_loc, MLast.ExUid (_loc, "::"),
+ MLast.ExTup (_loc, [lab; ass; e])),
txt)
in
txt)
- e.levels (MLast.ExUid (loc, "[]"))
+ e.levels (MLast.ExUid (_loc, "[]"))
in
ent, pos, txt
;;
-let let_in_of_extend loc gmod functor_version gl el args =
+let let_in_of_extend _loc gmod functor_version gl el args =
match gl with
Some (n1 :: _ as nl) ->
check_use nl el;
in
let globals =
List.map
- (fun {expr = e; tvar = x; loc = loc} ->
- MLast.PaAny loc,
+ (fun {expr = e; tvar = x; loc = _loc} ->
+ MLast.PaAny _loc,
MLast.ExTyc
- (loc, e,
+ (_loc, e,
MLast.TyApp
- (loc,
+ (_loc,
MLast.TyAcc
- (loc,
+ (_loc,
MLast.TyAcc
- (loc, MLast.TyUid (loc, gmod),
- MLast.TyUid (loc, "Entry")),
- MLast.TyLid (loc, "e")),
- MLast.TyQuo (loc, x))))
+ (_loc, MLast.TyUid (_loc, gmod),
+ MLast.TyUid (_loc, "Entry")),
+ MLast.TyLid (_loc, "e")),
+ MLast.TyQuo (_loc, x))))
nl
in
let locals =
List.map
- (fun {expr = e; tvar = x; loc = loc} ->
+ (fun {expr = e; tvar = x; loc = _loc} ->
let i =
match e with
MLast.ExLid (_, i) -> i
| _ -> failwith "internal error in pa_extend"
in
- MLast.PaLid (loc, i),
+ MLast.PaLid (_loc, i),
MLast.ExTyc
- (loc,
+ (_loc,
MLast.ExApp
- (loc, MLast.ExLid (loc, "grammar_entry_create"),
- MLast.ExStr (loc, i)),
+ (_loc, MLast.ExLid (_loc, "grammar_entry_create"),
+ MLast.ExStr (_loc, i)),
MLast.TyApp
- (loc,
+ (_loc,
MLast.TyAcc
- (loc,
+ (_loc,
MLast.TyAcc
- (loc, MLast.TyUid (loc, gmod),
- MLast.TyUid (loc, "Entry")),
- MLast.TyLid (loc, "e")),
- MLast.TyQuo (loc, x))))
+ (_loc, MLast.TyUid (_loc, gmod),
+ MLast.TyUid (_loc, "Entry")),
+ MLast.TyLid (_loc, "e")),
+ MLast.TyQuo (_loc, x))))
ll
in
let e =
if ll = [] then args
else if functor_version then
MLast.ExLet
- (loc, false,
- [MLast.PaLid (loc, "grammar_entry_create"),
+ (_loc, false,
+ [MLast.PaLid (_loc, "grammar_entry_create"),
MLast.ExAcc
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, gmod), MLast.ExUid (loc, "Entry")),
- MLast.ExLid (loc, "create"))],
- MLast.ExLet (loc, false, locals, args))
+ (_loc, MLast.ExUid (_loc, gmod),
+ MLast.ExUid (_loc, "Entry")),
+ MLast.ExLid (_loc, "create"))],
+ MLast.ExLet (_loc, false, locals, args))
else
MLast.ExLet
- (loc, false,
- [MLast.PaLid (loc, "grammar_entry_create"),
+ (_loc, false,
+ [MLast.PaLid (_loc, "grammar_entry_create"),
MLast.ExFun
- (loc,
- [MLast.PaLid (loc, "s"), None,
+ (_loc,
+ [MLast.PaLid (_loc, "s"), None,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, gmod),
- MLast.ExUid (loc, "Entry")),
- MLast.ExLid (loc, "create")),
+ (_loc, MLast.ExUid (_loc, gmod),
+ MLast.ExUid (_loc, "Entry")),
+ MLast.ExLid (_loc, "create")),
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, gmod),
- MLast.ExLid (loc, "of_entry")),
+ (_loc, MLast.ExUid (_loc, gmod),
+ MLast.ExLid (_loc, "of_entry")),
locate n1)),
- MLast.ExLid (loc, "s"))])],
- MLast.ExLet (loc, false, locals, args))
+ MLast.ExLid (_loc, "s"))])],
+ MLast.ExLet (_loc, false, locals, args))
in
- MLast.ExLet (loc, false, globals, e)
+ MLast.ExLet (_loc, false, globals, e)
| _ -> args
;;
-let text_of_extend loc gmod gl el f =
+let text_of_extend _loc gmod gl el f =
if !split_ext then
let args =
List.map
let (ent, pos, txt) = text_of_entry e.name.loc gmod e in
let ent =
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, gmod),
- MLast.ExUid (loc, "Entry")),
- MLast.ExLid (loc, "obj")),
+ (_loc, MLast.ExUid (_loc, gmod),
+ MLast.ExUid (_loc, "Entry")),
+ MLast.ExLid (_loc, "obj")),
ent)
in
- let e = MLast.ExTup (loc, [ent; pos; txt]) in
+ let e = MLast.ExTup (_loc, [ent; pos; txt]) in
MLast.ExLet
- (loc, false,
- [MLast.PaLid (loc, "aux"),
+ (_loc, false,
+ [MLast.PaLid (_loc, "aux"),
MLast.ExFun
- (loc,
- [MLast.PaUid (loc, "()"), None,
+ (_loc,
+ [MLast.PaUid (_loc, "()"), None,
MLast.ExApp
- (loc, f,
+ (_loc, f,
MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e),
- MLast.ExUid (loc, "[]")))])],
+ (_loc,
+ MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), e),
+ MLast.ExUid (_loc, "[]")))])],
MLast.ExApp
- (loc, MLast.ExLid (loc, "aux"), MLast.ExUid (loc, "()"))))
+ (_loc, MLast.ExLid (_loc, "aux"), MLast.ExUid (_loc, "()"))))
el
in
- let args = MLast.ExSeq (loc, args) in
- let_in_of_extend loc gmod false gl el args
+ let args = MLast.ExSeq (_loc, args) in
+ let_in_of_extend _loc gmod false gl el args
else
let args =
List.fold_right
let (ent, pos, txt) = text_of_entry e.name.loc gmod e in
let ent =
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, gmod),
- MLast.ExUid (loc, "Entry")),
- MLast.ExLid (loc, "obj")),
+ (_loc, MLast.ExUid (_loc, gmod),
+ MLast.ExUid (_loc, "Entry")),
+ MLast.ExLid (_loc, "obj")),
ent)
in
- let e = MLast.ExTup (loc, [ent; pos; txt]) in
+ let e = MLast.ExTup (_loc, [ent; pos; txt]) in
MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e), el))
- el (MLast.ExUid (loc, "[]"))
+ (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), e), el))
+ el (MLast.ExUid (_loc, "[]"))
in
- let args = let_in_of_extend loc gmod false gl el args in
- MLast.ExApp (loc, f, args)
+ let args = let_in_of_extend _loc gmod false gl el args in
+ MLast.ExApp (_loc, f, args)
;;
-let text_of_functorial_extend loc gmod gl el =
+let text_of_functorial_extend _loc gmod gl el =
let args =
let el =
List.map
let (ent, pos, txt) = text_of_entry e.name.loc gmod e in
let e =
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, gmod),
- MLast.ExLid (loc, "extend")),
+ (_loc, MLast.ExUid (_loc, gmod),
+ MLast.ExLid (_loc, "extend")),
ent),
pos),
txt)
in
if !split_ext then
MLast.ExLet
- (loc, false,
- [MLast.PaLid (loc, "aux"),
- MLast.ExFun (loc, [MLast.PaUid (loc, "()"), None, e])],
+ (_loc, false,
+ [MLast.PaLid (_loc, "aux"),
+ MLast.ExFun (_loc, [MLast.PaUid (_loc, "()"), None, e])],
MLast.ExApp
- (loc, MLast.ExLid (loc, "aux"), MLast.ExUid (loc, "()")))
+ (_loc, MLast.ExLid (_loc, "aux"), MLast.ExUid (_loc, "()")))
else e)
el
in
- MLast.ExSeq (loc, el)
+ MLast.ExSeq (_loc, el)
in
- let_in_of_extend loc gmod true gl el args
+ let_in_of_extend _loc gmod true gl el args
;;
let zero_loc = {(Lexing.dummy_pos) with Lexing.pos_cnum = 0};;
Gramext.Stoken ("", "END")],
Gramext.action
(fun _ (e : 'gdelete_rule_body) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(e : 'expr));
[Gramext.Stoken ("", "DELETE_RULE");
Gramext.Snterm
Gramext.Stoken ("", "END")],
Gramext.action
(fun _ (e : 'delete_rule_body) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(e : 'expr));
[Gramext.Stoken ("", "GEXTEND");
Gramext.Snterm
Gramext.Stoken ("", "END")],
Gramext.action
(fun _ (e : 'gextend_body) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(e : 'expr));
[Gramext.Stoken ("", "EXTEND");
Gramext.Snterm
Gramext.Stoken ("", "END")],
Gramext.action
(fun _ (e : 'extend_body) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(e : 'expr))]];
Grammar.Entry.obj (extend_body : 'extend_body Grammar.Entry.e), None,
[None, None,
(Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))],
Gramext.action
(fun _ (e : 'entry)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(e : 'e__1))])],
Gramext.action
(fun (el : 'e__1 list) (sl : 'global option) (f : 'efunction)
- (loc : Lexing.position * Lexing.position) ->
- (text_of_extend loc "Grammar" sl el f : 'extend_body))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (text_of_extend _loc "Grammar" sl el f : 'extend_body))]];
Grammar.Entry.obj (gextend_body : 'gextend_body Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("UIDENT", "");
(Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))],
Gramext.action
(fun _ (e : 'entry)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(e : 'e__2))])],
Gramext.action
(fun (el : 'e__2 list) (sl : 'global option) (g : string)
- (loc : Lexing.position * Lexing.position) ->
- (text_of_functorial_extend loc g sl el : 'gextend_body))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (text_of_functorial_extend _loc g sl el : 'gextend_body))]];
Grammar.Entry.obj (delete_rule_body : 'delete_rule_body Grammar.Entry.e),
None,
[None, None,
(Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))],
Gramext.action
(fun (sl : 'symbol list) _ (n : 'name)
- (loc : Lexing.position * Lexing.position) ->
- (let (e, b) = expr_of_delete_rule loc "Grammar" n sl in
+ (_loc : Lexing.position * Lexing.position) ->
+ (let (e, b) = expr_of_delete_rule _loc "Grammar" n sl in
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Grammar"),
- MLast.ExLid (loc, "delete_rule")),
+ (_loc, MLast.ExUid (_loc, "Grammar"),
+ MLast.ExLid (_loc, "delete_rule")),
e),
b) :
'delete_rule_body))]];
(Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))],
Gramext.action
(fun (sl : 'symbol list) _ (n : 'name) (g : string)
- (loc : Lexing.position * Lexing.position) ->
- (let (e, b) = expr_of_delete_rule loc g n sl in
+ (_loc : Lexing.position * Lexing.position) ->
+ (let (e, b) = expr_of_delete_rule _loc g n sl in
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, g),
- MLast.ExLid (loc, "delete_rule")),
+ (_loc, MLast.ExUid (_loc, g),
+ MLast.ExLid (_loc, "delete_rule")),
e),
b) :
'gdelete_rule_body))]];
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
+ (fun (_loc : Lexing.position * Lexing.position) ->
(MLast.ExAcc
- (loc, MLast.ExUid (loc, "Grammar"),
- MLast.ExLid (loc, "extend")) :
+ (_loc, MLast.ExUid (_loc, "Grammar"),
+ MLast.ExLid (_loc, "extend")) :
'efunction));
[Gramext.Stoken ("UIDENT", "FUNCTION"); Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e));
Gramext.Snterm
(Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))],
Gramext.action
- (fun _ (f : 'qualid) _ _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (f : 'qualid) _ _ (_loc : Lexing.position * Lexing.position) ->
(f : 'efunction))]];
Grammar.Entry.obj (global : 'global Grammar.Entry.e), None,
[None, None,
(Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))],
Gramext.action
(fun _ (sl : 'name list) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(sl : 'global))]];
Grammar.Entry.obj (entry : 'entry Grammar.Entry.e), None,
[None, None,
(Grammar.Entry.obj (level_list : 'level_list Grammar.Entry.e))],
Gramext.action
(fun (ll : 'level_list) (pos : 'position option) _ (n : 'name)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
({name = n; pos = pos; levels = ll} : 'entry))]];
Grammar.Entry.obj (position : 'position Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("UIDENT", "LEVEL");
Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))],
Gramext.action
- (fun (n : 'string) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (n : 'string) _ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Level")),
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExUid (_loc, "Level")),
n) :
'position));
[Gramext.Stoken ("UIDENT", "AFTER");
Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))],
Gramext.action
- (fun (n : 'string) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (n : 'string) _ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "After")),
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExUid (_loc, "After")),
n) :
'position));
[Gramext.Stoken ("UIDENT", "BEFORE");
Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))],
Gramext.action
- (fun (n : 'string) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (n : 'string) _ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "Before")),
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExUid (_loc, "Before")),
n) :
'position));
[Gramext.Stoken ("UIDENT", "LAST")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Last")) :
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExUid (_loc, "Last")) :
'position));
[Gramext.Stoken ("UIDENT", "FIRST")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "First")) :
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExUid (_loc, "First")) :
'position))]];
Grammar.Entry.obj (level_list : 'level_list Grammar.Entry.e), None,
[None, None,
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (ll : 'level list) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(ll : 'level_list))]];
Grammar.Entry.obj (level : 'level Grammar.Entry.e), None,
[None, None,
(Grammar.Entry.obj (rule_list : 'rule_list Grammar.Entry.e))],
Gramext.action
(fun (rules : 'rule_list) (ass : 'assoc option) (lab : string option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
({label = lab; assoc = ass; rules = rules} : 'level))]];
Grammar.Entry.obj (assoc : 'assoc Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("UIDENT", "NONA")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "NonA")) :
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExUid (_loc, "NonA")) :
'assoc));
[Gramext.Stoken ("UIDENT", "RIGHTA")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "RightA")) :
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExUid (_loc, "RightA")) :
'assoc));
[Gramext.Stoken ("UIDENT", "LEFTA")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExAcc
- (loc, MLast.ExUid (loc, "Gramext"),
- MLast.ExUid (loc, "LeftA")) :
+ (_loc, MLast.ExUid (_loc, "Gramext"),
+ MLast.ExUid (_loc, "LeftA")) :
'assoc))]];
Grammar.Entry.obj (rule_list : 'rule_list Grammar.Entry.e), None,
[None, None,
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (rules : 'rule list) _
- (loc : Lexing.position * Lexing.position) ->
- (retype_rule_list_without_patterns loc rules : 'rule_list));
+ (_loc : Lexing.position * Lexing.position) ->
+ (retype_rule_list_without_patterns _loc rules : 'rule_list));
[Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")],
Gramext.action
- (fun _ _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ _ (_loc : Lexing.position * Lexing.position) ->
([] : 'rule_list))]];
Grammar.Entry.obj (rule : 'rule Grammar.Entry.e), None,
[None, None,
(Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))],
Gramext.action
(fun (psl : 'psymbol list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
({prod = psl; action = None} : 'rule));
[Gramext.Slist0sep
(Gramext.Snterm
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
(fun (act : 'expr) _ (psl : 'psymbol list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
({prod = psl; action = Some act} : 'rule))]];
Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))],
Gramext.action
- (fun (s : 'symbol) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'symbol) (_loc : Lexing.position * Lexing.position) ->
({pattern = None; symbol = s} : 'psymbol));
[Gramext.Snterm
(Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))],
Gramext.action
(fun (s : 'symbol) _ (p : 'pattern)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
({pattern = Some p; symbol = s} : 'psymbol));
[Gramext.Stoken ("LIDENT", "");
Gramext.Sopt
Gramext.Stoken ("STRING", "")],
Gramext.action
(fun (s : string) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(s : 'e__3))])],
Gramext.action
(fun (lev : 'e__3 option) (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (let name = mk_name loc (MLast.ExLid (loc, i)) in
- let text = TXnterm (loc, name, lev) in
- let styp = STquo (loc, i) in
+ (_loc : Lexing.position * Lexing.position) ->
+ (let name = mk_name _loc (MLast.ExLid (_loc, i)) in
+ let text = TXnterm (_loc, name, lev) in
+ let styp = STquo (_loc, i) in
let symb = {used = [i]; text = text; styp = styp} in
{pattern = None; symbol = symb} :
'psymbol));
Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))],
Gramext.action
(fun (s : 'symbol) _ (p : string)
- (loc : Lexing.position * Lexing.position) ->
- ({pattern = Some (MLast.PaLid (loc, p)); symbol = s} :
+ (_loc : Lexing.position * Lexing.position) ->
+ ({pattern = Some (MLast.PaLid (_loc, p)); symbol = s} :
'psymbol))]];
Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e), None,
[Some "top", Some Gramext.NonA,
[[Gramext.Stoken ("UIDENT", "OPT"); Gramext.Sself],
Gramext.action
- (fun (s : 'symbol) _ (loc : Lexing.position * Lexing.position) ->
- (if !quotify then ssopt loc s
+ (fun (s : 'symbol) _ (_loc : Lexing.position * Lexing.position) ->
+ (if !quotify then ssopt _loc s
else
- let styp = STapp (loc, STlid (loc, "option"), s.styp) in
- let text = TXopt (loc, s.text) in
+ let styp = STapp (_loc, STlid (_loc, "option"), s.styp) in
+ let text = TXopt (_loc, s.text) in
{used = s.used; text = text; styp = styp} :
'symbol));
[Gramext.Stoken ("UIDENT", "LIST1"); Gramext.Sself;
(Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))],
Gramext.action
(fun (t : 'symbol) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(t : 'e__5))])],
Gramext.action
(fun (sep : 'e__5 option) (s : 'symbol) _
- (loc : Lexing.position * Lexing.position) ->
- (if !quotify then sslist loc true sep s
+ (_loc : Lexing.position * Lexing.position) ->
+ (if !quotify then sslist _loc true sep s
else
let used =
match sep with
Some symb -> symb.used @ s.used
| None -> s.used
in
- let styp = STapp (loc, STlid (loc, "list"), s.styp) in
- let text = slist loc true sep s in
+ let styp = STapp (_loc, STlid (_loc, "list"), s.styp) in
+ let text = slist _loc true sep s in
{used = used; text = text; styp = styp} :
'symbol));
[Gramext.Stoken ("UIDENT", "LIST0"); Gramext.Sself;
(Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))],
Gramext.action
(fun (t : 'symbol) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(t : 'e__4))])],
Gramext.action
(fun (sep : 'e__4 option) (s : 'symbol) _
- (loc : Lexing.position * Lexing.position) ->
- (if !quotify then sslist loc false sep s
+ (_loc : Lexing.position * Lexing.position) ->
+ (if !quotify then sslist _loc false sep s
else
let used =
match sep with
Some symb -> symb.used @ s.used
| None -> s.used
in
- let styp = STapp (loc, STlid (loc, "list"), s.styp) in
- let text = slist loc false sep s in
+ let styp = STapp (_loc, STlid (_loc, "list"), s.styp) in
+ let text = slist _loc false sep s in
{used = used; text = text; styp = styp} :
'symbol))];
None, None,
[[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (s_t : 'symbol) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (s_t : 'symbol) _ (_loc : Lexing.position * Lexing.position) ->
(s_t : 'symbol));
[Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e));
Gramext.Sopt
Gramext.Stoken ("STRING", "")],
Gramext.action
(fun (s : string) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(s : 'e__7))])],
Gramext.action
(fun (lev : 'e__7 option) (n : 'name)
- (loc : Lexing.position * Lexing.position) ->
- ({used = [n.tvar]; text = TXnterm (loc, n, lev);
- styp = STquo (loc, n.tvar)} :
+ (_loc : Lexing.position * Lexing.position) ->
+ ({used = [n.tvar]; text = TXnterm (_loc, n, lev);
+ styp = STquo (_loc, n.tvar)} :
'symbol));
[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ".");
Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e));
Gramext.Stoken ("STRING", "")],
Gramext.action
(fun (s : string) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(s : 'e__6))])],
Gramext.action
(fun (lev : 'e__6 option) (e : 'qualid) _ (i : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(let n =
- mk_name loc (MLast.ExAcc (loc, MLast.ExUid (loc, i), e))
+ mk_name _loc (MLast.ExAcc (_loc, MLast.ExUid (_loc, i), e))
in
- {used = [n.tvar]; text = TXnterm (loc, n, lev);
- styp = STquo (loc, n.tvar)} :
+ {used = [n.tvar]; text = TXnterm (_loc, n, lev);
+ styp = STquo (_loc, n.tvar)} :
'symbol));
[Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))],
Gramext.action
- (fun (e : 'string) (loc : Lexing.position * Lexing.position) ->
- (let text = TXtok (loc, "", e) in
- {used = []; text = text; styp = STlid (loc, "string")} :
+ (fun (e : 'string) (_loc : Lexing.position * Lexing.position) ->
+ (let text = TXtok (_loc, "", e) in
+ {used = []; text = text; styp = STlid (_loc, "string")} :
'symbol));
[Gramext.Stoken ("UIDENT", "");
Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))],
Gramext.action
(fun (e : 'string) (x : string)
- (loc : Lexing.position * Lexing.position) ->
- (let text = TXtok (loc, x, e) in
- {used = []; text = text; styp = STlid (loc, "string")} :
+ (_loc : Lexing.position * Lexing.position) ->
+ (let text = TXtok (_loc, x, e) in
+ {used = []; text = text; styp = STlid (_loc, "string")} :
'symbol));
[Gramext.Stoken ("UIDENT", "")],
Gramext.action
- (fun (x : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (x : string) (_loc : Lexing.position * Lexing.position) ->
(let text =
- if !quotify then sstoken loc x
- else TXtok (loc, x, MLast.ExStr (loc, ""))
+ if !quotify then sstoken _loc x
+ else TXtok (_loc, x, MLast.ExStr (_loc, ""))
in
- {used = []; text = text; styp = STlid (loc, "string")} :
+ {used = []; text = text; styp = STlid (_loc, "string")} :
'symbol));
[Gramext.Stoken ("", "[");
Gramext.Slist0sep
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (rl : 'rule list) _
- (loc : Lexing.position * Lexing.position) ->
- (let rl = retype_rule_list_without_patterns loc rl in
+ (_loc : Lexing.position * Lexing.position) ->
+ (let rl = retype_rule_list_without_patterns _loc rl in
let t = new_type_var () in
{used = used_of_rule_list rl;
- text = TXrules (loc, srules loc t rl "");
- styp = STquo (loc, t)} :
+ text = TXrules (_loc, srules _loc t rl "");
+ styp = STquo (_loc, t)} :
'symbol));
[Gramext.Stoken ("UIDENT", "NEXT")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- ({used = []; text = TXnext loc; styp = STself (loc, "NEXT")} :
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
+ ({used = []; text = TXnext _loc; styp = STself (_loc, "NEXT")} :
'symbol));
[Gramext.Stoken ("UIDENT", "SELF")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- ({used = []; text = TXself loc; styp = STself (loc, "SELF")} :
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
+ ({used = []; text = TXself _loc; styp = STself (_loc, "SELF")} :
'symbol))]];
Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e), None,
[None, None,
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (pl : 'patterns_comma) _ (p : 'pattern) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaTup (loc, (p :: pl)) : 'pattern));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaTup (_loc, (p :: pl)) : 'pattern));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (p : 'pattern) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (p : 'pattern) _ (_loc : Lexing.position * Lexing.position) ->
(p : 'pattern));
[Gramext.Stoken ("", "_")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (MLast.PaAny loc : 'pattern));
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaAny _loc : 'pattern));
[Gramext.Stoken ("LIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaLid (loc, i) : 'pattern))]];
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaLid (_loc, i) : 'pattern))]];
Grammar.Entry.obj (patterns_comma : 'patterns_comma Grammar.Entry.e),
None,
[None, None,
(Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e))],
Gramext.action
(fun (p : 'pattern) _ (pl : 'patterns_comma)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(pl @ [p] : 'patterns_comma))];
None, None,
[[Gramext.Snterm
(Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e))],
Gramext.action
- (fun (p : 'pattern) (loc : Lexing.position * Lexing.position) ->
+ (fun (p : 'pattern) (_loc : Lexing.position * Lexing.position) ->
([p] : 'patterns_comma))]];
Grammar.Entry.obj (name : 'name Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e))],
Gramext.action
- (fun (e : 'qualid) (loc : Lexing.position * Lexing.position) ->
- (mk_name loc e : 'name))]];
+ (fun (e : 'qualid) (_loc : Lexing.position * Lexing.position) ->
+ (mk_name _loc e : 'name))]];
Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e), None,
[None, None,
[[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (e2 : 'qualid) _ (e1 : 'qualid)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExAcc (loc, e1, e2) : 'qualid))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExAcc (_loc, e1, e2) : 'qualid))];
None, None,
[[Gramext.Stoken ("LIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.ExLid (loc, i) : 'qualid));
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExLid (_loc, i) : 'qualid));
[Gramext.Stoken ("UIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.ExUid (loc, i) : 'qualid))]];
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExUid (_loc, i) : 'qualid))]];
Grammar.Entry.obj (string : 'string Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (let shift = Reloc.shift_pos (String.length "$") (fst loc) in
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (let shift = Reloc.shift_pos (String.length "$") (fst _loc) in
let e =
try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string i) with
Exc_located ((bp, ep), exc) ->
'string));
[Gramext.Stoken ("STRING", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.ExStr (loc, s) : 'string))]]]);;
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExStr (_loc, s) : 'string))]]]);;
Pcaml.add_option "-quotify" (Arg.Set quotify) "Generate code for quotations";;
[None, Some Gramext.NonA,
[[Gramext.Stoken ("UIDENT", "SOPT"); Gramext.Sself],
Gramext.action
- (fun (s : 'symbol) _ (loc : Lexing.position * Lexing.position) ->
- (ssopt loc s : 'symbol));
+ (fun (s : 'symbol) _ (_loc : Lexing.position * Lexing.position) ->
+ (ssopt _loc s : 'symbol));
[Gramext.srules
[[Gramext.Stoken ("UIDENT", "SLIST1")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
(true : 'e__1));
[Gramext.Stoken ("UIDENT", "SLIST0")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
(false : 'e__1))];
Gramext.Sself;
Gramext.Sopt
(Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))],
Gramext.action
(fun (t : 'symbol) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(t : 'e__2))])],
Gramext.action
(fun (sep : 'e__2 option) (s : 'symbol) (min : 'e__1)
- (loc : Lexing.position * Lexing.position) ->
- (sslist loc min sep s : 'symbol))]]];;
+ (_loc : Lexing.position * Lexing.position) ->
+ (sslist _loc min sep s : 'symbol))]]];;
let is_defined i = List.mem_assoc i !defined;;
-let loc =
+let _loc =
let nowhere =
{(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0}
in
function
MLast.ExLet (_, rf, pel, e) ->
let pel = List.map (fun (p, e) -> p, loop e) pel in
- MLast.ExLet (loc, rf, pel, loop e)
+ MLast.ExLet (_loc, rf, pel, loop e)
| MLast.ExIfe (_, e1, e2, e3) ->
- MLast.ExIfe (loc, loop e1, loop e2, loop e3)
- | MLast.ExApp (_, e1, e2) -> MLast.ExApp (loc, loop e1, loop e2)
+ MLast.ExIfe (_loc, loop e1, loop e2, loop e3)
+ | MLast.ExApp (_, e1, e2) -> MLast.ExApp (_loc, loop e1, loop e2)
| MLast.ExFun (_, [args, None, e]) ->
- MLast.ExFun (loc, [args, None, loop e])
- | MLast.ExFun (_, peoel) -> MLast.ExFun (loc, List.map loop_peoel peoel)
+ MLast.ExFun (_loc, [args, None, loop e])
+ | MLast.ExFun (_, peoel) -> MLast.ExFun (_loc, List.map loop_peoel peoel)
| MLast.ExLid (_, x) | MLast.ExUid (_, x) as e ->
- begin try MLast.ExAnt (loc, List.assoc x env) with
+ begin try MLast.ExAnt (_loc, List.assoc x env) with
Not_found -> e
end
- | MLast.ExTup (_, x) -> MLast.ExTup (loc, List.map loop x)
- | MLast.ExSeq (_, x) -> MLast.ExSeq (loc, List.map loop x)
+ | MLast.ExTup (_, x) -> MLast.ExTup (_loc, List.map loop x)
+ | MLast.ExSeq (_, x) -> MLast.ExSeq (_loc, List.map loop x)
| MLast.ExRec (_, pel, None) ->
let pel = List.map (fun (p, e) -> p, loop e) pel in
- MLast.ExRec (loc, pel, None)
+ MLast.ExRec (_loc, pel, None)
| MLast.ExMat (_, e, peoel) ->
- MLast.ExMat (loc, loop e, List.map loop_peoel peoel)
+ MLast.ExMat (_loc, loop e, List.map loop_peoel peoel)
| MLast.ExTry (_, e, pel) ->
let loop' =
function
p, Some e1, e2 -> p, Some (loop e1), loop e2
| p, None, e2 -> p, None, loop e2
in
- MLast.ExTry (loc, loop e, List.map loop' pel)
+ MLast.ExTry (_loc, loop e, List.map loop' pel)
| e -> e
and loop_peoel =
function
let substp mloc env =
let rec loop =
function
- MLast.ExApp (_, e1, e2) -> MLast.PaApp (loc, loop e1, loop e2)
+ MLast.ExApp (_, e1, e2) -> MLast.PaApp (_loc, loop e1, loop e2)
| MLast.ExLid (_, x) ->
- begin try MLast.PaAnt (loc, List.assoc x env) with
- Not_found -> MLast.PaLid (loc, x)
+ begin try MLast.PaAnt (_loc, List.assoc x env) with
+ Not_found -> MLast.PaLid (_loc, x)
end
| MLast.ExUid (_, x) ->
- begin try MLast.PaAnt (loc, List.assoc x env) with
- Not_found -> MLast.PaUid (loc, x)
+ begin try MLast.PaAnt (_loc, List.assoc x env) with
+ Not_found -> MLast.PaUid (_loc, x)
end
- | MLast.ExInt (_, x) -> MLast.PaInt (loc, x)
- | MLast.ExStr (_, s) -> MLast.PaStr (loc, s)
- | MLast.ExTup (_, x) -> MLast.PaTup (loc, List.map loop x)
+ | MLast.ExInt (_, x) -> MLast.PaInt (_loc, x)
+ | MLast.ExStr (_, s) -> MLast.PaStr (_loc, s)
+ | MLast.ExTup (_, x) -> MLast.PaTup (_loc, List.map loop x)
| MLast.ExRec (_, pel, None) ->
let ppl = List.map (fun (p, e) -> p, loop e) pel in
- MLast.PaRec (loc, ppl)
+ MLast.PaRec (_loc, ppl)
| x ->
Stdpp.raise_with_loc mloc
(Failure
[None, None,
[[Gramext.Stoken ("UIDENT", x)],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (Pcaml.expr_reloc (fun _ -> loc) (fst loc) e : 'expr))]];
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
+ (Pcaml.expr_reloc (fun _ -> _loc) (fst _loc) e : 'expr))]];
Grammar.Entry.obj (patt : 'patt Grammar.Entry.e),
Some (Gramext.Level "simple"),
[None, None,
[[Gramext.Stoken ("UIDENT", x)],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (let p = substp loc [] e in
- Pcaml.patt_reloc (fun _ -> loc) (fst loc) p :
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
+ (let p = substp _loc [] e in
+ Pcaml.patt_reloc (fun _ -> _loc) (fst _loc) p :
'patt))]]]
| Some (sl, e) ->
Grammar.extend
[[Gramext.Stoken ("UIDENT", x); Gramext.Sself],
Gramext.action
(fun (param : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(let el =
match param with
MLast.ExTup (_, el) -> el
in
if List.length el = List.length sl then
let env = List.combine sl el in
- let e = subst loc env e in
- Pcaml.expr_reloc (fun _ -> loc) (fst loc) e
- else incorrect_number loc el sl :
+ let e = subst _loc env e in
+ Pcaml.expr_reloc (fun _ -> _loc) (fst _loc) e
+ else incorrect_number _loc el sl :
'expr))]];
Grammar.Entry.obj (patt : 'patt Grammar.Entry.e),
Some (Gramext.Level "simple"),
[[Gramext.Stoken ("UIDENT", x); Gramext.Sself],
Gramext.action
(fun (param : 'patt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(let pl =
match param with
MLast.PaTup (_, pl) -> pl
in
if List.length pl = List.length sl then
let env = List.combine sl pl in
- let p = substp loc env e in
- Pcaml.patt_reloc (fun _ -> loc) (fst loc) p
- else incorrect_number loc pl sl :
+ let p = substp _loc env e in
+ Pcaml.patt_reloc (fun _ -> _loc) (fst _loc) p
+ else incorrect_number _loc pl sl :
'patt))]]]
| None -> ()
end;
try List.find (dir_ok file) (!include_dirs @ ["./"]) ^ file with
Not_found -> file
in
- let st = Stream.of_channel (open_in file) in
+ let ch = open_in file in
+ let st = Stream.of_channel ch in
let old_input = !(Pcaml.input_file) in
+ let (bol_ref, lnum_ref, name_ref) = !(Pcaml.position) in
+ let (old_bol, old_lnum, old_name) = !bol_ref, !lnum_ref, !name_ref in
+ let restore () =
+ close_in ch;
+ bol_ref := old_bol;
+ lnum_ref := old_lnum;
+ name_ref := old_name;
+ Pcaml.input_file := old_input
+ in
+ bol_ref := 0;
+ lnum_ref := 1;
+ name_ref := file;
Pcaml.input_file := file;
- let items = Grammar.Entry.parse smlist st in
- Pcaml.input_file := old_input; items
+ try let items = Grammar.Entry.parse smlist st in restore (); items with
+ exn -> restore (); raise exn
;;
let rec execute_macro =
[[Gramext.Snterm
(Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e))],
Gramext.action
- (fun (x : 'macro_def) (loc : Lexing.position * Lexing.position) ->
+ (fun (x : 'macro_def) (_loc : Lexing.position * Lexing.position) ->
(match execute_macro x with
[si] -> si
- | sil -> MLast.StDcl (loc, sil) :
+ | sil -> MLast.StDcl (_loc, sil) :
'str_item))]];
Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "INCLUDE"); Gramext.Stoken ("STRING", "")],
Gramext.action
- (fun (fname : string) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (fname : string) _ (_loc : Lexing.position * Lexing.position) ->
(SdInc fname : 'macro_def));
[Gramext.Stoken ("", "IFNDEF");
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))],
Gramext.action
(fun (_ : 'endif) (dl2 : 'smlist) _ (dl1 : 'smlist) _ (i : 'uident) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(SdITE (i, dl2, dl1) : 'macro_def));
[Gramext.Stoken ("", "IFNDEF");
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))],
Gramext.action
(fun (_ : 'endif) (dl : 'smlist) _ (i : 'uident) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(SdITE (i, [], dl) : 'macro_def));
[Gramext.Stoken ("", "IFDEF");
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))],
Gramext.action
(fun (_ : 'endif) (dl2 : 'smlist) _ (dl1 : 'smlist) _ (i : 'uident) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(SdITE (i, dl1, dl2) : 'macro_def));
[Gramext.Stoken ("", "IFDEF");
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))],
Gramext.action
(fun (_ : 'endif) (dl : 'smlist) _ (i : 'uident) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(SdITE (i, dl, []) : 'macro_def));
[Gramext.Stoken ("", "UNDEF");
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'uident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'uident) _ (_loc : Lexing.position * Lexing.position) ->
(SdUnd i : 'macro_def));
[Gramext.Stoken ("", "DEFINE");
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
(opt_macro_value : 'opt_macro_value Grammar.Entry.e))],
Gramext.action
(fun (def : 'opt_macro_value) (i : 'uident) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(SdDef (i, def) : 'macro_def))]];
Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e), None,
[None, None,
(str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)))],
Gramext.action
(fun (sml : 'str_item_or_macro list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(sml : 'smlist))]];
Grammar.Entry.obj (endif : 'endif Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "ENDIF")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) -> (() : 'endif));
+ (fun _ (_loc : Lexing.position * Lexing.position) -> (() : 'endif));
[Gramext.Stoken ("", "END")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) -> (() : 'endif))]];
+ (fun _ (_loc : Lexing.position * Lexing.position) -> (() : 'endif))]];
Grammar.Entry.obj
(str_item_or_macro : 'str_item_or_macro Grammar.Entry.e),
None,
[[Gramext.Snterm
(Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e))],
Gramext.action
- (fun (si : 'str_item) (loc : Lexing.position * Lexing.position) ->
+ (fun (si : 'str_item) (_loc : Lexing.position * Lexing.position) ->
(SdStr si : 'str_item_or_macro));
[Gramext.Snterm
(Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e))],
Gramext.action
- (fun (d : 'macro_def) (loc : Lexing.position * Lexing.position) ->
+ (fun (d : 'macro_def) (_loc : Lexing.position * Lexing.position) ->
(d : 'str_item_or_macro))]];
Grammar.Entry.obj (opt_macro_value : 'opt_macro_value Grammar.Entry.e),
None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
+ (fun (_loc : Lexing.position * Lexing.position) ->
(None : 'opt_macro_value));
[Gramext.Stoken ("", "=");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(Some ([], e) : 'opt_macro_value));
[Gramext.Stoken ("", "(");
Gramext.Slist1sep
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
(fun (e : 'expr) _ _ (pl : string list) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Some (pl, e) : 'opt_macro_value))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
Some (Gramext.Level "top"),
Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))],
Gramext.action
(fun (_ : 'endif) (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(if is_defined i then e2 else e1 : 'expr));
[Gramext.Stoken ("", "IFDEF");
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))],
Gramext.action
(fun (_ : 'endif) (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(if is_defined i then e1 else e2 : 'expr))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
Some (Gramext.Level "simple"),
[None, None,
[[Gramext.Stoken ("LIDENT", "__LOCATION__")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (let bp = string_of_int (fst loc).Lexing.pos_cnum in
- let ep = string_of_int (snd loc).Lexing.pos_cnum in
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
+ (let bp = string_of_int (fst _loc).Lexing.pos_cnum in
+ let ep = string_of_int (snd _loc).Lexing.pos_cnum in
MLast.ExTup
- (loc, [MLast.ExInt (loc, bp); MLast.ExInt (loc, ep)]) :
+ (_loc, [MLast.ExInt (_loc, bp); MLast.ExInt (_loc, ep)]) :
'expr));
[Gramext.Stoken ("LIDENT", "__FILE__")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (MLast.ExStr (loc, !(Pcaml.input_file)) : 'expr))]];
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExStr (_loc, !(Pcaml.input_file)) : 'expr))]];
Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "IFNDEF");
Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))],
Gramext.action
(fun (_ : 'endif) (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(if is_defined i then p2 else p1 : 'patt));
[Gramext.Stoken ("", "IFDEF");
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))],
Gramext.action
(fun (_ : 'endif) (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(if is_defined i then p1 else p2 : 'patt))]];
Grammar.Entry.obj (uident : 'uident Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("UIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
(i : 'uident))]]]);;
Pcaml.add_option "-D" (Arg.String (define None))
| None -> false
;;
-let mksequence loc =
+let mksequence _loc =
function
[e] -> e
- | el -> MLast.ExSeq (loc, el)
+ | el -> MLast.ExSeq (_loc, el)
;;
-let mkmatchcase loc p aso w e =
+let mkmatchcase _loc p aso w e =
let p =
match aso with
- Some p2 -> MLast.PaAli (loc, p, p2)
+ Some p2 -> MLast.PaAli (_loc, p, p2)
| _ -> p
in
p, w, e
if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) else "-" ^ n
;;
-let mkumin loc f arg =
+let mkumin _loc f arg =
match arg with
- MLast.ExInt (_, n) -> MLast.ExInt (loc, neg_string n)
+ MLast.ExInt (_, n) -> MLast.ExInt (_loc, neg_string n)
| MLast.ExInt32 (loc, n) -> MLast.ExInt32 (loc, neg_string n)
| MLast.ExInt64 (loc, n) -> MLast.ExInt64 (loc, neg_string n)
| MLast.ExNativeInt (loc, n) -> MLast.ExNativeInt (loc, neg_string n)
- | MLast.ExFlo (_, n) -> MLast.ExFlo (loc, neg_string n)
- | _ -> let f = "~" ^ f in MLast.ExApp (loc, MLast.ExLid (loc, f), arg)
+ | MLast.ExFlo (_, n) -> MLast.ExFlo (_loc, neg_string n)
+ | _ -> let f = "~" ^ f in MLast.ExApp (_loc, MLast.ExLid (_loc, f), arg)
;;
-let mklistexp loc last =
+let mklistexp _loc last =
let rec loop top =
function
[] ->
begin match last with
Some e -> e
- | None -> MLast.ExUid (loc, "[]")
+ | None -> MLast.ExUid (_loc, "[]")
end
| e1 :: el ->
- let loc = if top then loc else fst (MLast.loc_of_expr e1), snd loc in
+ let _loc =
+ if top then _loc else fst (MLast.loc_of_expr e1), snd _loc
+ in
MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e1), loop false el)
+ (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), e1),
+ loop false el)
in
loop true
;;
-let mklistpat loc last =
+let mklistpat _loc last =
let rec loop top =
function
[] ->
begin match last with
Some p -> p
- | None -> MLast.PaUid (loc, "[]")
+ | None -> MLast.PaUid (_loc, "[]")
end
| p1 :: pl ->
- let loc = if top then loc else fst (MLast.loc_of_patt p1), snd loc in
+ let _loc =
+ if top then _loc else fst (MLast.loc_of_patt p1), snd _loc
+ in
MLast.PaApp
- (loc, MLast.PaApp (loc, MLast.PaUid (loc, "::"), p1), loop false pl)
+ (_loc, MLast.PaApp (_loc, MLast.PaUid (_loc, "::"), p1),
+ loop false pl)
in
loop true
;;
-let mkexprident loc i j =
- let rec loop m =
- function
- MLast.ExAcc (_, x, y) -> loop (MLast.ExAcc (loc, m, x)) y
- | e -> MLast.ExAcc (loc, m, e)
- in
- loop (MLast.ExUid (loc, i)) j
+let mkexprident _loc ids =
+ match ids with
+ [] -> Stdpp.raise_with_loc _loc (Stream.Error "illegal long identifier")
+ | id :: ids ->
+ let rec loop m =
+ function
+ id :: ids -> loop (MLast.ExAcc (_loc, m, id)) ids
+ | [] -> m
+ in
+ loop id ids
;;
-let mkassert loc e =
+let mkassert _loc e =
match e with
- MLast.ExUid (_, "False") -> MLast.ExAsf loc
- | _ -> MLast.ExAsr (loc, e)
+ MLast.ExUid (_, "False") -> MLast.ExAsf _loc
+ | _ -> MLast.ExAsr (_loc, e)
;;
let append_elem el e = el @ [e];;
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (s : 'str_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(s : 'e__1))]);
Gramext.Stoken ("", "end")],
Gramext.action
(fun _ (st : 'e__1 list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.MeStr (loc, st) : 'module_expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.MeStr (_loc, st) : 'module_expr));
[Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "(");
Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":");
Gramext.Snterm
Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself],
Gramext.action
(fun (me : 'module_expr) _ _ (t : 'module_type) _ (i : string) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.MeFun (loc, i, t, me) : 'module_expr))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.MeFun (_loc, i, t, me) : 'module_expr))];
None, None,
[[Gramext.Sself; Gramext.Sself],
Gramext.action
(fun (me2 : 'module_expr) (me1 : 'module_expr)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.MeApp (loc, me1, me2) : 'module_expr))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.MeApp (_loc, me1, me2) : 'module_expr))];
None, None,
[[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (me2 : 'module_expr) _ (me1 : 'module_expr)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.MeAcc (loc, me1, me2) : 'module_expr))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.MeAcc (_loc, me1, me2) : 'module_expr))];
Some "simple", None,
[[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (me : 'module_expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(me : 'module_expr));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
Gramext.Snterm
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (mt : 'module_type) _ (me : 'module_expr) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.MeTyc (loc, me, mt) : 'module_expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.MeTyc (_loc, me, mt) : 'module_expr));
[Gramext.Stoken ("UIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.MeUid (loc, i) : 'module_expr))]];
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.MeUid (_loc, i) : 'module_expr))]];
Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None,
[Some "top", None,
[[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) (loc : Lexing.position * Lexing.position) ->
- (MLast.StExp (loc, e) : 'str_item));
+ (fun (e : 'expr) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.StExp (_loc, e) : 'str_item));
[Gramext.Stoken ("", "value");
Gramext.Sopt (Gramext.Stoken ("", "rec"));
Gramext.Slist1sep
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (l : 'let_binding list) (r : string option) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.StVal (loc, o2b r, l) : 'str_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.StVal (_loc, o2b r, l) : 'str_item));
[Gramext.Stoken ("", "type");
Gramext.Slist1sep
(Gramext.Snterm
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (tdl : 'type_declaration list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.StTyp (loc, tdl) : 'str_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.StTyp (_loc, tdl) : 'str_item));
[Gramext.Stoken ("", "open");
Gramext.Snterm
(Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'mod_ident) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.StOpn (loc, i) : 'str_item));
+ (fun (i : 'mod_ident) _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.StOpn (_loc, i) : 'str_item));
[Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type");
Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "=");
Gramext.Snterm
(Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
Gramext.action
(fun (mt : 'module_type) _ (i : string) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.StMty (loc, i, mt) : 'str_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.StMty (_loc, i, mt) : 'str_item));
[Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec");
Gramext.Slist1sep
(Gramext.Snterm
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (nmtmes : 'module_rec_binding list) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.StRecMod (loc, nmtmes) : 'str_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.StRecMod (_loc, nmtmes) : 'str_item));
[Gramext.Stoken ("", "module"); Gramext.Stoken ("UIDENT", "");
Gramext.Snterm
(Grammar.Entry.obj
(module_binding : 'module_binding Grammar.Entry.e))],
Gramext.action
(fun (mb : 'module_binding) (i : string) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.StMod (loc, i, mb) : 'str_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.StMod (_loc, i, mb) : 'str_item));
[Gramext.Stoken ("", "include");
Gramext.Snterm
(Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
Gramext.action
(fun (me : 'module_expr) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.StInc (loc, me) : 'str_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.StInc (_loc, me) : 'str_item));
[Gramext.Stoken ("", "external"); Gramext.Stoken ("LIDENT", "");
Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Slist1 (Gramext.Stoken ("STRING", ""))],
Gramext.action
(fun (pd : string list) _ (t : 'ctyp) _ (i : string) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.StExt (loc, i, t, pd) : 'str_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.StExt (_loc, i, t, pd) : 'str_item));
[Gramext.Stoken ("", "exception");
Gramext.Snterm
(Grammar.Entry.obj
(Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e))],
Gramext.action
(fun (b : 'rebind_exn) (_, c, tl : 'constructor_declaration) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.StExc (loc, c, tl, b) : 'str_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.StExc (_loc, c, tl, b) : 'str_item));
[Gramext.Stoken ("", "declare");
Gramext.Slist0
(Gramext.srules
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (s : 'str_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(s : 'e__2))]);
Gramext.Stoken ("", "end")],
Gramext.action
(fun _ (st : 'e__2 list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.StDcl (loc, st) : 'str_item))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.StDcl (_loc, st) : 'str_item))]];
Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e), None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) -> ([] : 'rebind_exn));
+ (fun (_loc : Lexing.position * Lexing.position) ->
+ ([] : 'rebind_exn));
[Gramext.Stoken ("", "=");
Gramext.Snterm
(Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))],
Gramext.action
- (fun (sl : 'mod_ident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (sl : 'mod_ident) _ (_loc : Lexing.position * Lexing.position) ->
(sl : 'rebind_exn))]];
Grammar.Entry.obj (module_binding : 'module_binding Grammar.Entry.e),
None,
(Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
Gramext.action
(fun (me : 'module_expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(me : 'module_binding));
[Gramext.Stoken ("", ":");
Gramext.Snterm
(Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
Gramext.action
(fun (me : 'module_expr) _ (mt : 'module_type) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.MeTyc (loc, me, mt) : 'module_binding));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.MeTyc (_loc, me, mt) : 'module_binding));
[Gramext.Stoken ("", "("); Gramext.Stoken ("UIDENT", "");
Gramext.Stoken ("", ":");
Gramext.Snterm
Gramext.Stoken ("", ")"); Gramext.Sself],
Gramext.action
(fun (mb : 'module_binding) _ (mt : 'module_type) _ (m : string) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.MeFun (loc, m, mt, mb) : 'module_binding))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.MeFun (_loc, m, mt, mb) : 'module_binding))]];
Grammar.Entry.obj
(module_rec_binding : 'module_rec_binding Grammar.Entry.e),
None,
(Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
Gramext.action
(fun (me : 'module_expr) _ (mt : 'module_type) _ (m : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(m, mt, me : 'module_rec_binding))]];
Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e), None,
[None, None,
Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself],
Gramext.action
(fun (mt : 'module_type) _ _ (t : 'module_type) _ (i : string) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.MtFun (loc, i, t, mt) : 'module_type))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.MtFun (_loc, i, t, mt) : 'module_type))];
None, None,
[[Gramext.Sself; Gramext.Stoken ("", "with");
Gramext.Slist1sep
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (wcl : 'with_constr list) _ (mt : 'module_type)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.MtWit (loc, mt, wcl) : 'module_type))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.MtWit (_loc, mt, wcl) : 'module_type))];
None, None,
[[Gramext.Stoken ("", "sig");
Gramext.Slist0
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (s : 'sig_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(s : 'e__3))]);
Gramext.Stoken ("", "end")],
Gramext.action
(fun _ (sg : 'e__3 list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.MtSig (loc, sg) : 'module_type))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.MtSig (_loc, sg) : 'module_type))];
None, None,
[[Gramext.Sself; Gramext.Sself],
Gramext.action
(fun (m2 : 'module_type) (m1 : 'module_type)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.MtApp (loc, m1, m2) : 'module_type))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.MtApp (_loc, m1, m2) : 'module_type))];
None, None,
[[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (m2 : 'module_type) _ (m1 : 'module_type)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.MtAcc (loc, m1, m2) : 'module_type))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.MtAcc (_loc, m1, m2) : 'module_type))];
Some "simple", None,
[[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (mt : 'module_type) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(mt : 'module_type));
[Gramext.Stoken ("", "'");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.MtQuo (loc, i) : 'module_type));
+ (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.MtQuo (_loc, i) : 'module_type));
[Gramext.Stoken ("LIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.MtLid (loc, i) : 'module_type));
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.MtLid (_loc, i) : 'module_type));
[Gramext.Stoken ("UIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.MtUid (loc, i) : 'module_type))]];
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.MtUid (_loc, i) : 'module_type))]];
Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None,
[Some "top", None,
[[Gramext.Stoken ("", "value"); Gramext.Stoken ("LIDENT", "");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (i : string) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.SgVal (loc, i, t) : 'sig_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.SgVal (_loc, i, t) : 'sig_item));
[Gramext.Stoken ("", "type");
Gramext.Slist1sep
(Gramext.Snterm
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (tdl : 'type_declaration list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.SgTyp (loc, tdl) : 'sig_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.SgTyp (_loc, tdl) : 'sig_item));
[Gramext.Stoken ("", "open");
Gramext.Snterm
(Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'mod_ident) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.SgOpn (loc, i) : 'sig_item));
+ (fun (i : 'mod_ident) _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.SgOpn (_loc, i) : 'sig_item));
[Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type");
Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "=");
Gramext.Snterm
(Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
Gramext.action
(fun (mt : 'module_type) _ (i : string) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.SgMty (loc, i, mt) : 'sig_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.SgMty (_loc, i, mt) : 'sig_item));
[Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec");
Gramext.Slist1sep
(Gramext.Snterm
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (mds : 'module_rec_declaration list) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.SgRecMod (loc, mds) : 'sig_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.SgRecMod (_loc, mds) : 'sig_item));
[Gramext.Stoken ("", "module"); Gramext.Stoken ("UIDENT", "");
Gramext.Snterm
(Grammar.Entry.obj
(module_declaration : 'module_declaration Grammar.Entry.e))],
Gramext.action
(fun (mt : 'module_declaration) (i : string) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.SgMod (loc, i, mt) : 'sig_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.SgMod (_loc, i, mt) : 'sig_item));
[Gramext.Stoken ("", "include");
Gramext.Snterm
(Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
Gramext.action
(fun (mt : 'module_type) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.SgInc (loc, mt) : 'sig_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.SgInc (_loc, mt) : 'sig_item));
[Gramext.Stoken ("", "external"); Gramext.Stoken ("LIDENT", "");
Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Slist1 (Gramext.Stoken ("STRING", ""))],
Gramext.action
(fun (pd : string list) _ (t : 'ctyp) _ (i : string) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.SgExt (loc, i, t, pd) : 'sig_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.SgExt (_loc, i, t, pd) : 'sig_item));
[Gramext.Stoken ("", "exception");
Gramext.Snterm
(Grammar.Entry.obj
'constructor_declaration Grammar.Entry.e))],
Gramext.action
(fun (_, c, tl : 'constructor_declaration) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.SgExc (loc, c, tl) : 'sig_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.SgExc (_loc, c, tl) : 'sig_item));
[Gramext.Stoken ("", "declare");
Gramext.Slist0
(Gramext.srules
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (s : 'sig_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(s : 'e__4))]);
Gramext.Stoken ("", "end")],
Gramext.action
(fun _ (st : 'e__4 list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.SgDcl (loc, st) : 'sig_item))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.SgDcl (_loc, st) : 'sig_item))]];
Grammar.Entry.obj
(module_declaration : 'module_declaration Grammar.Entry.e),
None,
Gramext.Stoken ("", ")"); Gramext.Sself],
Gramext.action
(fun (mt : 'module_declaration) _ (t : 'module_type) _ (i : string) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.MtFun (loc, i, t, mt) : 'module_declaration));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.MtFun (_loc, i, t, mt) : 'module_declaration));
[Gramext.Stoken ("", ":");
Gramext.Snterm
(Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
Gramext.action
(fun (mt : 'module_type) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(mt : 'module_declaration))]];
Grammar.Entry.obj
(module_rec_declaration : 'module_rec_declaration Grammar.Entry.e),
(Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
Gramext.action
(fun (mt : 'module_type) _ (m : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(m, mt : 'module_rec_declaration))]];
Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e), None,
[None, None,
(Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
Gramext.action
(fun (me : 'module_expr) _ (i : 'mod_ident) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.WcMod (loc, i, me) : 'with_constr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.WcMod (_loc, i, me) : 'with_constr));
[Gramext.Stoken ("", "type");
Gramext.Snterm
(Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (tpl : 'type_parameter list) (i : 'mod_ident) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.WcTyp (loc, i, tpl, t) : 'with_constr))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.WcTyp (_loc, i, tpl, t) : 'with_constr))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), None,
[Some "top", Some Gramext.RightA,
[[Gramext.Stoken ("", "object");
Gramext.Stoken ("", "end")],
Gramext.action
(fun _ (cf : 'class_structure) (cspo : 'class_self_patt option) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExObj (loc, cspo, cf) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExObj (_loc, cspo, cf) : 'expr));
[Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do");
Gramext.Stoken ("", "{");
Gramext.Snterm
Gramext.Stoken ("", "}")],
Gramext.action
(fun _ (seq : 'sequence) _ _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExWhi (loc, e, seq) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExWhi (_loc, e, seq) : 'expr));
[Gramext.Stoken ("", "for"); Gramext.Stoken ("LIDENT", "");
Gramext.Stoken ("", "="); Gramext.Sself;
Gramext.Snterm
Gramext.action
(fun _ (seq : 'sequence) _ _ (e2 : 'expr) (df : 'direction_flag)
(e1 : 'expr) _ (i : string) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExFor (loc, i, e1, e2, df, seq) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExFor (_loc, i, e1, e2, df, seq) : 'expr));
[Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{");
Gramext.Snterm
(Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e));
Gramext.Stoken ("", "}")],
Gramext.action
(fun _ (seq : 'sequence) _ _
- (loc : Lexing.position * Lexing.position) ->
- (mksequence loc seq : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (mksequence _loc seq : 'expr));
[Gramext.Stoken ("", "if"); Gramext.Sself; Gramext.Stoken ("", "then");
Gramext.Sself; Gramext.Stoken ("", "else"); Gramext.Sself],
Gramext.action
(fun (e3 : 'expr) _ (e2 : 'expr) _ (e1 : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExIfe (loc, e1, e2, e3) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExIfe (_loc, e1, e2, e3) : 'expr));
[Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with");
Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
Gramext.Stoken ("", "->"); Gramext.Sself],
Gramext.action
(fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExTry (loc, e, [p1, None, e1]) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExTry (_loc, e, [p1, None, e1]) : 'expr));
[Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with");
Gramext.Stoken ("", "[");
Gramext.Slist0sep
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (l : 'match_case list) _ _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExTry (loc, e, l) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExTry (_loc, e, l) : 'expr));
[Gramext.Stoken ("", "match"); Gramext.Sself;
Gramext.Stoken ("", "with");
Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
Gramext.Stoken ("", "->"); Gramext.Sself],
Gramext.action
(fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExMat (loc, e, [p1, None, e1]) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExMat (_loc, e, [p1, None, e1]) : 'expr));
[Gramext.Stoken ("", "match"); Gramext.Sself;
Gramext.Stoken ("", "with"); Gramext.Stoken ("", "[");
Gramext.Slist0sep
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (l : 'match_case list) _ _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExMat (loc, e, l) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExMat (_loc, e, l) : 'expr));
[Gramext.Stoken ("", "fun");
Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
Gramext.Snterm
(Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e))],
Gramext.action
(fun (e : 'fun_def) (p : 'ipatt) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExFun (loc, [p, None, e]) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExFun (_loc, [p, None, e]) : 'expr));
[Gramext.Stoken ("", "fun"); Gramext.Stoken ("", "[");
Gramext.Slist0sep
(Gramext.Snterm
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (l : 'match_case list) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExFun (loc, l) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExFun (_loc, l) : 'expr));
[Gramext.Stoken ("", "let"); Gramext.Stoken ("", "module");
Gramext.Stoken ("UIDENT", "");
Gramext.Snterm
Gramext.Stoken ("", "in"); Gramext.Sself],
Gramext.action
(fun (e : 'expr) _ (mb : 'module_binding) (m : string) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExLmd (loc, m, mb, e) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExLmd (_loc, m, mb, e) : 'expr));
[Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec"));
Gramext.Slist1sep
(Gramext.Snterm
Gramext.Stoken ("", "in"); Gramext.Sself],
Gramext.action
(fun (x : 'expr) _ (l : 'let_binding list) (r : string option) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExLet (loc, o2b r, l, x) : 'expr))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExLet (_loc, o2b r, l, x) : 'expr))];
Some "where", None,
[[Gramext.Sself; Gramext.Stoken ("", "where");
Gramext.Sopt (Gramext.Stoken ("", "rec"));
(Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e))],
Gramext.action
(fun (lb : 'let_binding) (rf : string option) _ (e : 'expr)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExLet (loc, o2b rf, [lb], e) : 'expr))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExLet (_loc, o2b rf, [lb], e) : 'expr))];
Some ":=", Some Gramext.NonA,
[[Gramext.Sself; Gramext.Stoken ("", ":="); Gramext.Sself;
Gramext.Snterm (Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e))],
Gramext.action
(fun _ (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExAss (loc, e1, e2) : 'expr))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExAss (_loc, e1, e2) : 'expr))];
Some "||", Some Gramext.RightA,
[[Gramext.Sself; Gramext.Stoken ("", "||"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "||"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "||"), e1), e2) :
'expr))];
Some "&&", Some Gramext.RightA,
[[Gramext.Sself; Gramext.Stoken ("", "&&"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "&&"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "&&"), e1), e2) :
'expr))];
Some "<", Some Gramext.LeftA,
[[Gramext.Sself; Gramext.Stoken ("", "!="); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "!="), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "!="), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "=="), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "=="), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "<>"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "<>"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "<>"), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "="); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "="), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "="), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", ">="); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, ">="), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, ">="), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "<="); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "<="), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "<="), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", ">"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, ">"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, ">"), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "<"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "<"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "<"), e1), e2) :
'expr))];
Some "^", Some Gramext.RightA,
[[Gramext.Sself; Gramext.Stoken ("", "@"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "@"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "@"), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "^"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "^"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "^"), e1), e2) :
'expr))];
Some "+", Some Gramext.LeftA,
[[Gramext.Sself; Gramext.Stoken ("", "-."); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "-."), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "-."), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "+."); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "+."), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "+."), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "-"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "-"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "-"), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "+"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "+"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "+"), e1), e2) :
'expr))];
Some "*", Some Gramext.LeftA,
[[Gramext.Sself; Gramext.Stoken ("", "mod"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "mod"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "mod"), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "lxor"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "lxor"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "lxor"), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "lor"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "lor"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "lor"), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "land"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "land"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "land"), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "/."); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "/."), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "/."), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "*."); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "*."), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "*."), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "/"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "/"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "/"), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "*"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "*"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "*"), e1), e2) :
'expr))];
Some "**", Some Gramext.RightA,
[[Gramext.Sself; Gramext.Stoken ("", "lsr"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "lsr"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "lsr"), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "lsl"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "lsl"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "lsl"), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "asr"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "asr"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "asr"), e1), e2) :
'expr));
[Gramext.Sself; Gramext.Stoken ("", "**"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExLid (loc, "**"), e1), e2) :
+ (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "**"), e1), e2) :
'expr))];
Some "unary minus", Some Gramext.NonA,
[[Gramext.Stoken ("", "-."); Gramext.Sself],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
- (mkumin loc "-." e : 'expr));
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
+ (mkumin _loc "-." e : 'expr));
[Gramext.Stoken ("", "-"); Gramext.Sself],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
- (mkumin loc "-" e : 'expr))];
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
+ (mkumin _loc "-" e : 'expr))];
Some "apply", Some Gramext.LeftA,
[[Gramext.Stoken ("", "lazy"); Gramext.Sself],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.ExLaz (loc, e) : 'expr));
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExLaz (_loc, e) : 'expr));
[Gramext.Stoken ("", "assert"); Gramext.Sself],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
- (mkassert loc e : 'expr));
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
+ (mkassert _loc e : 'expr));
[Gramext.Sself; Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExApp (loc, e1, e2) : 'expr))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExApp (_loc, e1, e2) : 'expr))];
Some ".", Some Gramext.LeftA,
[[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExAcc (loc, e1, e2) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExAcc (_loc, e1, e2) : 'expr));
[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "[");
Gramext.Sself; Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (e2 : 'expr) _ _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExSte (loc, e1, e2) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExSte (_loc, e1, e2) : 'expr));
[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "(");
Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (e2 : 'expr) _ _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExAre (loc, e1, e2) : 'expr))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExAre (_loc, e1, e2) : 'expr))];
Some "~-", Some Gramext.NonA,
[[Gramext.Stoken ("", "~-."); Gramext.Sself],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.ExApp (loc, MLast.ExLid (loc, "~-."), e) : 'expr));
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExApp (_loc, MLast.ExLid (_loc, "~-."), e) : 'expr));
[Gramext.Stoken ("", "~-"); Gramext.Sself],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.ExApp (loc, MLast.ExLid (loc, "~-"), e) : 'expr))];
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExApp (_loc, MLast.ExLid (_loc, "~-"), e) : 'expr))];
Some "simple", None,
[[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(e : 'expr));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ",");
Gramext.Slist1sep
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (el : 'expr list) _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExTup (loc, (e :: el)) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExTup (_loc, (e :: el)) : 'expr));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (t : 'ctyp) _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExTyc (loc, e, t) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExTyc (_loc, e, t) : 'expr));
[Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ _ (loc : Lexing.position * Lexing.position) ->
- (MLast.ExUid (loc, "()") : 'expr));
+ (fun _ _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExUid (_loc, "()") : 'expr));
[Gramext.Stoken ("", "{"); Gramext.Stoken ("", "("); Gramext.Sself;
Gramext.Stoken ("", ")"); Gramext.Stoken ("", "with");
Gramext.Slist1sep
Gramext.Stoken ("", "}")],
Gramext.action
(fun _ (lel : 'label_expr list) _ _ (e : 'expr) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExRec (loc, lel, Some e) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExRec (_loc, lel, Some e) : 'expr));
[Gramext.Stoken ("", "{");
Gramext.Slist1sep
(Gramext.Snterm
Gramext.Stoken ("", "}")],
Gramext.action
(fun _ (lel : 'label_expr list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExRec (loc, lel, None) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExRec (_loc, lel, None) : 'expr));
[Gramext.Stoken ("", "[|");
Gramext.Slist0sep
(Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)),
Gramext.Stoken ("", "|]")],
Gramext.action
(fun _ (el : 'expr list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExArr (loc, el) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExArr (_loc, el) : 'expr));
[Gramext.Stoken ("", "[");
Gramext.Slist1sep
(Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)),
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (last : 'cons_expr_opt) (el : 'expr list) _
- (loc : Lexing.position * Lexing.position) ->
- (mklistexp loc last el : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (mklistexp _loc last el : 'expr));
[Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")],
Gramext.action
- (fun _ _ (loc : Lexing.position * Lexing.position) ->
- (MLast.ExUid (loc, "[]") : 'expr));
+ (fun _ _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExUid (_loc, "[]") : 'expr));
[Gramext.Snterm
(Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'expr_ident) (loc : Lexing.position * Lexing.position) ->
- (i : 'expr));
+ (fun (ids : 'expr_ident) (_loc : Lexing.position * Lexing.position) ->
+ (mkexprident _loc ids : 'expr));
[Gramext.Stoken ("CHAR", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.ExChr (loc, s) : 'expr));
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExChr (_loc, s) : 'expr));
[Gramext.Stoken ("STRING", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.ExStr (loc, s) : 'expr));
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExStr (_loc, s) : 'expr));
[Gramext.Stoken ("FLOAT", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.ExFlo (loc, s) : 'expr));
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExFlo (_loc, s) : 'expr));
[Gramext.Stoken ("NATIVEINT", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.ExNativeInt (loc, s) : 'expr));
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExNativeInt (_loc, s) : 'expr));
[Gramext.Stoken ("INT64", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.ExInt64 (loc, s) : 'expr));
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExInt64 (_loc, s) : 'expr));
[Gramext.Stoken ("INT32", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.ExInt32 (loc, s) : 'expr));
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExInt32 (_loc, s) : 'expr));
[Gramext.Stoken ("INT", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.ExInt (loc, s) : 'expr))]];
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExInt (_loc, s) : 'expr))]];
Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e), None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
+ (fun (_loc : Lexing.position * Lexing.position) ->
(None : 'cons_expr_opt));
[Gramext.Stoken ("", "::");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(Some e : 'cons_expr_opt))]];
Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e), None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) -> (() : 'dummy))]];
+ (fun (_loc : Lexing.position * Lexing.position) -> (() : 'dummy))]];
Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) (_loc : Lexing.position * Lexing.position) ->
([e] : 'sequence));
[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
Gramext.Stoken ("", ";")],
Gramext.action
- (fun _ (e : 'expr) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (e : 'expr) (_loc : Lexing.position * Lexing.position) ->
([e] : 'sequence));
[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
Gramext.Stoken ("", ";"); Gramext.Sself],
Gramext.action
(fun (el : 'sequence) _ (e : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(e :: el : 'sequence));
[Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec"));
Gramext.Slist1sep
Gramext.srules
[[Gramext.Stoken ("", ";")],
Gramext.action
- (fun (x : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (x : string) (_loc : Lexing.position * Lexing.position) ->
(x : 'e__5));
[Gramext.Stoken ("", "in")],
Gramext.action
- (fun (x : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (x : string) (_loc : Lexing.position * Lexing.position) ->
(x : 'e__5))];
Gramext.Sself],
Gramext.action
(fun (el : 'sequence) _ (l : 'let_binding list) (rf : string option) _
- (loc : Lexing.position * Lexing.position) ->
- ([MLast.ExLet (loc, o2b rf, l, mksequence loc el)] : 'sequence))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ ([MLast.ExLet (_loc, o2b rf, l, mksequence _loc el)] :
+ 'sequence))]];
Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
(Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))],
Gramext.action
(fun (e : 'fun_binding) (p : 'ipatt)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(p, e : 'let_binding))]];
Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e), None,
[None, Some Gramext.RightA,
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
(fun (e : 'expr) _ (t : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExCoe (loc, e, None, t) : 'fun_binding));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExCoe (_loc, e, None, t) : 'fun_binding));
[Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", "=");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
(fun (e : 'expr) _ (t : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExTyc (loc, e, t) : 'fun_binding));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExTyc (_loc, e, t) : 'fun_binding));
[Gramext.Stoken ("", "=");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(e : 'fun_binding));
[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
Gramext.Sself],
Gramext.action
(fun (e : 'fun_binding) (p : 'ipatt)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExFun (loc, [p, None, e]) : 'fun_binding))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExFun (_loc, [p, None, e]) : 'fun_binding))]];
Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
(fun (e : 'expr) _ (w : 'when_expr_opt) (aso : 'as_patt_opt)
- (p : 'patt) (loc : Lexing.position * Lexing.position) ->
- (mkmatchcase loc p aso w e : 'match_case))]];
+ (p : 'patt) (_loc : Lexing.position * Lexing.position) ->
+ (mkmatchcase _loc p aso w e : 'match_case))]];
Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e), None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
+ (fun (_loc : Lexing.position * Lexing.position) ->
(None : 'as_patt_opt));
[Gramext.Stoken ("", "as");
Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
Gramext.action
- (fun (p : 'patt) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (p : 'patt) _ (_loc : Lexing.position * Lexing.position) ->
(Some p : 'as_patt_opt))]];
Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e), None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
+ (fun (_loc : Lexing.position * Lexing.position) ->
(None : 'when_expr_opt));
[Gramext.Stoken ("", "when");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(Some e : 'when_expr_opt))]];
Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e), None,
[None, None,
(Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))],
Gramext.action
(fun (e : 'fun_binding) (i : 'patt_label_ident)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(i, e : 'label_expr))]];
Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e), None,
[None, Some Gramext.RightA,
Gramext.Sself],
Gramext.action
(fun (j : 'expr_ident) _ (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (mkexprident loc i j : 'expr_ident));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExUid (_loc, i) :: j : 'expr_ident));
[Gramext.Stoken ("UIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.ExUid (loc, i) : 'expr_ident));
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ ([MLast.ExUid (_loc, i)] : 'expr_ident));
[Gramext.Stoken ("LIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.ExLid (loc, i) : 'expr_ident))]];
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ ([MLast.ExLid (_loc, i)] : 'expr_ident))]];
Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e), None,
[None, Some Gramext.RightA,
[[Gramext.Stoken ("", "->");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(e : 'fun_def));
[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
Gramext.Sself],
Gramext.action
(fun (e : 'fun_def) (p : 'ipatt)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExFun (loc, [p, None, e]) : 'fun_def))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExFun (_loc, [p, None, e]) : 'fun_def))]];
Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), None,
[None, Some Gramext.LeftA,
[[Gramext.Sself; Gramext.Stoken ("", "|"); Gramext.Sself],
Gramext.action
(fun (p2 : 'patt) _ (p1 : 'patt)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaOrp (loc, p1, p2) : 'patt))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaOrp (_loc, p1, p2) : 'patt))];
None, Some Gramext.NonA,
[[Gramext.Sself; Gramext.Stoken ("", ".."); Gramext.Sself],
Gramext.action
(fun (p2 : 'patt) _ (p1 : 'patt)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaRng (loc, p1, p2) : 'patt))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaRng (_loc, p1, p2) : 'patt))];
None, Some Gramext.LeftA,
[[Gramext.Sself; Gramext.Sself],
Gramext.action
(fun (p2 : 'patt) (p1 : 'patt)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaApp (loc, p1, p2) : 'patt))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaApp (_loc, p1, p2) : 'patt))];
None, Some Gramext.LeftA,
[[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (p2 : 'patt) _ (p1 : 'patt)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaAcc (loc, p1, p2) : 'patt))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaAcc (_loc, p1, p2) : 'patt))];
Some "simple", None,
[[Gramext.Stoken ("", "_")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (MLast.PaAny loc : 'patt));
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaAny _loc : 'patt));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ",");
Gramext.Slist1sep
(Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)),
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (pl : 'patt list) _ (p : 'patt) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaTup (loc, (p :: pl)) : 'patt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaTup (_loc, (p :: pl)) : 'patt));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as");
Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (p2 : 'patt) _ (p : 'patt) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaAli (loc, p, p2) : 'patt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaAli (_loc, p, p2) : 'patt));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (t : 'ctyp) _ (p : 'patt) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaTyc (loc, p, t) : 'patt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaTyc (_loc, p, t) : 'patt));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (p : 'patt) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (p : 'patt) _ (_loc : Lexing.position * Lexing.position) ->
(p : 'patt));
[Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ _ (loc : Lexing.position * Lexing.position) ->
- (MLast.PaUid (loc, "()") : 'patt));
+ (fun _ _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaUid (_loc, "()") : 'patt));
[Gramext.Stoken ("", "{");
Gramext.Slist1sep
(Gramext.Snterm
Gramext.Stoken ("", "}")],
Gramext.action
(fun _ (lpl : 'label_patt list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaRec (loc, lpl) : 'patt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaRec (_loc, lpl) : 'patt));
[Gramext.Stoken ("", "[|");
Gramext.Slist0sep
(Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)),
Gramext.Stoken ("", "|]")],
Gramext.action
(fun _ (pl : 'patt list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaArr (loc, pl) : 'patt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaArr (_loc, pl) : 'patt));
[Gramext.Stoken ("", "[");
Gramext.Slist1sep
(Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)),
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (last : 'cons_patt_opt) (pl : 'patt list) _
- (loc : Lexing.position * Lexing.position) ->
- (mklistpat loc last pl : 'patt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (mklistpat _loc last pl : 'patt));
[Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")],
Gramext.action
- (fun _ _ (loc : Lexing.position * Lexing.position) ->
- (MLast.PaUid (loc, "[]") : 'patt));
+ (fun _ _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaUid (_loc, "[]") : 'patt));
[Gramext.Stoken ("", "-"); Gramext.Stoken ("FLOAT", "")],
Gramext.action
- (fun (s : string) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.PaFlo (loc, neg_string s) : 'patt));
+ (fun (s : string) _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaFlo (_loc, neg_string s) : 'patt));
[Gramext.Stoken ("", "-"); Gramext.Stoken ("NATIVEINT", "")],
Gramext.action
- (fun (s : string) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.PaNativeInt (loc, neg_string s) : 'patt));
+ (fun (s : string) _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaNativeInt (_loc, neg_string s) : 'patt));
[Gramext.Stoken ("", "-"); Gramext.Stoken ("INT64", "")],
Gramext.action
- (fun (s : string) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.PaInt64 (loc, neg_string s) : 'patt));
+ (fun (s : string) _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaInt64 (_loc, neg_string s) : 'patt));
[Gramext.Stoken ("", "-"); Gramext.Stoken ("INT32", "")],
Gramext.action
- (fun (s : string) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.PaInt32 (loc, neg_string s) : 'patt));
+ (fun (s : string) _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaInt32 (_loc, neg_string s) : 'patt));
[Gramext.Stoken ("", "-"); Gramext.Stoken ("INT", "")],
Gramext.action
- (fun (s : string) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.PaInt (loc, neg_string s) : 'patt));
+ (fun (s : string) _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaInt (_loc, neg_string s) : 'patt));
[Gramext.Stoken ("CHAR", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaChr (loc, s) : 'patt));
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaChr (_loc, s) : 'patt));
[Gramext.Stoken ("STRING", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaStr (loc, s) : 'patt));
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaStr (_loc, s) : 'patt));
[Gramext.Stoken ("FLOAT", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaFlo (loc, s) : 'patt));
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaFlo (_loc, s) : 'patt));
[Gramext.Stoken ("NATIVEINT", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaNativeInt (loc, s) : 'patt));
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaNativeInt (_loc, s) : 'patt));
[Gramext.Stoken ("INT64", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaInt64 (loc, s) : 'patt));
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaInt64 (_loc, s) : 'patt));
[Gramext.Stoken ("INT32", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaInt32 (loc, s) : 'patt));
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaInt32 (_loc, s) : 'patt));
[Gramext.Stoken ("INT", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaInt (loc, s) : 'patt));
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaInt (_loc, s) : 'patt));
[Gramext.Stoken ("UIDENT", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaUid (loc, s) : 'patt));
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaUid (_loc, s) : 'patt));
[Gramext.Stoken ("LIDENT", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaLid (loc, s) : 'patt))]];
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaLid (_loc, s) : 'patt))]];
Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e), None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
+ (fun (_loc : Lexing.position * Lexing.position) ->
(None : 'cons_patt_opt));
[Gramext.Stoken ("", "::");
Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
Gramext.action
- (fun (p : 'patt) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (p : 'patt) _ (_loc : Lexing.position * Lexing.position) ->
(Some p : 'cons_patt_opt))]];
Grammar.Entry.obj (label_patt : 'label_patt Grammar.Entry.e), None,
[None, None,
Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
Gramext.action
(fun (p : 'patt) _ (i : 'patt_label_ident)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(i, p : 'label_patt))]];
Grammar.Entry.obj (patt_label_ident : 'patt_label_ident Grammar.Entry.e),
None,
[[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (p2 : 'patt_label_ident) _ (p1 : 'patt_label_ident)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaAcc (loc, p1, p2) : 'patt_label_ident))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaAcc (_loc, p1, p2) : 'patt_label_ident))];
Some "simple", Some Gramext.RightA,
[[Gramext.Stoken ("LIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaLid (loc, i) : 'patt_label_ident));
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaLid (_loc, i) : 'patt_label_ident));
[Gramext.Stoken ("UIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaUid (loc, i) : 'patt_label_ident))]];
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaUid (_loc, i) : 'patt_label_ident))]];
Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "_")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (MLast.PaAny loc : 'ipatt));
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaAny _loc : 'ipatt));
[Gramext.Stoken ("LIDENT", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaLid (loc, s) : 'ipatt));
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaLid (_loc, s) : 'ipatt));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ",");
Gramext.Slist1sep
(Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)),
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (pl : 'ipatt list) _ (p : 'ipatt) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaTup (loc, (p :: pl)) : 'ipatt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaTup (_loc, (p :: pl)) : 'ipatt));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as");
Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (p2 : 'ipatt) _ (p : 'ipatt) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaAli (loc, p, p2) : 'ipatt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaAli (_loc, p, p2) : 'ipatt));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (t : 'ctyp) _ (p : 'ipatt) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaTyc (loc, p, t) : 'ipatt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaTyc (_loc, p, t) : 'ipatt));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (p : 'ipatt) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (p : 'ipatt) _ (_loc : Lexing.position * Lexing.position) ->
(p : 'ipatt));
[Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ _ (loc : Lexing.position * Lexing.position) ->
- (MLast.PaUid (loc, "()") : 'ipatt));
+ (fun _ _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaUid (_loc, "()") : 'ipatt));
[Gramext.Stoken ("", "{");
Gramext.Slist1sep
(Gramext.Snterm
Gramext.Stoken ("", "}")],
Gramext.action
(fun _ (lpl : 'label_ipatt list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaRec (loc, lpl) : 'ipatt))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaRec (_loc, lpl) : 'ipatt))]];
Grammar.Entry.obj (label_ipatt : 'label_ipatt Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm
Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))],
Gramext.action
(fun (p : 'ipatt) _ (i : 'patt_label_ident)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(i, p : 'label_ipatt))]];
Grammar.Entry.obj (type_declaration : 'type_declaration Grammar.Entry.e),
None,
Gramext.action
(fun (cl : 'constrain list) (tk : 'ctyp) _
(tpl : 'type_parameter list) (n : 'type_patt)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(n, tpl, tk, cl : 'type_declaration))]];
Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("LIDENT", "")],
Gramext.action
- (fun (n : string) (loc : Lexing.position * Lexing.position) ->
- (loc, n : 'type_patt))]];
+ (fun (n : string) (_loc : Lexing.position * Lexing.position) ->
+ (_loc, n : 'type_patt))]];
Grammar.Entry.obj (constrain : 'constrain Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "constraint");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t2 : 'ctyp) _ (t1 : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(t1, t2 : 'constrain))]];
Grammar.Entry.obj (type_parameter : 'type_parameter Grammar.Entry.e),
None,
[[Gramext.Stoken ("", "-"); Gramext.Stoken ("", "'");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'ident) _ _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'ident) _ _ (_loc : Lexing.position * Lexing.position) ->
(i, (false, true) : 'type_parameter));
[Gramext.Stoken ("", "+"); Gramext.Stoken ("", "'");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'ident) _ _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'ident) _ _ (_loc : Lexing.position * Lexing.position) ->
(i, (true, false) : 'type_parameter));
[Gramext.Stoken ("", "'");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) ->
(i, (false, false) : 'type_parameter))]];
Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), None,
[None, Some Gramext.LeftA,
[[Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself],
Gramext.action
(fun (t2 : 'ctyp) _ (t1 : 'ctyp)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyMan (loc, t1, t2) : 'ctyp))];
- None, Some Gramext.LeftA,
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyMan (_loc, t1, t2) : 'ctyp))];
+ None, Some Gramext.NonA,
+ [[Gramext.Stoken ("", "private");
+ Gramext.Snterml
+ (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), "alias")],
+ Gramext.action
+ (fun (t : 'ctyp) _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyPrv (_loc, t) : 'ctyp))];
+ Some "alias", Some Gramext.LeftA,
[[Gramext.Sself; Gramext.Stoken ("", "as"); Gramext.Sself],
Gramext.action
(fun (t2 : 'ctyp) _ (t1 : 'ctyp)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyAli (loc, t1, t2) : 'ctyp))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyAli (_loc, t1, t2) : 'ctyp))];
None, Some Gramext.LeftA,
[[Gramext.Stoken ("", "!");
Gramext.Slist1
Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (t : 'ctyp) _ (pl : 'typevar list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyPol (loc, pl, t) : 'ctyp))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyPol (_loc, pl, t) : 'ctyp))];
Some "arrow", Some Gramext.RightA,
[[Gramext.Sself; Gramext.Stoken ("", "->"); Gramext.Sself],
Gramext.action
(fun (t2 : 'ctyp) _ (t1 : 'ctyp)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyArr (loc, t1, t2) : 'ctyp))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyArr (_loc, t1, t2) : 'ctyp))];
Some "label", Some Gramext.NonA,
[[Gramext.Stoken ("OPTLABEL", ""); Gramext.Sself],
Gramext.action
(fun (t : 'ctyp) (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyOlb (loc, i, t) : 'ctyp));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyOlb (_loc, i, t) : 'ctyp));
[Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":");
Gramext.Sself],
Gramext.action
(fun (t : 'ctyp) _ (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyOlb (loc, i, t) : 'ctyp));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyOlb (_loc, i, t) : 'ctyp));
[Gramext.Stoken ("LABEL", ""); Gramext.Sself],
Gramext.action
(fun (t : 'ctyp) (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyLab (loc, i, t) : 'ctyp));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyLab (_loc, i, t) : 'ctyp));
[Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":");
Gramext.Sself],
Gramext.action
(fun (t : 'ctyp) _ (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyLab (loc, i, t) : 'ctyp))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyLab (_loc, i, t) : 'ctyp))];
None, Some Gramext.LeftA,
[[Gramext.Sself; Gramext.Sself],
Gramext.action
(fun (t2 : 'ctyp) (t1 : 'ctyp)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyApp (loc, t1, t2) : 'ctyp))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyApp (_loc, t1, t2) : 'ctyp))];
None, Some Gramext.LeftA,
[[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (t2 : 'ctyp) _ (t1 : 'ctyp)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyAcc (loc, t1, t2) : 'ctyp))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyAcc (_loc, t1, t2) : 'ctyp))];
Some "simple", None,
[[Gramext.Stoken ("", "{");
Gramext.Slist1sep
Gramext.Stoken ("", "}")],
Gramext.action
(fun _ (ldl : 'label_declaration list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyRec (loc, false, ldl) : 'ctyp));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyRec (_loc, ldl) : 'ctyp));
[Gramext.Stoken ("", "[");
Gramext.Slist0sep
(Gramext.Snterm
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (cdl : 'constructor_declaration list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TySum (loc, false, cdl) : 'ctyp));
- [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "{");
- Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (label_declaration : 'label_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", ";"));
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (ldl : 'label_declaration list) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyRec (loc, true, ldl) : 'ctyp));
- [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "[");
- Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (constructor_declaration :
- 'constructor_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "|"));
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (cdl : 'constructor_declaration list) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TySum (loc, true, cdl) : 'ctyp));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TySum (_loc, cdl) : 'ctyp));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (t : 'ctyp) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (t : 'ctyp) _ (_loc : Lexing.position * Lexing.position) ->
(t : 'ctyp));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "*");
Gramext.Slist1sep
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (tl : 'ctyp list) _ (t : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyTup (loc, (t :: tl)) : 'ctyp));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyTup (_loc, (t :: tl)) : 'ctyp));
[Gramext.Stoken ("UIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.TyUid (loc, i) : 'ctyp));
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyUid (_loc, i) : 'ctyp));
[Gramext.Stoken ("LIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.TyLid (loc, i) : 'ctyp));
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyLid (_loc, i) : 'ctyp));
[Gramext.Stoken ("", "_")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
- (MLast.TyAny loc : 'ctyp));
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyAny _loc : 'ctyp));
[Gramext.Stoken ("", "'");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.TyQuo (loc, i) : 'ctyp))]];
+ (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyQuo (_loc, i) : 'ctyp))]];
Grammar.Entry.obj
(constructor_declaration : 'constructor_declaration Grammar.Entry.e),
None,
[None, None,
[[Gramext.Stoken ("UIDENT", "")],
Gramext.action
- (fun (ci : string) (loc : Lexing.position * Lexing.position) ->
- (loc, ci, [] : 'constructor_declaration));
+ (fun (ci : string) (_loc : Lexing.position * Lexing.position) ->
+ (_loc, ci, [] : 'constructor_declaration));
[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "of");
Gramext.Slist1sep
(Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)),
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (cal : 'ctyp list) _ (ci : string)
- (loc : Lexing.position * Lexing.position) ->
- (loc, ci, cal : 'constructor_declaration))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (_loc, ci, cal : 'constructor_declaration))]];
Grammar.Entry.obj
(label_declaration : 'label_declaration Grammar.Entry.e),
None,
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) (mf : string option) _ (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (loc, i, o2b mf, t : 'label_declaration))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (_loc, i, o2b mf, t : 'label_declaration))]];
Grammar.Entry.obj (ident : 'ident Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("UIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
(i : 'ident));
[Gramext.Stoken ("LIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
(i : 'ident))]];
Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e), None,
[None, Some Gramext.RightA,
Gramext.Sself],
Gramext.action
(fun (j : 'mod_ident) _ (i : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(i :: j : 'mod_ident));
[Gramext.Stoken ("LIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
([i] : 'mod_ident));
[Gramext.Stoken ("UIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
([i] : 'mod_ident))]];
Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None,
[None, None,
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (ctd : 'class_type_declaration list) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.StClt (loc, ctd) : 'str_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.StClt (_loc, ctd) : 'str_item));
[Gramext.Stoken ("", "class");
Gramext.Slist1sep
(Gramext.Snterm
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (cd : 'class_declaration list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.StCls (loc, cd) : 'str_item))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.StCls (_loc, cd) : 'str_item))]];
Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type");
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (ctd : 'class_type_declaration list) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.SgClt (loc, ctd) : 'sig_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.SgClt (_loc, ctd) : 'sig_item));
[Gramext.Stoken ("", "class");
Gramext.Slist1sep
(Gramext.Snterm
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (cd : 'class_description list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.SgCls (loc, cd) : 'sig_item))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.SgCls (_loc, cd) : 'sig_item))]];
Grammar.Entry.obj
(class_declaration : 'class_declaration Grammar.Entry.e),
None,
Gramext.action
(fun (cfb : 'class_fun_binding) (ctp : 'class_type_parameters)
(i : string) (vf : string option)
- (loc : Lexing.position * Lexing.position) ->
- ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
+ (_loc : Lexing.position * Lexing.position) ->
+ ({MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
MLast.ciNam = i; MLast.ciExp = cfb} :
'class_declaration))]];
Grammar.Entry.obj
Gramext.Sself],
Gramext.action
(fun (cfb : 'class_fun_binding) (p : 'ipatt)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CeFun (loc, p, cfb) : 'class_fun_binding));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CeFun (_loc, p, cfb) : 'class_fun_binding));
[Gramext.Stoken ("", ":");
Gramext.Snterm
(Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e));
(Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))],
Gramext.action
(fun (ce : 'class_expr) _ (ct : 'class_type) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CeTyc (loc, ce, ct) : 'class_fun_binding));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CeTyc (_loc, ce, ct) : 'class_fun_binding));
[Gramext.Stoken ("", "=");
Gramext.Snterm
(Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))],
Gramext.action
- (fun (ce : 'class_expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (ce : 'class_expr) _
+ (_loc : Lexing.position * Lexing.position) ->
(ce : 'class_fun_binding))]];
Grammar.Entry.obj
(class_type_parameters : 'class_type_parameters Grammar.Entry.e),
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (tpl : 'type_parameter list) _
- (loc : Lexing.position * Lexing.position) ->
- (loc, tpl : 'class_type_parameters));
+ (_loc : Lexing.position * Lexing.position) ->
+ (_loc, tpl : 'class_type_parameters));
[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
- (loc, [] : 'class_type_parameters))]];
+ (fun (_loc : Lexing.position * Lexing.position) ->
+ (_loc, [] : 'class_type_parameters))]];
Grammar.Entry.obj (class_fun_def : 'class_fun_def Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "->");
Gramext.Snterm
(Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))],
Gramext.action
- (fun (ce : 'class_expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (ce : 'class_expr) _
+ (_loc : Lexing.position * Lexing.position) ->
(ce : 'class_fun_def));
[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
Gramext.Sself],
Gramext.action
(fun (ce : 'class_fun_def) (p : 'ipatt)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CeFun (loc, p, ce) : 'class_fun_def))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CeFun (_loc, p, ce) : 'class_fun_def))]];
Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), None,
[Some "top", None,
[[Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec"));
Gramext.Stoken ("", "in"); Gramext.Sself],
Gramext.action
(fun (ce : 'class_expr) _ (lb : 'let_binding list)
- (rf : string option) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.CeLet (loc, o2b rf, lb, ce) : 'class_expr));
+ (rf : string option) _
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CeLet (_loc, o2b rf, lb, ce) : 'class_expr));
[Gramext.Stoken ("", "fun");
Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
Gramext.Snterm
(class_fun_def : 'class_fun_def Grammar.Entry.e))],
Gramext.action
(fun (ce : 'class_fun_def) (p : 'ipatt) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CeFun (loc, p, ce) : 'class_expr))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CeFun (_loc, p, ce) : 'class_expr))];
Some "apply", Some Gramext.NonA,
[[Gramext.Sself;
Gramext.Snterml
(Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), "label")],
Gramext.action
(fun (e : 'expr) (ce : 'class_expr)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CeApp (loc, ce, e) : 'class_expr))];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CeApp (_loc, ce, e) : 'class_expr))];
Some "simple", None,
[[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (ce : 'class_expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(ce : 'class_expr));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
Gramext.Snterm
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (ct : 'class_type) _ (ce : 'class_expr) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CeTyc (loc, ce, ct) : 'class_expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CeTyc (_loc, ce, ct) : 'class_expr));
[Gramext.Stoken ("", "object");
Gramext.Sopt
(Gramext.Snterm
Gramext.Stoken ("", "end")],
Gramext.action
(fun _ (cf : 'class_structure) (cspo : 'class_self_patt option) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CeStr (loc, cspo, cf) : 'class_expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CeStr (_loc, cspo, cf) : 'class_expr));
[Gramext.Snterm
(Grammar.Entry.obj
(class_longident : 'class_longident Grammar.Entry.e))],
Gramext.action
(fun (ci : 'class_longident)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CeCon (loc, ci, []) : 'class_expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CeCon (_loc, ci, []) : 'class_expr));
[Gramext.Snterm
(Grammar.Entry.obj
(class_longident : 'class_longident Grammar.Entry.e));
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (ctcl : 'ctyp list) _ (ci : 'class_longident)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CeCon (loc, ci, ctcl) : 'class_expr))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CeCon (_loc, ci, ctcl) : 'class_expr))]];
Grammar.Entry.obj (class_structure : 'class_structure Grammar.Entry.e),
None,
[None, None,
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (cf : 'class_str_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(cf : 'e__6))])],
Gramext.action
- (fun (cf : 'e__6 list) (loc : Lexing.position * Lexing.position) ->
+ (fun (cf : 'e__6 list) (_loc : Lexing.position * Lexing.position) ->
(cf : 'class_structure))]];
Grammar.Entry.obj (class_self_patt : 'class_self_patt Grammar.Entry.e),
None,
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (t : 'ctyp) _ (p : 'patt) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaTyc (loc, p, t) : 'class_self_patt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaTyc (_loc, p, t) : 'class_self_patt));
[Gramext.Stoken ("", "(");
Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (p : 'patt) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (p : 'patt) _ (_loc : Lexing.position * Lexing.position) ->
(p : 'class_self_patt))]];
Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e),
None,
[[Gramext.Stoken ("", "initializer");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (se : 'expr) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.CrIni (loc, se) : 'class_str_item));
+ (fun (se : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CrIni (_loc, se) : 'class_str_item));
[Gramext.Stoken ("", "type");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", "=");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t2 : 'ctyp) _ (t1 : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CrCtr (loc, t1, t2) : 'class_str_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CrCtr (_loc, t1, t2) : 'class_str_item));
[Gramext.Stoken ("", "method");
Gramext.Sopt (Gramext.Stoken ("", "private"));
Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
(Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))],
Gramext.action
(fun (e : 'fun_binding) (topt : 'polyt option) (l : 'label)
- (pf : string option) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.CrMth (loc, l, o2b pf, e, topt) : 'class_str_item));
+ (pf : string option) _
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CrMth (_loc, l, o2b pf, e, topt) : 'class_str_item));
[Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual");
Gramext.Sopt (Gramext.Stoken ("", "private"));
Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CrVir (loc, l, o2b pf, t) : 'class_str_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CrVir (_loc, l, o2b pf, t) : 'class_str_item));
[Gramext.Stoken ("", "value");
Gramext.Sopt (Gramext.Stoken ("", "mutable"));
Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
(cvalue_binding : 'cvalue_binding Grammar.Entry.e))],
Gramext.action
(fun (e : 'cvalue_binding) (lab : 'label) (mf : string option) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CrVal (loc, lab, o2b mf, e) : 'class_str_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CrVal (_loc, lab, o2b mf, e) : 'class_str_item));
[Gramext.Stoken ("", "inherit");
Gramext.Snterm
(Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e));
(Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e)))],
Gramext.action
(fun (pb : 'as_lident option) (ce : 'class_expr) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CrInh (loc, ce, pb) : 'class_str_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CrInh (_loc, ce, pb) : 'class_str_item));
[Gramext.Stoken ("", "declare");
Gramext.Slist0
(Gramext.srules
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (s : 'class_str_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(s : 'e__7))]);
Gramext.Stoken ("", "end")],
Gramext.action
(fun _ (st : 'e__7 list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CrDcl (loc, st) : 'class_str_item))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CrDcl (_loc, st) : 'class_str_item))]];
Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "as"); Gramext.Stoken ("LIDENT", "")],
Gramext.action
- (fun (i : string) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : string) _ (_loc : Lexing.position * Lexing.position) ->
(i : 'as_lident))]];
Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
- (fun (t : 'ctyp) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (t : 'ctyp) _ (_loc : Lexing.position * Lexing.position) ->
(t : 'polyt))]];
Grammar.Entry.obj (cvalue_binding : 'cvalue_binding Grammar.Entry.e),
None,
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
(fun (e : 'expr) _ (t : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExCoe (loc, e, None, t) : 'cvalue_binding));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExCoe (_loc, e, None, t) : 'cvalue_binding));
[Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", ":>");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
(fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExCoe (loc, e, Some t, t2) : 'cvalue_binding));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExCoe (_loc, e, Some t, t2) : 'cvalue_binding));
[Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", "=");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
(fun (e : 'expr) _ (t : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExTyc (loc, e, t) : 'cvalue_binding));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExTyc (_loc, e, t) : 'cvalue_binding));
[Gramext.Stoken ("", "=");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(e : 'cvalue_binding))]];
Grammar.Entry.obj (label : 'label Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("LIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
(i : 'label))]];
Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None,
[None, None,
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (csf : 'class_sig_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(csf : 'e__8))]);
Gramext.Stoken ("", "end")],
Gramext.action
(fun _ (csf : 'e__8 list) (cst : 'class_self_type option) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CtSig (loc, cst, csf) : 'class_type));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CtSig (_loc, cst, csf) : 'class_type));
[Gramext.Snterm
(Grammar.Entry.obj
(clty_longident : 'clty_longident Grammar.Entry.e))],
Gramext.action
(fun (id : 'clty_longident)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CtCon (loc, id, []) : 'class_type));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CtCon (_loc, id, []) : 'class_type));
[Gramext.Snterm
(Grammar.Entry.obj
(clty_longident : 'clty_longident Grammar.Entry.e));
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (tl : 'ctyp list) _ (id : 'clty_longident)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CtCon (loc, id, tl) : 'class_type));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CtCon (_loc, id, tl) : 'class_type));
[Gramext.Stoken ("", "[");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", "]"); Gramext.Stoken ("", "->"); Gramext.Sself],
Gramext.action
(fun (ct : 'class_type) _ _ (t : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CtFun (loc, t, ct) : 'class_type))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CtFun (_loc, t, ct) : 'class_type))]];
Grammar.Entry.obj (class_self_type : 'class_self_type Grammar.Entry.e),
None,
[None, None,
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (t : 'ctyp) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (t : 'ctyp) _ (_loc : Lexing.position * Lexing.position) ->
(t : 'class_self_type))]];
Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e),
None,
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t2 : 'ctyp) _ (t1 : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CgCtr (loc, t1, t2) : 'class_sig_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CgCtr (_loc, t1, t2) : 'class_sig_item));
[Gramext.Stoken ("", "method");
Gramext.Sopt (Gramext.Stoken ("", "private"));
Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (l : 'label) (pf : string option) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CgMth (loc, l, o2b pf, t) : 'class_sig_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CgMth (_loc, l, o2b pf, t) : 'class_sig_item));
[Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual");
Gramext.Sopt (Gramext.Stoken ("", "private"));
Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CgVir (loc, l, o2b pf, t) : 'class_sig_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CgVir (_loc, l, o2b pf, t) : 'class_sig_item));
[Gramext.Stoken ("", "value");
Gramext.Sopt (Gramext.Stoken ("", "mutable"));
Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (l : 'label) (mf : string option) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CgVal (loc, l, o2b mf, t) : 'class_sig_item));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CgVal (_loc, l, o2b mf, t) : 'class_sig_item));
[Gramext.Stoken ("", "inherit");
Gramext.Snterm
(Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
Gramext.action
- (fun (cs : 'class_type) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.CgInh (loc, cs) : 'class_sig_item));
+ (fun (cs : 'class_type) _
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CgInh (_loc, cs) : 'class_sig_item));
[Gramext.Stoken ("", "declare");
Gramext.Slist0
(Gramext.srules
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (s : 'class_sig_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(s : 'e__9))]);
Gramext.Stoken ("", "end")],
Gramext.action
(fun _ (st : 'e__9 list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.CgDcl (loc, st) : 'class_sig_item))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.CgDcl (_loc, st) : 'class_sig_item))]];
Grammar.Entry.obj
(class_description : 'class_description Grammar.Entry.e),
None,
(Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
Gramext.action
(fun (ct : 'class_type) _ (ctp : 'class_type_parameters) (n : string)
- (vf : string option) (loc : Lexing.position * Lexing.position) ->
- ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
+ (vf : string option) (_loc : Lexing.position * Lexing.position) ->
+ ({MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
MLast.ciNam = n; MLast.ciExp = ct} :
'class_description))]];
Grammar.Entry.obj
(Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
Gramext.action
(fun (cs : 'class_type) _ (ctp : 'class_type_parameters) (n : string)
- (vf : string option) (loc : Lexing.position * Lexing.position) ->
- ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
+ (vf : string option) (_loc : Lexing.position * Lexing.position) ->
+ ({MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp;
MLast.ciNam = n; MLast.ciExp = cs} :
'class_type_declaration))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
(class_longident : 'class_longident Grammar.Entry.e))],
Gramext.action
(fun (i : 'class_longident) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExNew (loc, i) : 'expr))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExNew (_loc, i) : 'expr))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
Some (Gramext.Level "."),
[None, None,
Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e))],
Gramext.action
(fun (lab : 'label) _ (e : 'expr)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExSnd (loc, e, lab) : 'expr))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExSnd (_loc, e, lab) : 'expr))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
Some (Gramext.Level "simple"),
[None, None,
Gramext.Stoken ("", ">}")],
Gramext.action
(fun _ (fel : 'field_expr list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExOvr (loc, fel) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExOvr (_loc, fel) : 'expr));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":>");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (t : 'ctyp) _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExCoe (loc, e, None, t) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExCoe (_loc, e, None, t) : 'expr));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", ":>");
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExCoe (loc, e, Some t, t2) : 'expr))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExCoe (_loc, e, Some t, t2) : 'expr))]];
Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
(fun (e : 'expr) _ (l : 'label)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(l, e : 'field_expr))]];
Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e),
Some (Gramext.Level "simple"),
[None, None,
[[Gramext.Stoken ("", "<"); Gramext.Stoken ("", ">")],
Gramext.action
- (fun _ _ (loc : Lexing.position * Lexing.position) ->
- (MLast.TyObj (loc, [], false) : 'ctyp));
+ (fun _ _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyObj (_loc, [], false) : 'ctyp));
[Gramext.Stoken ("", "<");
Gramext.Snterm
(Grammar.Entry.obj (meth_list : 'meth_list Grammar.Entry.e));
Gramext.Stoken ("", ">")],
Gramext.action
(fun _ (ml, v : 'meth_list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyObj (loc, ml, v) : 'ctyp));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyObj (_loc, ml, v) : 'ctyp));
[Gramext.Stoken ("", "#");
Gramext.Snterm
(Grammar.Entry.obj
(class_longident : 'class_longident Grammar.Entry.e))],
Gramext.action
(fun (id : 'class_longident) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyCls (loc, id) : 'ctyp))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyCls (_loc, id) : 'ctyp))]];
Grammar.Entry.obj (meth_list : 'meth_list Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "..")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
([], true : 'meth_list));
[Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e))],
Gramext.action
- (fun (f : 'field) (loc : Lexing.position * Lexing.position) ->
+ (fun (f : 'field) (_loc : Lexing.position * Lexing.position) ->
([f], false : 'meth_list));
[Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e));
Gramext.Stoken ("", ";")],
Gramext.action
- (fun _ (f : 'field) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (f : 'field) (_loc : Lexing.position * Lexing.position) ->
([f], false : 'meth_list));
[Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e));
Gramext.Stoken ("", ";"); Gramext.Sself],
Gramext.action
(fun (ml, v : 'meth_list) _ (f : 'field)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(f :: ml, v : 'meth_list))]];
Grammar.Entry.obj (field : 'field Grammar.Entry.e), None,
[None, None,
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (lab : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(lab, t : 'field))]];
Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "'");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) ->
(i : 'typevar))]];
Grammar.Entry.obj (clty_longident : 'clty_longident Grammar.Entry.e),
None,
[None, None,
[[Gramext.Stoken ("LIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
([i] : 'clty_longident));
[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ".");
Gramext.Sself],
Gramext.action
(fun (l : 'clty_longident) _ (m : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(m :: l : 'clty_longident))]];
Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e),
None,
[None, None,
[[Gramext.Stoken ("LIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
([i] : 'class_longident));
[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ".");
Gramext.Sself],
Gramext.action
(fun (l : 'class_longident) _ (m : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(m :: l : 'class_longident))]];
Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e),
Some (Gramext.Level "simple"),
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (ntl : 'name_tag list) _ (rfl : 'row_field_list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyVrn (loc, rfl, Some (Some ntl)) : 'ctyp));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyVrn (_loc, rfl, Some (Some ntl)) : 'ctyp));
[Gramext.Stoken ("", "[<");
Gramext.Snterm
(Grammar.Entry.obj
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (rfl : 'row_field_list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyVrn (loc, rfl, Some (Some [])) : 'ctyp));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyVrn (_loc, rfl, Some (Some [])) : 'ctyp));
[Gramext.Stoken ("", "["); Gramext.Stoken ("", "<");
Gramext.Snterm
(Grammar.Entry.obj
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (ntl : 'name_tag list) _ (rfl : 'row_field_list) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyVrn (loc, rfl, Some (Some ntl)) : 'ctyp));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyVrn (_loc, rfl, Some (Some ntl)) : 'ctyp));
[Gramext.Stoken ("", "["); Gramext.Stoken ("", "<");
Gramext.Snterm
(Grammar.Entry.obj
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (rfl : 'row_field_list) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyVrn (loc, rfl, Some (Some [])) : 'ctyp));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyVrn (_loc, rfl, Some (Some [])) : 'ctyp));
[Gramext.Stoken ("", "["); Gramext.Stoken ("", ">");
Gramext.Snterm
(Grammar.Entry.obj
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (rfl : 'row_field_list) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyVrn (loc, rfl, Some None) : 'ctyp));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyVrn (_loc, rfl, Some None) : 'ctyp));
[Gramext.Stoken ("", "["); Gramext.Stoken ("", "=");
Gramext.Snterm
(Grammar.Entry.obj
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (rfl : 'row_field_list) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyVrn (loc, rfl, None) : 'ctyp))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyVrn (_loc, rfl, None) : 'ctyp))]];
Grammar.Entry.obj (row_field_list : 'row_field_list Grammar.Entry.e),
None,
[None, None,
Gramext.Stoken ("", "|"))],
Gramext.action
(fun (rfl : 'row_field list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(rfl : 'row_field_list))]];
Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
- (fun (t : 'ctyp) (loc : Lexing.position * Lexing.position) ->
+ (fun (t : 'ctyp) (_loc : Lexing.position * Lexing.position) ->
(MLast.RfInh t : 'row_field));
[Gramext.Stoken ("", "`");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e));
Gramext.Stoken ("", "&"))],
Gramext.action
(fun (l : 'ctyp list) (ao : string option) _ (i : 'ident) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(MLast.RfTag (i, o2b ao, l) : 'row_field));
[Gramext.Stoken ("", "`");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) ->
(MLast.RfTag (i, true, []) : 'row_field))]];
Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "`");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) ->
(i : 'name_tag))]];
Grammar.Entry.obj (patt : 'patt Grammar.Entry.e),
Some (Gramext.Level "simple"),
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaOlb (loc, "", Some (p, eo)) : 'patt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaOlb (_loc, "", Some (p, eo)) : 'patt));
[Gramext.Stoken ("QUESTIONIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaOlb (loc, i, None) : 'patt));
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaOlb (_loc, i, None) : 'patt));
[Gramext.Stoken ("OPTLABEL", ""); Gramext.Stoken ("", "(");
Gramext.Snterm
(Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaOlb (loc, i, Some (p, eo)) : 'patt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaOlb (_loc, i, Some (p, eo)) : 'patt));
[Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":");
Gramext.Stoken ("", "(");
Gramext.Snterm
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ _ (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaOlb (loc, i, Some (p, eo)) : 'patt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaOlb (_loc, i, Some (p, eo)) : 'patt));
[Gramext.Stoken ("TILDEIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaLab (loc, i, None) : 'patt));
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaLab (_loc, i, None) : 'patt));
[Gramext.Stoken ("LABEL", ""); Gramext.Sself],
Gramext.action
(fun (p : 'patt) (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaLab (loc, i, Some p) : 'patt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaLab (_loc, i, Some p) : 'patt));
[Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":");
Gramext.Sself],
Gramext.action
(fun (p : 'patt) _ (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaLab (loc, i, Some p) : 'patt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaLab (_loc, i, Some p) : 'patt));
[Gramext.Stoken ("", "#");
Gramext.Snterm
(Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))],
Gramext.action
- (fun (sl : 'mod_ident) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.PaTyp (loc, sl) : 'patt));
+ (fun (sl : 'mod_ident) _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaTyp (_loc, sl) : 'patt));
[Gramext.Stoken ("", "`");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (s : 'ident) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.PaVrn (loc, s) : 'patt))]];
+ (fun (s : 'ident) _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaVrn (_loc, s) : 'patt))]];
Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
Gramext.action
- (fun (p : 'patt) (loc : Lexing.position * Lexing.position) ->
+ (fun (p : 'patt) (_loc : Lexing.position * Lexing.position) ->
(p : 'patt_tcon));
[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (p : 'patt)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaTyc (loc, p, t) : 'patt_tcon))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaTyc (_loc, p, t) : 'patt_tcon))]];
Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "(");
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaOlb (loc, "", Some (p, eo)) : 'ipatt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaOlb (_loc, "", Some (p, eo)) : 'ipatt));
[Gramext.Stoken ("QUESTIONIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaOlb (loc, i, None) : 'ipatt));
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaOlb (_loc, i, None) : 'ipatt));
[Gramext.Stoken ("OPTLABEL", ""); Gramext.Stoken ("", "(");
Gramext.Snterm
(Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaOlb (loc, i, Some (p, eo)) : 'ipatt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaOlb (_loc, i, Some (p, eo)) : 'ipatt));
[Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":");
Gramext.Stoken ("", "(");
Gramext.Snterm
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ _ (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaOlb (loc, i, Some (p, eo)) : 'ipatt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaOlb (_loc, i, Some (p, eo)) : 'ipatt));
[Gramext.Stoken ("TILDEIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaLab (loc, i, None) : 'ipatt));
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaLab (_loc, i, None) : 'ipatt));
[Gramext.Stoken ("LABEL", ""); Gramext.Sself],
Gramext.action
(fun (p : 'ipatt) (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaLab (loc, i, Some p) : 'ipatt));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaLab (_loc, i, Some p) : 'ipatt));
[Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":");
Gramext.Sself],
Gramext.action
(fun (p : 'ipatt) _ (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaLab (loc, i, Some p) : 'ipatt))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaLab (_loc, i, Some p) : 'ipatt))]];
Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))],
Gramext.action
- (fun (p : 'ipatt) (loc : Lexing.position * Lexing.position) ->
+ (fun (p : 'ipatt) (_loc : Lexing.position * Lexing.position) ->
(p : 'ipatt_tcon));
[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (p : 'ipatt)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.PaTyc (loc, p, t) : 'ipatt_tcon))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaTyc (_loc, p, t) : 'ipatt_tcon))]];
Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "=");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(e : 'eq_expr))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
Some (Gramext.After "apply"),
[Some "label", Some Gramext.NonA,
[[Gramext.Stoken ("QUESTIONIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.ExOlb (loc, i, None) : 'expr));
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExOlb (_loc, i, None) : 'expr));
[Gramext.Stoken ("OPTLABEL", ""); Gramext.Sself],
Gramext.action
(fun (e : 'expr) (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExOlb (loc, i, Some e) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExOlb (_loc, i, Some e) : 'expr));
[Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":");
Gramext.Sself],
Gramext.action
(fun (e : 'expr) _ (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExOlb (loc, i, Some e) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExOlb (_loc, i, Some e) : 'expr));
[Gramext.Stoken ("TILDEIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.ExLab (loc, i, None) : 'expr));
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExLab (_loc, i, None) : 'expr));
[Gramext.Stoken ("LABEL", ""); Gramext.Sself],
Gramext.action
(fun (e : 'expr) (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExLab (loc, i, Some e) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExLab (_loc, i, Some e) : 'expr));
[Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":");
Gramext.Sself],
Gramext.action
(fun (e : 'expr) _ (i : string)
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExLab (loc, i, Some e) : 'expr))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExLab (_loc, i, Some e) : 'expr))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
Some (Gramext.Level "simple"),
[None, None,
[[Gramext.Stoken ("", "`");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (s : 'ident) _ (loc : Lexing.position * Lexing.position) ->
- (MLast.ExVrn (loc, s) : 'expr))]];
+ (fun (s : 'ident) _ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExVrn (_loc, s) : 'expr))]];
Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e),
None,
[None, None,
[[Gramext.Stoken ("", "downto")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
(false : 'direction_flag));
[Gramext.Stoken ("", "to")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
(true : 'direction_flag))]];
Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e),
Some (Gramext.Level "simple"),
Gramext.Stoken ("", "|]")],
Gramext.action
(fun _ (ntl : 'name_tag list) _ (rfl : 'row_field_list) _ _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyVrn (loc, rfl, Some (Some ntl)) : 'ctyp));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyVrn (_loc, rfl, Some (Some ntl)) : 'ctyp));
[Gramext.Stoken ("", "[|");
Gramext.Snterm
(Grammar.Entry.obj
Gramext.Stoken ("", "|]")],
Gramext.action
(fun _ (rfl : 'row_field_list) _ _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyVrn (loc, rfl, Some (Some [])) : 'ctyp));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyVrn (_loc, rfl, Some (Some [])) : 'ctyp));
[Gramext.Stoken ("", "[|");
Gramext.Snterm
(Grammar.Entry.obj
Gramext.Stoken ("", "|]")],
Gramext.action
(fun _ (rfl : 'row_field_list) _ _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyVrn (loc, rfl, Some None) : 'ctyp));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyVrn (_loc, rfl, Some None) : 'ctyp));
[Gramext.Stoken ("", "[|");
Gramext.Snterm
(Grammar.Entry.obj
Gramext.Stoken ("", "|]")],
Gramext.action
(fun _ (rfl : 'row_field_list) _ _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.TyVrn (loc, rfl, None) : 'ctyp))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.TyVrn (_loc, rfl, None) : 'ctyp))]];
Grammar.Entry.obj (warning_variant : 'warning_variant Grammar.Entry.e),
None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
- (warn_variant loc : 'warning_variant))]];
+ (fun (_loc : Lexing.position * Lexing.position) ->
+ (warn_variant _loc : 'warning_variant))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
Some (Gramext.Level "top"),
[None, None,
(Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
Gramext.Stoken ("", ";")],
Gramext.action
- (fun _ (e : 'expr) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (e : 'expr)
+ (_loc : Lexing.position * Lexing.position) ->
(e : 'e__12))]);
Gramext.Snterm
(Grammar.Entry.obj
Gramext.Stoken ("", "done")],
Gramext.action
(fun _ _ (seq : 'e__12 list) _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExWhi (loc, e, seq) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExWhi (_loc, e, seq) : 'expr));
[Gramext.Stoken ("", "for"); Gramext.Stoken ("LIDENT", "");
Gramext.Stoken ("", "="); Gramext.Sself;
Gramext.Snterm
(Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
Gramext.Stoken ("", ";")],
Gramext.action
- (fun _ (e : 'expr) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (e : 'expr)
+ (_loc : Lexing.position * Lexing.position) ->
(e : 'e__11))]);
Gramext.Snterm
(Grammar.Entry.obj
Gramext.action
(fun _ _ (seq : 'e__11 list) _ (e2 : 'expr) (df : 'direction_flag)
(e1 : 'expr) _ (i : string) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExFor (loc, i, e1, e2, df, seq) : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExFor (_loc, i, e1, e2, df, seq) : 'expr));
[Gramext.Stoken ("", "do");
Gramext.Slist0
(Gramext.srules
(Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
Gramext.Stoken ("", ";")],
Gramext.action
- (fun _ (e : 'expr) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (e : 'expr)
+ (_loc : Lexing.position * Lexing.position) ->
(e : 'e__10))]);
Gramext.Stoken ("", "return");
Gramext.Snterm
Gramext.Sself],
Gramext.action
(fun (e : 'expr) _ _ (seq : 'e__10 list) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.ExSeq (loc, append_elem seq e) : 'expr))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.ExSeq (_loc, append_elem seq e) : 'expr))]];
Grammar.Entry.obj (warning_sequence : 'warning_sequence Grammar.Entry.e),
None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
- (warn_sequence loc : 'warning_sequence))]]]);;
+ (fun (_loc : Lexing.position * Lexing.position) ->
+ (warn_sequence _loc : 'warning_sequence))]]]);;
Grammar.extend
(let _ = (interf : 'interf Grammar.Entry.e)
[None, None,
[[Gramext.Stoken ("EOI", "")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
([], false : 'interf));
[Gramext.Snterm
(Grammar.Entry.obj (sig_item_semi : 'sig_item_semi Grammar.Entry.e));
Gramext.Sself],
Gramext.action
(fun (sil, stopped : 'interf) (si : 'sig_item_semi)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(si :: sil, stopped : 'interf));
[Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", "");
Gramext.Sopt
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (dp : 'expr option) (n : string) _
- (loc : Lexing.position * Lexing.position) ->
- ([MLast.SgDir (loc, n, dp), loc], true : 'interf))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ ([MLast.SgDir (_loc, n, dp), _loc], true : 'interf))]];
Grammar.Entry.obj (sig_item_semi : 'sig_item_semi Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm
(Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e));
Gramext.Stoken ("", ";")],
Gramext.action
- (fun _ (si : 'sig_item) (loc : Lexing.position * Lexing.position) ->
- (si, loc : 'sig_item_semi))]];
+ (fun _ (si : 'sig_item) (_loc : Lexing.position * Lexing.position) ->
+ (si, _loc : 'sig_item_semi))]];
Grammar.Entry.obj (implem : 'implem Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("EOI", "")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
([], false : 'implem));
[Gramext.Snterm
(Grammar.Entry.obj (str_item_semi : 'str_item_semi Grammar.Entry.e));
Gramext.Sself],
Gramext.action
(fun (sil, stopped : 'implem) (si : 'str_item_semi)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(si :: sil, stopped : 'implem));
[Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", "");
Gramext.Sopt
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (dp : 'expr option) (n : string) _
- (loc : Lexing.position * Lexing.position) ->
- ([MLast.StDir (loc, n, dp), loc], true : 'implem))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ ([MLast.StDir (_loc, n, dp), _loc], true : 'implem))]];
Grammar.Entry.obj (str_item_semi : 'str_item_semi Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm
(Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e));
Gramext.Stoken ("", ";")],
Gramext.action
- (fun _ (si : 'str_item) (loc : Lexing.position * Lexing.position) ->
- (si, loc : 'str_item_semi))]];
+ (fun _ (si : 'str_item) (_loc : Lexing.position * Lexing.position) ->
+ (si, _loc : 'str_item_semi))]];
Grammar.Entry.obj (top_phrase : 'top_phrase Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("EOI", "")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
(None : 'top_phrase));
[Gramext.Snterm (Grammar.Entry.obj (phrase : 'phrase Grammar.Entry.e))],
Gramext.action
- (fun (ph : 'phrase) (loc : Lexing.position * Lexing.position) ->
+ (fun (ph : 'phrase) (_loc : Lexing.position * Lexing.position) ->
(Some ph : 'top_phrase))]];
Grammar.Entry.obj (use_file : 'use_file Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("EOI", "")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
([], false : 'use_file));
[Gramext.Snterm
(Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e));
Gramext.Stoken ("", ";"); Gramext.Sself],
Gramext.action
(fun (sil, stopped : 'use_file) _ (si : 'str_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(si :: sil, stopped : 'use_file));
[Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", "");
Gramext.Sopt
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (dp : 'expr option) (n : string) _
- (loc : Lexing.position * Lexing.position) ->
- ([MLast.StDir (loc, n, dp)], true : 'use_file))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ ([MLast.StDir (_loc, n, dp)], true : 'use_file))]];
Grammar.Entry.obj (phrase : 'phrase Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm
(Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e));
Gramext.Stoken ("", ";")],
Gramext.action
- (fun _ (sti : 'str_item) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (sti : 'str_item) (_loc : Lexing.position * Lexing.position) ->
(sti : 'phrase));
[Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", "");
Gramext.Sopt
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (dp : 'expr option) (n : string) _
- (loc : Lexing.position * Lexing.position) ->
- (MLast.StDir (loc, n, dp) : 'phrase))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (MLast.StDir (_loc, n, dp) : 'phrase))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
Some (Gramext.Level "simple"),
[None, None,
[[Gramext.Stoken ("QUOTATION", "")],
Gramext.action
- (fun (x : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (x : string) (_loc : Lexing.position * Lexing.position) ->
(let x =
try
let i = String.index x ':' in
with
Not_found -> "", x
in
- Pcaml.handle_expr_quotation loc x :
+ Pcaml.handle_expr_quotation _loc x :
'expr));
[Gramext.Stoken ("LOCATE", "")],
Gramext.action
- (fun (x : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (x : string) (_loc : Lexing.position * Lexing.position) ->
(let x =
try
let i = String.index x ':' in
Not_found | Failure _ ->
{(Lexing.dummy_pos) with Lexing.pos_cnum = 0}, x
in
- Pcaml.handle_expr_locate loc x :
+ Pcaml.handle_expr_locate _loc x :
'expr))]];
Grammar.Entry.obj (patt : 'patt Grammar.Entry.e),
Some (Gramext.Level "simple"),
[None, None,
[[Gramext.Stoken ("QUOTATION", "")],
Gramext.action
- (fun (x : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (x : string) (_loc : Lexing.position * Lexing.position) ->
(let x =
try
let i = String.index x ':' in
with
Not_found -> "", x
in
- Pcaml.handle_patt_quotation loc x :
+ Pcaml.handle_patt_quotation _loc x :
'patt));
[Gramext.Stoken ("LOCATE", "")],
Gramext.action
- (fun (x : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (x : string) (_loc : Lexing.position * Lexing.position) ->
(let x =
try
let i = String.index x ':' in
Not_found | Failure _ ->
{(Lexing.dummy_pos) with Lexing.pos_cnum = 0}, x
in
- Pcaml.handle_patt_locate loc x :
+ Pcaml.handle_patt_locate _loc x :
'patt))]]]);;
;;
let strm_n = "strm__";;
-let peek_fun loc =
- MLast.ExAcc (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "peek"))
+let peek_fun _loc =
+ MLast.ExAcc (_loc, MLast.ExUid (_loc, "Stream"), MLast.ExLid (_loc, "peek"))
;;
-let junk_fun loc =
- MLast.ExAcc (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "junk"))
+let junk_fun _loc =
+ MLast.ExAcc (_loc, MLast.ExUid (_loc, "Stream"), MLast.ExLid (_loc, "junk"))
;;
(* Parsers. *)
;;
let rec subst v e =
- let loc = MLast.loc_of_expr e in
+ let _loc = MLast.loc_of_expr e in
match e with
MLast.ExLid (_, x) ->
- let x = if x = v then strm_n else x in MLast.ExLid (loc, x)
+ let x = if x = v then strm_n else x in MLast.ExLid (_loc, x)
| MLast.ExUid (_, _) -> e
| MLast.ExInt (_, _) -> e
| MLast.ExChr (_, _) -> e
| MLast.ExStr (_, _) -> e
| MLast.ExAcc (_, _, _) -> e
| MLast.ExLet (_, rf, pel, e) ->
- MLast.ExLet (loc, rf, List.map (subst_pe v) pel, subst v e)
- | MLast.ExApp (_, e1, e2) -> MLast.ExApp (loc, subst v e1, subst v e2)
- | MLast.ExTup (_, el) -> MLast.ExTup (loc, List.map (subst v) el)
+ MLast.ExLet (_loc, rf, List.map (subst_pe v) pel, subst v e)
+ | MLast.ExApp (_, e1, e2) -> MLast.ExApp (_loc, subst v e1, subst v e2)
+ | MLast.ExTup (_, el) -> MLast.ExTup (_loc, List.map (subst v) el)
| _ -> raise Not_found
and subst_pe v (p, e) =
match p with
let stream_pattern_component skont ckont =
function
- SpTrm (loc, p, wo) ->
+ SpTrm (_loc, p, wo) ->
MLast.ExMat
- (loc, MLast.ExApp (loc, peek_fun loc, MLast.ExLid (loc, strm_n)),
- [MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p), wo,
+ (_loc, MLast.ExApp (_loc, peek_fun _loc, MLast.ExLid (_loc, strm_n)),
+ [MLast.PaApp (_loc, MLast.PaUid (_loc, "Some"), p), wo,
MLast.ExSeq
- (loc,
- [MLast.ExApp (loc, junk_fun loc, MLast.ExLid (loc, strm_n));
+ (_loc,
+ [MLast.ExApp (_loc, junk_fun _loc, MLast.ExLid (_loc, strm_n));
skont]);
- MLast.PaAny loc, None, ckont])
- | SpNtr (loc, p, e) ->
+ MLast.PaAny _loc, None, ckont])
+ | SpNtr (_loc, p, e) ->
let e =
match e with
MLast.ExFun
MLast.TyAny _)), None, e])
when v = strm_n ->
e
- | _ -> MLast.ExApp (loc, e, MLast.ExLid (loc, strm_n))
+ | _ -> MLast.ExApp (_loc, e, MLast.ExLid (_loc, strm_n))
in
if pattern_eq_expression p skont then
if is_raise_failure ckont then e
else if handle_failure e then e
else
MLast.ExTry
- (loc, e,
+ (_loc, e,
[MLast.PaAcc
- (loc, MLast.PaUid (loc, "Stream"),
- MLast.PaUid (loc, "Failure")),
+ (_loc, MLast.PaUid (_loc, "Stream"),
+ MLast.PaUid (_loc, "Failure")),
None, ckont])
else if is_raise_failure ckont then
- MLast.ExLet (loc, false, [p, e], skont)
+ MLast.ExLet (_loc, false, [p, e], skont)
else if
pattern_eq_expression
- (MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p)) skont
+ (MLast.PaApp (_loc, MLast.PaUid (_loc, "Some"), p)) skont
then
MLast.ExTry
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "Some"), e),
+ (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "Some"), e),
[MLast.PaAcc
- (loc, MLast.PaUid (loc, "Stream"),
- MLast.PaUid (loc, "Failure")),
+ (_loc, MLast.PaUid (_loc, "Stream"),
+ MLast.PaUid (_loc, "Failure")),
None, ckont])
else if is_raise ckont then
let tst =
if handle_failure e then e
else
MLast.ExTry
- (loc, e,
+ (_loc, e,
[MLast.PaAcc
- (loc, MLast.PaUid (loc, "Stream"),
- MLast.PaUid (loc, "Failure")),
+ (_loc, MLast.PaUid (_loc, "Stream"),
+ MLast.PaUid (_loc, "Failure")),
None, ckont])
in
- MLast.ExLet (loc, false, [p, tst], skont)
+ MLast.ExLet (_loc, false, [p, tst], skont)
else
MLast.ExMat
- (loc,
+ (_loc,
MLast.ExTry
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "Some"), e),
+ (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "Some"), e),
[MLast.PaAcc
- (loc, MLast.PaUid (loc, "Stream"),
- MLast.PaUid (loc, "Failure")),
- None, MLast.ExUid (loc, "None")]),
- [MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p), None, skont;
- MLast.PaAny loc, None, ckont])
- | SpStr (loc, p) ->
+ (_loc, MLast.PaUid (_loc, "Stream"),
+ MLast.PaUid (_loc, "Failure")),
+ None, MLast.ExUid (_loc, "None")]),
+ [MLast.PaApp (_loc, MLast.PaUid (_loc, "Some"), p), None, skont;
+ MLast.PaAny _loc, None, ckont])
+ | SpStr (_loc, p) ->
try
match p with
MLast.PaLid (_, v) -> subst v skont
| _ -> raise Not_found
with
Not_found ->
- MLast.ExLet (loc, false, [p, MLast.ExLid (loc, strm_n)], skont)
+ MLast.ExLet (_loc, false, [p, MLast.ExLid (_loc, strm_n)], skont)
;;
-let rec stream_pattern loc epo e ekont =
+let rec stream_pattern _loc epo e ekont =
function
[] ->
begin match epo with
Some ep ->
MLast.ExLet
- (loc, false,
+ (_loc, false,
[ep,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"),
- MLast.ExLid (loc, "count")),
- MLast.ExLid (loc, strm_n))],
+ (_loc, MLast.ExUid (_loc, "Stream"),
+ MLast.ExLid (_loc, "count")),
+ MLast.ExLid (_loc, strm_n))],
e)
| _ -> e
end
let str =
match err with
Some estr -> estr
- | _ -> MLast.ExStr (loc, "")
+ | _ -> MLast.ExStr (_loc, "")
in
MLast.ExApp
- (loc, MLast.ExLid (loc, "raise"),
+ (_loc, MLast.ExLid (_loc, "raise"),
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"),
- MLast.ExUid (loc, "Error")),
+ (_loc, MLast.ExUid (_loc, "Stream"),
+ MLast.ExUid (_loc, "Error")),
str))
in
- stream_pattern loc epo e ekont spcl
+ stream_pattern _loc epo e ekont spcl
in
let ckont = ekont err in stream_pattern_component skont ckont spc
;;
-let stream_patterns_term loc ekont tspel =
+let stream_patterns_term _loc ekont tspel =
let pel =
List.map
- (fun (p, w, loc, spcl, epo, e) ->
- let p = MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p) in
+ (fun (p, w, _loc, spcl, epo, e) ->
+ let p = MLast.PaApp (_loc, MLast.PaUid (_loc, "Some"), p) in
let e =
let ekont err =
let str =
match err with
Some estr -> estr
- | _ -> MLast.ExStr (loc, "")
+ | _ -> MLast.ExStr (_loc, "")
in
MLast.ExApp
- (loc, MLast.ExLid (loc, "raise"),
+ (_loc, MLast.ExLid (_loc, "raise"),
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"),
- MLast.ExUid (loc, "Error")),
+ (_loc, MLast.ExUid (_loc, "Stream"),
+ MLast.ExUid (_loc, "Error")),
str))
in
- let skont = stream_pattern loc epo e ekont spcl in
+ let skont = stream_pattern _loc epo e ekont spcl in
MLast.ExSeq
- (loc,
- [MLast.ExApp (loc, junk_fun loc, MLast.ExLid (loc, strm_n));
+ (_loc,
+ [MLast.ExApp (_loc, junk_fun _loc, MLast.ExLid (_loc, strm_n));
skont])
in
p, w, e)
tspel
in
- let pel = pel @ [MLast.PaAny loc, None, ekont ()] in
+ let pel = pel @ [MLast.PaAny _loc, None, ekont ()] in
MLast.ExMat
- (loc, MLast.ExApp (loc, peek_fun loc, MLast.ExLid (loc, strm_n)), pel)
+ (_loc, MLast.ExApp (_loc, peek_fun _loc, MLast.ExLid (_loc, strm_n)), pel)
;;
let rec group_terms =
function
- ((SpTrm (loc, p, w), None) :: spcl, epo, e) :: spel ->
+ ((SpTrm (_loc, p, w), None) :: spcl, epo, e) :: spel ->
let (tspel, spel) = group_terms spel in
- (p, w, loc, spcl, epo, e) :: tspel, spel
+ (p, w, _loc, spcl, epo, e) :: tspel, spel
| spel -> [], spel
;;
-let rec parser_cases loc =
+let rec parser_cases _loc =
function
[] ->
MLast.ExApp
- (loc, MLast.ExLid (loc, "raise"),
+ (_loc, MLast.ExLid (_loc, "raise"),
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"), MLast.ExUid (loc, "Failure")))
+ (_loc, MLast.ExUid (_loc, "Stream"),
+ MLast.ExUid (_loc, "Failure")))
| spel ->
match group_terms spel with
[], (spcl, epo, e) :: spel ->
- stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl
+ stream_pattern _loc epo e (fun _ -> parser_cases _loc spel) spcl
| tspel, spel ->
- stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel
+ stream_patterns_term _loc (fun _ -> parser_cases _loc spel) tspel
;;
-let cparser loc bpo pc =
- let e = parser_cases loc pc in
+let cparser _loc bpo pc =
+ let e = parser_cases _loc pc in
let e =
match bpo with
Some bp ->
MLast.ExLet
- (loc, false,
+ (_loc, false,
[bp,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"),
- MLast.ExLid (loc, "count")),
- MLast.ExLid (loc, strm_n))],
+ (_loc, MLast.ExUid (_loc, "Stream"),
+ MLast.ExLid (_loc, "count")),
+ MLast.ExLid (_loc, strm_n))],
e)
| None -> e
in
let p =
MLast.PaTyc
- (loc, MLast.PaLid (loc, strm_n),
+ (_loc, MLast.PaLid (_loc, strm_n),
MLast.TyApp
- (loc,
+ (_loc,
MLast.TyAcc
- (loc, MLast.TyUid (loc, "Stream"), MLast.TyLid (loc, "t")),
- MLast.TyAny loc))
+ (_loc, MLast.TyUid (_loc, "Stream"), MLast.TyLid (_loc, "t")),
+ MLast.TyAny _loc))
in
- MLast.ExFun (loc, [p, None, e])
+ MLast.ExFun (_loc, [p, None, e])
;;
-let cparser_match loc me bpo pc =
- let pc = parser_cases loc pc in
+let cparser_match _loc me bpo pc =
+ let pc = parser_cases _loc pc in
let e =
match bpo with
Some bp ->
MLast.ExLet
- (loc, false,
+ (_loc, false,
[bp,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"),
- MLast.ExLid (loc, "count")),
- MLast.ExLid (loc, strm_n))],
+ (_loc, MLast.ExUid (_loc, "Stream"),
+ MLast.ExLid (_loc, "count")),
+ MLast.ExLid (_loc, strm_n))],
pc)
| None -> pc
in
MLast.ExLid (_, x) when x = strm_n -> e
| _ ->
MLast.ExLet
- (loc, false,
+ (_loc, false,
[MLast.PaTyc
- (loc, MLast.PaLid (loc, strm_n),
+ (_loc, MLast.PaLid (_loc, strm_n),
MLast.TyApp
- (loc,
+ (_loc,
MLast.TyAcc
- (loc, MLast.TyUid (loc, "Stream"), MLast.TyLid (loc, "t")),
- MLast.TyAny loc)),
+ (_loc, MLast.TyUid (_loc, "Stream"),
+ MLast.TyLid (_loc, "t")),
+ MLast.TyAny _loc)),
me],
e)
;;
| _ -> false
;;
-let slazy loc e =
+let slazy _loc e =
match e with
MLast.ExApp (_, f, MLast.ExUid (_, "()")) ->
begin match f with
MLast.ExLid (_, _) -> f
- | _ -> MLast.ExFun (loc, [MLast.PaAny loc, None, e])
+ | _ -> MLast.ExFun (_loc, [MLast.PaAny _loc, None, e])
end
- | _ -> MLast.ExFun (loc, [MLast.PaAny loc, None, e])
+ | _ -> MLast.ExFun (_loc, [MLast.PaAny _loc, None, e])
;;
let rec cstream gloc =
function
[] ->
- let loc = gloc in
+ let _loc = gloc in
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "sempty"))
- | [SeTrm (loc, e)] ->
+ (_loc, MLast.ExUid (_loc, "Stream"), MLast.ExLid (_loc, "sempty"))
+ | [SeTrm (_loc, e)] ->
if not_computing e then
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "ising")),
+ (_loc, MLast.ExUid (_loc, "Stream"),
+ MLast.ExLid (_loc, "ising")),
e)
else
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "lsing")),
- slazy loc e)
- | SeTrm (loc, e) :: secl ->
+ (_loc, MLast.ExUid (_loc, "Stream"),
+ MLast.ExLid (_loc, "lsing")),
+ slazy _loc e)
+ | SeTrm (_loc, e) :: secl ->
if not_computing e then
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"),
- MLast.ExLid (loc, "icons")),
+ (_loc, MLast.ExUid (_loc, "Stream"),
+ MLast.ExLid (_loc, "icons")),
e),
cstream gloc secl)
else
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"),
- MLast.ExLid (loc, "lcons")),
- slazy loc e),
+ (_loc, MLast.ExUid (_loc, "Stream"),
+ MLast.ExLid (_loc, "lcons")),
+ slazy _loc e),
cstream gloc secl)
- | [SeNtr (loc, e)] ->
+ | [SeNtr (_loc, e)] ->
if not_computing e then e
else
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "slazy")),
- slazy loc e)
- | SeNtr (loc, e) :: secl ->
+ (_loc, MLast.ExUid (_loc, "Stream"),
+ MLast.ExLid (_loc, "slazy")),
+ slazy _loc e)
+ | SeNtr (_loc, e) :: secl ->
if not_computing e then
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "iapp")),
+ (_loc, MLast.ExUid (_loc, "Stream"),
+ MLast.ExLid (_loc, "iapp")),
e),
cstream gloc secl)
else
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExApp
- (loc,
+ (_loc,
MLast.ExAcc
- (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "lapp")),
- slazy loc e),
+ (_loc, MLast.ExUid (_loc, "Stream"),
+ MLast.ExLid (_loc, "lapp")),
+ slazy _loc e),
cstream gloc secl)
;;
(Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e))],
Gramext.action
(fun (pc : 'parser_case) (po : 'ipatt option) _ _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
- (cparser_match loc e po [pc] : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (cparser_match _loc e po [pc] : 'expr));
[Gramext.Stoken ("", "match"); Gramext.Sself;
Gramext.Stoken ("", "with"); Gramext.Stoken ("", "parser");
Gramext.Sopt
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (pcl : 'parser_case list) _ (po : 'ipatt option) _ _
- (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
- (cparser_match loc e po pcl : 'expr));
+ (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
+ (cparser_match _loc e po pcl : 'expr));
[Gramext.Stoken ("", "parser");
Gramext.Sopt
(Gramext.Snterm
(Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e))],
Gramext.action
(fun (pc : 'parser_case) (po : 'ipatt option) _
- (loc : Lexing.position * Lexing.position) ->
- (cparser loc po [pc] : 'expr));
+ (_loc : Lexing.position * Lexing.position) ->
+ (cparser _loc po [pc] : 'expr));
[Gramext.Stoken ("", "parser");
Gramext.Sopt
(Gramext.Snterm
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (pcl : 'parser_case list) _ (po : 'ipatt option) _
- (loc : Lexing.position * Lexing.position) ->
- (cparser loc po pcl : 'expr))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (cparser _loc po pcl : 'expr))]];
Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "[:");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
(fun (e : 'expr) _ (po : 'ipatt option) _ (sp : 'stream_patt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(sp, po, e : 'parser_case))]];
Grammar.Entry.obj (stream_patt : 'stream_patt Grammar.Entry.e), None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
+ (fun (_loc : Lexing.position * Lexing.position) ->
([] : 'stream_patt));
[Gramext.Snterm
(Grammar.Entry.obj
Gramext.Stoken ("", ";"))],
Gramext.action
(fun (sp : 'stream_patt_comp_err list) _ (spc : 'stream_patt_comp)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
((spc, None) :: sp : 'stream_patt));
[Gramext.Snterm
(Grammar.Entry.obj
(stream_patt_comp : 'stream_patt_comp Grammar.Entry.e))],
Gramext.action
(fun (spc : 'stream_patt_comp)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
([spc, None] : 'stream_patt))]];
Grammar.Entry.obj
(stream_patt_comp_err : 'stream_patt_comp_err Grammar.Entry.e),
Gramext.Snterm
(Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _
+ (_loc : Lexing.position * Lexing.position) ->
(e : 'e__1))])],
Gramext.action
(fun (eo : 'e__1 option) (spc : 'stream_patt_comp)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(spc, eo : 'stream_patt_comp_err))]];
Grammar.Entry.obj (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e),
None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
Gramext.action
- (fun (p : 'patt) (loc : Lexing.position * Lexing.position) ->
- (SpStr (loc, p) : 'stream_patt_comp));
+ (fun (p : 'patt) (_loc : Lexing.position * Lexing.position) ->
+ (SpStr (_loc, p) : 'stream_patt_comp));
[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
Gramext.Stoken ("", "=");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
(fun (e : 'expr) _ (p : 'patt)
- (loc : Lexing.position * Lexing.position) ->
- (SpNtr (loc, p, e) : 'stream_patt_comp));
+ (_loc : Lexing.position * Lexing.position) ->
+ (SpNtr (_loc, p, e) : 'stream_patt_comp));
[Gramext.Stoken ("", "`");
Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
Gramext.Sopt
Gramext.Snterm
(Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _
+ (_loc : Lexing.position * Lexing.position) ->
(e : 'e__2))])],
Gramext.action
(fun (eo : 'e__2 option) (p : 'patt) _
- (loc : Lexing.position * Lexing.position) ->
- (SpTrm (loc, p, eo) : 'stream_patt_comp))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (SpTrm (_loc, p, eo) : 'stream_patt_comp))]];
Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("LIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
- (MLast.PaLid (loc, i) : 'ipatt))]];
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
+ (MLast.PaLid (_loc, i) : 'ipatt))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
Some (Gramext.Level "simple"),
[None, None,
Gramext.Stoken ("", ":]")],
Gramext.action
(fun _ (se : 'stream_expr_comp list) _
- (loc : Lexing.position * Lexing.position) ->
- (cstream loc se : 'expr))]];
+ (_loc : Lexing.position * Lexing.position) ->
+ (cstream _loc se : 'expr))]];
Grammar.Entry.obj (stream_expr_comp : 'stream_expr_comp Grammar.Entry.e),
None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) (loc : Lexing.position * Lexing.position) ->
- (SeNtr (loc, e) : 'stream_expr_comp));
+ (fun (e : 'expr) (_loc : Lexing.position * Lexing.position) ->
+ (SeNtr (_loc, e) : 'stream_expr_comp));
[Gramext.Stoken ("", "`");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
- (SeTrm (loc, e) : 'stream_expr_comp))]]]);;
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
+ (SeTrm (_loc, e) : 'stream_expr_comp))]]]);;
| Loc
| Antiquot of MLast.loc * string
;;
- let loc =
+ let _loc =
let nowhere =
{(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0}
in
let rec to_expr =
function
Node (n, al) ->
- List.fold_left (fun e a -> MLast.ExApp (loc, e, to_expr a))
+ List.fold_left (fun e a -> MLast.ExApp (_loc, e, to_expr a))
(MLast.ExAcc
- (loc, MLast.ExUid (loc, "MLast"), MLast.ExUid (loc, n)))
+ (_loc, MLast.ExUid (_loc, "MLast"), MLast.ExUid (_loc, n)))
al
| List al ->
List.fold_right
(fun a e ->
MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), to_expr a),
- e))
- al (MLast.ExUid (loc, "[]"))
- | Tuple al -> MLast.ExTup (loc, List.map to_expr al)
- | Option None -> MLast.ExUid (loc, "None")
+ (_loc,
+ MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), to_expr a), e))
+ al (MLast.ExUid (_loc, "[]"))
+ | Tuple al -> MLast.ExTup (_loc, List.map to_expr al)
+ | Option None -> MLast.ExUid (_loc, "None")
| Option (Some a) ->
- MLast.ExApp (loc, MLast.ExUid (loc, "Some"), to_expr a)
- | Int s -> MLast.ExInt (loc, s)
- | Str s -> MLast.ExStr (loc, s)
- | Bool true -> MLast.ExUid (loc, "True")
- | Bool false -> MLast.ExUid (loc, "False")
+ MLast.ExApp (_loc, MLast.ExUid (_loc, "Some"), to_expr a)
+ | Int s -> MLast.ExInt (_loc, s)
+ | Str s -> MLast.ExStr (_loc, s)
+ | Bool true -> MLast.ExUid (_loc, "True")
+ | Bool false -> MLast.ExUid (_loc, "False")
| Cons (a1, a2) ->
MLast.ExApp
- (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), to_expr a1),
+ (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), to_expr a1),
to_expr a2)
| Apply (f, al) ->
- List.fold_left (fun e a -> MLast.ExApp (loc, e, to_expr a))
- (MLast.ExLid (loc, f)) al
- | Record lal -> MLast.ExRec (loc, List.map to_expr_label lal, None)
- | Loc -> MLast.ExLid (loc, !(Stdpp.loc_name))
+ List.fold_left (fun e a -> MLast.ExApp (_loc, e, to_expr a))
+ (MLast.ExLid (_loc, f)) al
+ | Record lal -> MLast.ExRec (_loc, List.map to_expr_label lal, None)
+ | Loc -> MLast.ExLid (_loc, !(Stdpp.loc_name))
| Antiquot (loc, s) ->
let (bolpos, lnum, _) = !(Pcaml.position) in
let (bolposv, lnumv) = !bolpos, !lnum in
(Reloc.adjust_loc (fst loc) (bp, ep), exc))
| exc -> restore_pos (); raise exc
in
- MLast.ExAnt (loc, e)
+ MLast.ExAnt (_loc, e)
and to_expr_label (l, a) =
- MLast.PaAcc (loc, MLast.PaUid (loc, "MLast"), MLast.PaLid (loc, l)),
+ MLast.PaAcc (_loc, MLast.PaUid (_loc, "MLast"), MLast.PaLid (_loc, l)),
to_expr a
;;
let rec to_patt =
function
Node (n, al) ->
- List.fold_left (fun e a -> MLast.PaApp (loc, e, to_patt a))
+ List.fold_left (fun e a -> MLast.PaApp (_loc, e, to_patt a))
(MLast.PaAcc
- (loc, MLast.PaUid (loc, "MLast"), MLast.PaUid (loc, n)))
+ (_loc, MLast.PaUid (_loc, "MLast"), MLast.PaUid (_loc, n)))
al
| List al ->
List.fold_right
(fun a p ->
MLast.PaApp
- (loc, MLast.PaApp (loc, MLast.PaUid (loc, "::"), to_patt a),
- p))
- al (MLast.PaUid (loc, "[]"))
- | Tuple al -> MLast.PaTup (loc, List.map to_patt al)
- | Option None -> MLast.PaUid (loc, "None")
+ (_loc,
+ MLast.PaApp (_loc, MLast.PaUid (_loc, "::"), to_patt a), p))
+ al (MLast.PaUid (_loc, "[]"))
+ | Tuple al -> MLast.PaTup (_loc, List.map to_patt al)
+ | Option None -> MLast.PaUid (_loc, "None")
| Option (Some a) ->
- MLast.PaApp (loc, MLast.PaUid (loc, "Some"), to_patt a)
- | Int s -> MLast.PaInt (loc, s)
- | Str s -> MLast.PaStr (loc, s)
- | Bool true -> MLast.PaUid (loc, "True")
- | Bool false -> MLast.PaUid (loc, "False")
+ MLast.PaApp (_loc, MLast.PaUid (_loc, "Some"), to_patt a)
+ | Int s -> MLast.PaInt (_loc, s)
+ | Str s -> MLast.PaStr (_loc, s)
+ | Bool true -> MLast.PaUid (_loc, "True")
+ | Bool false -> MLast.PaUid (_loc, "False")
| Cons (a1, a2) ->
MLast.PaApp
- (loc, MLast.PaApp (loc, MLast.PaUid (loc, "::"), to_patt a1),
+ (_loc, MLast.PaApp (_loc, MLast.PaUid (_loc, "::"), to_patt a1),
to_patt a2)
| Apply (_, _) -> failwith "bad pattern"
- | Record lal -> MLast.PaRec (loc, List.map to_patt_label lal)
- | Loc -> MLast.PaAny loc
+ | Record lal -> MLast.PaRec (_loc, List.map to_patt_label lal)
+ | Loc -> MLast.PaAny _loc
| Antiquot (loc, s) ->
let (bolpos, lnum, _) = !(Pcaml.position) in
let (bolposv, lnumv) = !bolpos, !lnum in
(Reloc.adjust_loc (fst loc) (bp, ep), exc))
| exc -> restore_pos (); raise exc
in
- MLast.PaAnt (loc, p)
+ MLast.PaAnt (_loc, p)
and to_patt_label (l, a) =
- MLast.PaAcc (loc, MLast.PaUid (loc, "MLast"), MLast.PaLid (loc, l)),
+ MLast.PaAcc (_loc, MLast.PaUid (_loc, "MLast"), MLast.PaLid (_loc, l)),
to_patt a
;;
end
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (s : 'str_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(s : 'e__1))])],
Gramext.action
- (fun (a : 'e__1 list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'e__1 list)
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "end")],
Gramext.action
- (fun _ (st : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (st : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("MeStr", [Qast.Loc; st]) : 'module_expr));
[Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "(");
Gramext.Snterm
Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself],
Gramext.action
(fun (me : 'module_expr) _ _ (t : 'module_type) _ (i : 'a_UIDENT) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("MeFun", [Qast.Loc; i; t; me]) : 'module_expr))];
None, None,
[[Gramext.Sself; Gramext.Sself],
Gramext.action
(fun (me2 : 'module_expr) (me1 : 'module_expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("MeApp", [Qast.Loc; me1; me2]) : 'module_expr))];
None, None,
[[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (me2 : 'module_expr) _ (me1 : 'module_expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("MeAcc", [Qast.Loc; me1; me2]) : 'module_expr))];
Some "simple", None,
[[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (me : 'module_expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(me : 'module_expr));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
Gramext.Snterm
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (mt : 'module_type) _ (me : 'module_expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("MeTyc", [Qast.Loc; me; mt]) : 'module_expr));
[Gramext.Snterm
(Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_UIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("MeUid", [Qast.Loc; i]) : 'module_expr))]];
Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None,
[Some "top", None,
[[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("StExp", [Qast.Loc; e]) : 'str_item));
[Gramext.Stoken ("", "value");
Gramext.srules
[[Gramext.Stoken ("", "rec")],
Gramext.action
(fun (x : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Str x : 'e__3))])],
Gramext.action
(fun (a : 'e__3 option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.srules
[[Gramext.Slist1sep
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (a : 'let_binding list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
(fun (l : 'a_list) (r : 'a_opt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("StVal", [Qast.Loc; o2b r; l]) : 'str_item));
[Gramext.Stoken ("", "type");
Gramext.srules
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (a : 'type_declaration list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
- (fun (tdl : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (tdl : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("StTyp", [Qast.Loc; tdl]) : 'str_item));
[Gramext.Stoken ("", "open");
Gramext.Snterm
(Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'mod_ident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'mod_ident) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("StOpn", [Qast.Loc; i]) : 'str_item));
[Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type");
Gramext.Snterm
(Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
Gramext.action
(fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("StMty", [Qast.Loc; i; mt]) : 'str_item));
[Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec");
Gramext.srules
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (a : 'module_rec_binding list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
(fun (nmtmes : 'a_list) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("StRecMod", [Qast.Loc; nmtmes]) : 'str_item));
[Gramext.Stoken ("", "module");
Gramext.Snterm
(module_binding : 'module_binding Grammar.Entry.e))],
Gramext.action
(fun (mb : 'module_binding) (i : 'a_UIDENT) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("StMod", [Qast.Loc; i; mb]) : 'str_item));
[Gramext.Stoken ("", "include");
Gramext.Snterm
(Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
Gramext.action
(fun (me : 'module_expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("StInc", [Qast.Loc; me]) : 'str_item));
[Gramext.Stoken ("", "external");
Gramext.Snterm
(Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e)))],
Gramext.action
(fun (a : 'a_STRING list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
(fun (pd : 'a_list) _ (t : 'ctyp) _ (i : 'a_LIDENT) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("StExt", [Qast.Loc; i; t; pd]) : 'str_item));
[Gramext.Stoken ("", "exception");
Gramext.Snterm
(Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e))],
Gramext.action
(fun (b : 'rebind_exn) (ctl : 'constructor_declaration) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(let (_, c, tl) =
match ctl with
Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (s : 'str_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(s : 'e__2))])],
Gramext.action
- (fun (a : 'e__2 list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'e__2 list)
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "end")],
Gramext.action
- (fun _ (st : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (st : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("StDcl", [Qast.Loc; st]) : 'str_item))]];
Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e), None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
+ (fun (_loc : Lexing.position * Lexing.position) ->
(Qast.List [] : 'rebind_exn));
[Gramext.Stoken ("", "=");
Gramext.Snterm
(Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))],
Gramext.action
- (fun (sl : 'mod_ident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (sl : 'mod_ident) _ (_loc : Lexing.position * Lexing.position) ->
(sl : 'rebind_exn))]];
Grammar.Entry.obj (module_binding : 'module_binding Grammar.Entry.e),
None,
(Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
Gramext.action
(fun (me : 'module_expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(me : 'module_binding));
[Gramext.Stoken ("", ":");
Gramext.Snterm
(Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
Gramext.action
(fun (me : 'module_expr) _ (mt : 'module_type) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("MeTyc", [Qast.Loc; me; mt]) : 'module_binding));
[Gramext.Stoken ("", "(");
Gramext.Snterm
Gramext.Stoken ("", ")"); Gramext.Sself],
Gramext.action
(fun (mb : 'module_binding) _ (mt : 'module_type) _ (m : 'a_UIDENT) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("MeFun", [Qast.Loc; m; mt; mb]) : 'module_binding))]];
Grammar.Entry.obj
(module_rec_binding : 'module_rec_binding Grammar.Entry.e),
(Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
Gramext.action
(fun (me : 'module_expr) _ (mt : 'module_type) _ (m : 'a_UIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [m; me; mt] : 'module_rec_binding))]];
Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e), None,
[None, None,
Gramext.Stoken ("", "->"); Gramext.Sself],
Gramext.action
(fun (mt : 'module_type) _ _ (t : 'module_type) _ (i : 'a_UIDENT) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("MtFun", [Qast.Loc; i; t; mt]) : 'module_type))];
None, None,
[[Gramext.Sself; Gramext.Stoken ("", "with");
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (a : 'with_constr list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
(fun (wcl : 'a_list) _ (mt : 'module_type)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("MtWit", [Qast.Loc; mt; wcl]) : 'module_type))];
None, None,
[[Gramext.Stoken ("", "sig");
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (s : 'sig_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(s : 'e__4))])],
Gramext.action
- (fun (a : 'e__4 list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'e__4 list)
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "end")],
Gramext.action
- (fun _ (sg : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (sg : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("MtSig", [Qast.Loc; sg]) : 'module_type))];
None, None,
[[Gramext.Sself; Gramext.Sself],
Gramext.action
(fun (m2 : 'module_type) (m1 : 'module_type)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("MtApp", [Qast.Loc; m1; m2]) : 'module_type))];
None, None,
[[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (m2 : 'module_type) _ (m1 : 'module_type)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("MtAcc", [Qast.Loc; m1; m2]) : 'module_type))];
Some "simple", None,
[[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (mt : 'module_type) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(mt : 'module_type));
[Gramext.Stoken ("", "'");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("MtQuo", [Qast.Loc; i]) : 'module_type));
[Gramext.Snterm
(Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("MtLid", [Qast.Loc; i]) : 'module_type));
[Gramext.Snterm
(Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_UIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("MtUid", [Qast.Loc; i]) : 'module_type))]];
Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None,
[Some "top", None,
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (i : 'a_LIDENT) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("SgVal", [Qast.Loc; i; t]) : 'sig_item));
[Gramext.Stoken ("", "type");
Gramext.srules
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (a : 'type_declaration list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
- (fun (tdl : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (tdl : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("SgTyp", [Qast.Loc; tdl]) : 'sig_item));
[Gramext.Stoken ("", "open");
Gramext.Snterm
(Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'mod_ident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'mod_ident) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("SgOpn", [Qast.Loc; i]) : 'sig_item));
[Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec");
Gramext.srules
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (a : 'module_rec_declaration list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
- (fun (mds : 'a_list) _ _ (loc : Lexing.position * Lexing.position) ->
+ (fun (mds : 'a_list) _ _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("SgRecMod", [Qast.Loc; mds]) : 'sig_item));
[Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type");
Gramext.Snterm
(Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
Gramext.action
(fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("SgMty", [Qast.Loc; i; mt]) : 'sig_item));
[Gramext.Stoken ("", "module");
Gramext.Snterm
(module_declaration : 'module_declaration Grammar.Entry.e))],
Gramext.action
(fun (mt : 'module_declaration) (i : 'a_UIDENT) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("SgMod", [Qast.Loc; i; mt]) : 'sig_item));
[Gramext.Stoken ("", "include");
Gramext.Snterm
(Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
Gramext.action
(fun (mt : 'module_type) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("SgInc", [Qast.Loc; mt]) : 'sig_item));
[Gramext.Stoken ("", "external");
Gramext.Snterm
(Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e)))],
Gramext.action
(fun (a : 'a_STRING list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
(fun (pd : 'a_list) _ (t : 'ctyp) _ (i : 'a_LIDENT) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("SgExt", [Qast.Loc; i; t; pd]) : 'sig_item));
[Gramext.Stoken ("", "exception");
Gramext.Snterm
'constructor_declaration Grammar.Entry.e))],
Gramext.action
(fun (ctl : 'constructor_declaration) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(let (_, c, tl) =
match ctl with
Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (s : 'sig_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(s : 'e__5))])],
Gramext.action
- (fun (a : 'e__5 list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'e__5 list)
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "end")],
Gramext.action
- (fun _ (st : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (st : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("SgDcl", [Qast.Loc; st]) : 'sig_item))]];
Grammar.Entry.obj
(module_declaration : 'module_declaration Grammar.Entry.e),
Gramext.Stoken ("", ")"); Gramext.Sself],
Gramext.action
(fun (mt : 'module_declaration) _ (t : 'module_type) _ (i : 'a_UIDENT)
- _ (loc : Lexing.position * Lexing.position) ->
+ _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("MtFun", [Qast.Loc; i; t; mt]) : 'module_declaration));
[Gramext.Stoken ("", ":");
Gramext.Snterm
(Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
Gramext.action
(fun (mt : 'module_type) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(mt : 'module_declaration))]];
Grammar.Entry.obj
(module_rec_declaration : 'module_rec_declaration Grammar.Entry.e),
(Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))],
Gramext.action
(fun (mt : 'module_type) _ (m : 'a_UIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [m; mt] : 'module_rec_declaration))]];
Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e), None,
[None, None,
(Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))],
Gramext.action
(fun (me : 'module_expr) _ (i : 'mod_ident) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("WcMod", [Qast.Loc; i; me]) : 'with_constr));
[Gramext.Stoken ("", "type");
Gramext.Snterm
(type_parameter : 'type_parameter Grammar.Entry.e)))],
Gramext.action
(fun (a : 'type_parameter list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "=");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (tpl : 'a_list) (i : 'mod_ident) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("WcTyp", [Qast.Loc; i; tpl; t]) : 'with_constr))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), None,
[Some "top", Some Gramext.RightA,
Gramext.Stoken ("", "}")],
Gramext.action
(fun _ (seq : 'sequence) _ _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExWhi", [Qast.Loc; e; seq]) : 'expr));
[Gramext.Stoken ("", "for");
Gramext.Snterm
Gramext.action
(fun _ (seq : 'sequence) _ _ (e2 : 'expr) (df : 'direction_flag)
(e1 : 'expr) _ (i : 'a_LIDENT) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExFor", [Qast.Loc; i; e1; e2; df; seq]) : 'expr));
[Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{");
Gramext.Snterm
Gramext.Stoken ("", "}")],
Gramext.action
(fun _ (seq : 'sequence) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(mksequence Qast.Loc seq : 'expr));
[Gramext.Stoken ("", "if"); Gramext.Sself; Gramext.Stoken ("", "then");
Gramext.Sself; Gramext.Stoken ("", "else"); Gramext.Sself],
Gramext.action
(fun (e3 : 'expr) _ (e2 : 'expr) _ (e1 : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExIfe", [Qast.Loc; e1; e2; e3]) : 'expr));
[Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with");
Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
Gramext.Stoken ("", "->"); Gramext.Sself],
Gramext.action
(fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExTry",
[Qast.Loc; e;
Gramext.Stoken ("", "|"))],
Gramext.action
(fun (a : 'match_case list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (l : 'a_list) _ _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExTry", [Qast.Loc; e; l]) : 'expr));
[Gramext.Stoken ("", "match"); Gramext.Sself;
Gramext.Stoken ("", "with");
Gramext.Stoken ("", "->"); Gramext.Sself],
Gramext.action
(fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExMat",
[Qast.Loc; e;
Gramext.Stoken ("", "|"))],
Gramext.action
(fun (a : 'match_case list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (l : 'a_list) _ _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExMat", [Qast.Loc; e; l]) : 'expr));
[Gramext.Stoken ("", "fun");
Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
(Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e))],
Gramext.action
(fun (e : 'fun_def) (p : 'ipatt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExFun",
[Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) :
Gramext.Stoken ("", "|"))],
Gramext.action
(fun (a : 'match_case list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "]")],
Gramext.action
- (fun _ (l : 'a_list) _ _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (l : 'a_list) _ _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExFun", [Qast.Loc; l]) : 'expr));
[Gramext.Stoken ("", "let"); Gramext.Stoken ("", "module");
Gramext.Snterm
Gramext.Stoken ("", "in"); Gramext.Sself],
Gramext.action
(fun (e : 'expr) _ (mb : 'module_binding) (m : 'a_UIDENT) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExLmd", [Qast.Loc; m; mb; e]) : 'expr));
[Gramext.Stoken ("", "let");
Gramext.srules
[[Gramext.Stoken ("", "rec")],
Gramext.action
(fun (x : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Str x : 'e__6))])],
Gramext.action
(fun (a : 'e__6 option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.srules
[[Gramext.Slist1sep
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (a : 'let_binding list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "in"); Gramext.Sself],
Gramext.action
(fun (x : 'expr) _ (l : 'a_list) (r : 'a_opt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExLet", [Qast.Loc; o2b r; l; x]) : 'expr))];
Some "where", None,
[[Gramext.Sself; Gramext.Stoken ("", "where");
[[Gramext.Stoken ("", "rec")],
Gramext.action
(fun (x : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Str x : 'e__7))])],
Gramext.action
(fun (a : 'e__7 option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Snterm
(Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e))],
Gramext.action
(fun (lb : 'let_binding) (rf : 'a_opt) _ (e : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExLet", [Qast.Loc; o2b rf; Qast.List [lb]; e]) :
'expr))];
Some ":=", Some Gramext.NonA,
Gramext.Snterm (Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e))],
Gramext.action
(fun _ (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExAss", [Qast.Loc; e1; e2]) : 'expr))];
Some "||", Some Gramext.RightA,
[[Gramext.Sself; Gramext.Stoken ("", "||"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[[Gramext.Sself; Gramext.Stoken ("", "&&"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[[Gramext.Sself; Gramext.Stoken ("", "!="); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "<>"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "="); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", ">="); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "<="); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", ">"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "<"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[[Gramext.Sself; Gramext.Stoken ("", "@"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "^"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[[Gramext.Sself; Gramext.Stoken ("", "-."); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "+."); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "-"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "+"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[[Gramext.Sself; Gramext.Stoken ("", "mod"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "lxor"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "lor"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "land"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "/."); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "*."); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "/"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "*"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[[Gramext.Sself; Gramext.Stoken ("", "lsr"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "lsl"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "asr"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
[Gramext.Sself; Gramext.Stoken ("", "**"); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc;
Some "unary minus", Some Gramext.NonA,
[[Gramext.Stoken ("", "-."); Gramext.Sself],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(mkumin Qast.Loc (Qast.Str "-.") e : 'expr));
[Gramext.Stoken ("", "-"); Gramext.Sself],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(mkumin Qast.Loc (Qast.Str "-") e : 'expr))];
Some "apply", Some Gramext.LeftA,
[[Gramext.Stoken ("", "lazy"); Gramext.Sself],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExLaz", [Qast.Loc; e]) : 'expr));
[Gramext.Stoken ("", "assert"); Gramext.Sself],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(mkassert Qast.Loc e : 'expr));
[Gramext.Sself; Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExApp", [Qast.Loc; e1; e2]) : 'expr))];
Some ".", Some Gramext.LeftA,
[[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (e2 : 'expr) _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExAcc", [Qast.Loc; e1; e2]) : 'expr));
[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "[");
Gramext.Sself; Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (e2 : 'expr) _ _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExSte", [Qast.Loc; e1; e2]) : 'expr));
[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "(");
Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (e2 : 'expr) _ _ (e1 : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExAre", [Qast.Loc; e1; e2]) : 'expr))];
Some "~-", Some Gramext.NonA,
[[Gramext.Stoken ("", "~-."); Gramext.Sself],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "~-."]);
'expr));
[Gramext.Stoken ("", "~-"); Gramext.Sself],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExApp",
[Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "~-"]);
Some "simple", None,
[[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(e : 'expr));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ",");
Gramext.srules
(Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)),
Gramext.Stoken ("", ","))],
Gramext.action
- (fun (a : 'expr list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'expr list)
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (el : 'a_list) _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExTup", [Qast.Loc; Qast.Cons (e, el)]) : 'expr));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (t : 'ctyp) _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExTyc", [Qast.Loc; e; t]) : 'expr));
[Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExUid", [Qast.Loc; Qast.Str "()"]) : 'expr));
[Gramext.Stoken ("", "{"); Gramext.Stoken ("", "("); Gramext.Sself;
Gramext.Stoken ("", ")"); Gramext.Stoken ("", "with");
Gramext.Stoken ("", ";"))],
Gramext.action
(fun (a : 'label_expr list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "}")],
Gramext.action
(fun _ (lel : 'a_list) _ _ (e : 'expr) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExRec", [Qast.Loc; lel; Qast.Option (Some e)]) :
'expr));
[Gramext.Stoken ("", "{");
Gramext.Stoken ("", ";"))],
Gramext.action
(fun (a : 'label_expr list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "}")],
Gramext.action
- (fun _ (lel : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (lel : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExRec", [Qast.Loc; lel; Qast.Option None]) : 'expr));
[Gramext.Stoken ("", "[|");
Gramext.srules
(Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)),
Gramext.Stoken ("", ";"))],
Gramext.action
- (fun (a : 'expr list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'expr list)
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "|]")],
Gramext.action
- (fun _ (el : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (el : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExArr", [Qast.Loc; el]) : 'expr));
[Gramext.Stoken ("", "[");
Gramext.srules
(Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)),
Gramext.Stoken ("", ";"))],
Gramext.action
- (fun (a : 'expr list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'expr list)
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Snterm
(Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e));
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (last : 'cons_expr_opt) (el : 'a_list) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(mklistexp Qast.Loc last el : 'expr));
[Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")],
Gramext.action
- (fun _ _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExUid", [Qast.Loc; Qast.Str "[]"]) : 'expr));
[Gramext.Snterm
(Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'expr_ident) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'expr_ident) (_loc : Lexing.position * Lexing.position) ->
(i : 'expr));
[Gramext.Snterm (Grammar.Entry.obj (a_CHAR : 'a_CHAR Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_CHAR) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_CHAR) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExChr", [Qast.Loc; s]) : 'expr));
[Gramext.Snterm
(Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_STRING) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_STRING) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExStr", [Qast.Loc; s]) : 'expr));
[Gramext.Snterm
(Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_FLOAT) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_FLOAT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExFlo", [Qast.Loc; s]) : 'expr));
[Gramext.Snterm
(Grammar.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_NATIVEINT) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_NATIVEINT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExNativeInt", [Qast.Loc; s]) : 'expr));
[Gramext.Snterm
(Grammar.Entry.obj (a_INT64 : 'a_INT64 Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_INT64) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_INT64) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExInt64", [Qast.Loc; s]) : 'expr));
[Gramext.Snterm
(Grammar.Entry.obj (a_INT32 : 'a_INT32 Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_INT32) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_INT32) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExInt32", [Qast.Loc; s]) : 'expr));
[Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_INT) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_INT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExInt", [Qast.Loc; s]) : 'expr))]];
Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e), None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
+ (fun (_loc : Lexing.position * Lexing.position) ->
(Qast.Option None : 'cons_expr_opt));
[Gramext.Stoken ("", "::");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option (Some e) : 'cons_expr_opt))]];
Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e), None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) -> (() : 'dummy))]];
+ (fun (_loc : Lexing.position * Lexing.position) -> (() : 'dummy))]];
Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) (_loc : Lexing.position * Lexing.position) ->
(Qast.List [e] : 'sequence));
[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
Gramext.Stoken ("", ";")],
Gramext.action
- (fun _ (e : 'expr) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (e : 'expr) (_loc : Lexing.position * Lexing.position) ->
(Qast.List [e] : 'sequence));
[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
Gramext.Stoken ("", ";"); Gramext.Sself],
Gramext.action
(fun (el : 'sequence) _ (e : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Cons (e, el) : 'sequence));
[Gramext.Stoken ("", "let");
Gramext.srules
[[Gramext.Stoken ("", "rec")],
Gramext.action
(fun (x : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Str x : 'e__8))])],
Gramext.action
(fun (a : 'e__8 option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.srules
[[Gramext.Slist1sep
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (a : 'let_binding list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.srules
[[Gramext.Stoken ("", ";")],
Gramext.action
- (fun (x : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (x : string) (_loc : Lexing.position * Lexing.position) ->
(x : 'e__9));
[Gramext.Stoken ("", "in")],
Gramext.action
- (fun (x : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (x : string) (_loc : Lexing.position * Lexing.position) ->
(x : 'e__9))];
Gramext.Sself],
Gramext.action
(fun (el : 'sequence) _ (l : 'a_list) (rf : 'a_opt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List
[Qast.Node
("ExLet", [Qast.Loc; o2b rf; l; mksequence Qast.Loc el])] :
(Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))],
Gramext.action
(fun (e : 'fun_binding) (p : 'ipatt)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [p; e] : 'let_binding))]];
Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e), None,
[None, Some Gramext.RightA,
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
(fun (e : 'expr) _ (t : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExTyc", [Qast.Loc; e; t]) : 'fun_binding));
[Gramext.Stoken ("", "=");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(e : 'fun_binding));
[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
Gramext.Sself],
Gramext.action
(fun (e : 'fun_binding) (p : 'ipatt)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExFun",
[Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) :
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
(fun (e : 'expr) _ (w : 'when_expr_opt) (aso : 'as_patt_opt)
- (p : 'patt) (loc : Lexing.position * Lexing.position) ->
+ (p : 'patt) (_loc : Lexing.position * Lexing.position) ->
(mkmatchcase Qast.Loc p aso w e : 'match_case))]];
Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e), None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
+ (fun (_loc : Lexing.position * Lexing.position) ->
(Qast.Option None : 'as_patt_opt));
[Gramext.Stoken ("", "as");
Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
Gramext.action
- (fun (p : 'patt) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (p : 'patt) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option (Some p) : 'as_patt_opt))]];
Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e), None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
+ (fun (_loc : Lexing.position * Lexing.position) ->
(Qast.Option None : 'when_expr_opt));
[Gramext.Stoken ("", "when");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option (Some e) : 'when_expr_opt))]];
Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e), None,
[None, None,
(Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))],
Gramext.action
(fun (e : 'fun_binding) (i : 'patt_label_ident)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [i; e] : 'label_expr))]];
Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e), None,
[None, Some Gramext.RightA,
Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (j : 'expr_ident) _ (i : 'a_UIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(mkexprident Qast.Loc i j : 'expr_ident));
[Gramext.Snterm
(Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_UIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExUid", [Qast.Loc; i]) : 'expr_ident));
[Gramext.Snterm
(Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExLid", [Qast.Loc; i]) : 'expr_ident))]];
Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e), None,
[None, Some Gramext.RightA,
[[Gramext.Stoken ("", "->");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(e : 'fun_def));
[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
Gramext.Sself],
Gramext.action
(fun (e : 'fun_def) (p : 'ipatt)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("ExFun",
[Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) :
[[Gramext.Sself; Gramext.Stoken ("", "|"); Gramext.Sself],
Gramext.action
(fun (p2 : 'patt) _ (p1 : 'patt)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaOrp", [Qast.Loc; p1; p2]) : 'patt))];
None, Some Gramext.NonA,
[[Gramext.Sself; Gramext.Stoken ("", ".."); Gramext.Sself],
Gramext.action
(fun (p2 : 'patt) _ (p1 : 'patt)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaRng", [Qast.Loc; p1; p2]) : 'patt))];
None, Some Gramext.LeftA,
[[Gramext.Sself; Gramext.Sself],
Gramext.action
(fun (p2 : 'patt) (p1 : 'patt)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaApp", [Qast.Loc; p1; p2]) : 'patt))];
None, Some Gramext.LeftA,
[[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (p2 : 'patt) _ (p1 : 'patt)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaAcc", [Qast.Loc; p1; p2]) : 'patt))];
Some "simple", None,
[[Gramext.Stoken ("", "_")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaAny", [Qast.Loc]) : 'patt));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ",");
Gramext.srules
(Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)),
Gramext.Stoken ("", ","))],
Gramext.action
- (fun (a : 'patt list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'patt list)
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (pl : 'a_list) _ (p : 'patt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaTup", [Qast.Loc; Qast.Cons (p, pl)]) : 'patt));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as");
Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (p2 : 'patt) _ (p : 'patt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaAli", [Qast.Loc; p; p2]) : 'patt));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (t : 'ctyp) _ (p : 'patt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'patt));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (p : 'patt) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (p : 'patt) _ (_loc : Lexing.position * Lexing.position) ->
(p : 'patt));
[Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaUid", [Qast.Loc; Qast.Str "()"]) : 'patt));
[Gramext.Stoken ("", "{");
Gramext.srules
Gramext.Stoken ("", ";"))],
Gramext.action
(fun (a : 'label_patt list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "}")],
Gramext.action
- (fun _ (lpl : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (lpl : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaRec", [Qast.Loc; lpl]) : 'patt));
[Gramext.Stoken ("", "[|");
Gramext.srules
(Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)),
Gramext.Stoken ("", ";"))],
Gramext.action
- (fun (a : 'patt list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'patt list)
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "|]")],
Gramext.action
- (fun _ (pl : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (pl : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaArr", [Qast.Loc; pl]) : 'patt));
[Gramext.Stoken ("", "[");
Gramext.srules
(Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)),
Gramext.Stoken ("", ";"))],
Gramext.action
- (fun (a : 'patt list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'patt list)
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Snterm
(Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e));
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (last : 'cons_patt_opt) (pl : 'a_list) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(mklistpat Qast.Loc last pl : 'patt));
[Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")],
Gramext.action
- (fun _ _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaUid", [Qast.Loc; Qast.Str "[]"]) : 'patt));
[Gramext.Stoken ("", "-");
Gramext.Snterm
(Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_FLOAT) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_FLOAT) _ (_loc : Lexing.position * Lexing.position) ->
(mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool false) s : 'patt));
[Gramext.Stoken ("", "-");
Gramext.Snterm
(Grammar.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_NATIVEINT) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_NATIVEINT) _
+ (_loc : Lexing.position * Lexing.position) ->
(mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool true) s : 'patt));
[Gramext.Stoken ("", "-");
Gramext.Snterm
(Grammar.Entry.obj (a_INT64 : 'a_INT64 Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_INT64) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_INT64) _ (_loc : Lexing.position * Lexing.position) ->
(mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool true) s : 'patt));
[Gramext.Stoken ("", "-");
Gramext.Snterm
(Grammar.Entry.obj (a_INT32 : 'a_INT32 Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_INT32) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_INT32) _ (_loc : Lexing.position * Lexing.position) ->
(mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool true) s : 'patt));
[Gramext.Stoken ("", "-");
Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_INT) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_INT) _ (_loc : Lexing.position * Lexing.position) ->
(mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool true) s : 'patt));
[Gramext.Snterm (Grammar.Entry.obj (a_CHAR : 'a_CHAR Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_CHAR) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_CHAR) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaChr", [Qast.Loc; s]) : 'patt));
[Gramext.Snterm
(Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_STRING) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_STRING) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaStr", [Qast.Loc; s]) : 'patt));
[Gramext.Snterm
(Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_FLOAT) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_FLOAT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaFlo", [Qast.Loc; s]) : 'patt));
[Gramext.Snterm
(Grammar.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_NATIVEINT) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_NATIVEINT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaNativeInt", [Qast.Loc; s]) : 'patt));
[Gramext.Snterm
(Grammar.Entry.obj (a_INT64 : 'a_INT64 Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_INT64) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_INT64) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaInt64", [Qast.Loc; s]) : 'patt));
[Gramext.Snterm
(Grammar.Entry.obj (a_INT32 : 'a_INT32 Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_INT32) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_INT32) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaInt32", [Qast.Loc; s]) : 'patt));
[Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_INT) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_INT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaInt", [Qast.Loc; s]) : 'patt));
[Gramext.Snterm
(Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_UIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaUid", [Qast.Loc; s]) : 'patt));
[Gramext.Snterm
(Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_LIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaLid", [Qast.Loc; s]) : 'patt))]];
Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e), None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
+ (fun (_loc : Lexing.position * Lexing.position) ->
(Qast.Option None : 'cons_patt_opt));
[Gramext.Stoken ("", "::");
Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
Gramext.action
- (fun (p : 'patt) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (p : 'patt) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option (Some p) : 'cons_patt_opt))]];
Grammar.Entry.obj (label_patt : 'label_patt Grammar.Entry.e), None,
[None, None,
Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
Gramext.action
(fun (p : 'patt) _ (i : 'patt_label_ident)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [i; p] : 'label_patt))]];
Grammar.Entry.obj (patt_label_ident : 'patt_label_ident Grammar.Entry.e),
None,
[[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (p2 : 'patt_label_ident) _ (p1 : 'patt_label_ident)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaAcc", [Qast.Loc; p1; p2]) : 'patt_label_ident))];
Some "simple", Some Gramext.RightA,
[[Gramext.Snterm
(Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaLid", [Qast.Loc; i]) : 'patt_label_ident));
[Gramext.Snterm
(Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_UIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaUid", [Qast.Loc; i]) : 'patt_label_ident))]];
Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "_")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaAny", [Qast.Loc]) : 'ipatt));
[Gramext.Snterm
(Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
Gramext.action
- (fun (s : 'a_LIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaLid", [Qast.Loc; s]) : 'ipatt));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ",");
Gramext.srules
Gramext.Stoken ("", ","))],
Gramext.action
(fun (a : 'ipatt list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (pl : 'a_list) _ (p : 'ipatt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaTup", [Qast.Loc; Qast.Cons (p, pl)]) : 'ipatt));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as");
Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (p2 : 'ipatt) _ (p : 'ipatt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaAli", [Qast.Loc; p; p2]) : 'ipatt));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (t : 'ctyp) _ (p : 'ipatt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'ipatt));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (p : 'ipatt) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (p : 'ipatt) _ (_loc : Lexing.position * Lexing.position) ->
(p : 'ipatt));
[Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaUid", [Qast.Loc; Qast.Str "()"]) : 'ipatt));
[Gramext.Stoken ("", "{");
Gramext.srules
Gramext.Stoken ("", ";"))],
Gramext.action
(fun (a : 'label_ipatt list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "}")],
Gramext.action
- (fun _ (lpl : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (lpl : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaRec", [Qast.Loc; lpl]) : 'ipatt))]];
Grammar.Entry.obj (label_ipatt : 'label_ipatt Grammar.Entry.e), None,
[None, None,
Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))],
Gramext.action
(fun (p : 'ipatt) _ (i : 'patt_label_ident)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [i; p] : 'label_ipatt))]];
Grammar.Entry.obj (type_declaration : 'type_declaration Grammar.Entry.e),
None,
(type_parameter : 'type_parameter Grammar.Entry.e)))],
Gramext.action
(fun (a : 'type_parameter list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "=");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
(constrain : 'constrain Grammar.Entry.e)))],
Gramext.action
(fun (a : 'constrain list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
(fun (cl : 'a_list) (tk : 'ctyp) _ (tpl : 'a_list) (n : 'type_patt)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [n; tpl; tk; cl] : 'type_declaration))]];
Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm
(Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
Gramext.action
- (fun (n : 'a_LIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (n : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [Qast.Loc; n] : 'type_patt))]];
Grammar.Entry.obj (constrain : 'constrain Grammar.Entry.e), None,
[None, None,
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t2 : 'ctyp) _ (t1 : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [t1; t2] : 'constrain))]];
Grammar.Entry.obj (type_parameter : 'type_parameter Grammar.Entry.e),
None,
[[Gramext.Stoken ("", "-"); Gramext.Stoken ("", "'");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'ident) _ _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'ident) _ _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [i; Qast.Tuple [Qast.Bool false; Qast.Bool true]] :
'type_parameter));
[Gramext.Stoken ("", "+"); Gramext.Stoken ("", "'");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'ident) _ _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'ident) _ _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [i; Qast.Tuple [Qast.Bool true; Qast.Bool false]] :
'type_parameter));
[Gramext.Stoken ("", "'");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [i; Qast.Tuple [Qast.Bool false; Qast.Bool false]] :
'type_parameter))]];
Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), None,
[[Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself],
Gramext.action
(fun (t2 : 'ctyp) _ (t1 : 'ctyp)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyMan", [Qast.Loc; t1; t2]) : 'ctyp))];
- None, Some Gramext.LeftA,
+ None, Some Gramext.NonA,
+ [[Gramext.Stoken ("", "private");
+ Gramext.Snterml
+ (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), "alias")],
+ Gramext.action
+ (fun (t : 'ctyp) _ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Node ("TyPrv", [Qast.Loc; t]) : 'ctyp))];
+ Some "alias", Some Gramext.LeftA,
[[Gramext.Sself; Gramext.Stoken ("", "as"); Gramext.Sself],
Gramext.action
(fun (t2 : 'ctyp) _ (t1 : 'ctyp)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyAli", [Qast.Loc; t1; t2]) : 'ctyp))];
None, Some Gramext.LeftA,
[[Gramext.Stoken ("", "!");
(Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e)))],
Gramext.action
(fun (a : 'typevar list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (t : 'ctyp) _ (pl : 'a_list) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyPol", [Qast.Loc; pl; t]) : 'ctyp))];
Some "arrow", Some Gramext.RightA,
[[Gramext.Sself; Gramext.Stoken ("", "->"); Gramext.Sself],
Gramext.action
(fun (t2 : 'ctyp) _ (t1 : 'ctyp)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyArr", [Qast.Loc; t1; t2]) : 'ctyp))];
Some "label", Some Gramext.NonA,
[[Gramext.Snterm
Gramext.Sself],
Gramext.action
(fun (t : 'ctyp) (i : 'a_OPTLABEL)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyOlb", [Qast.Loc; i; t]) : 'ctyp));
[Gramext.Snterm
(Grammar.Entry.obj
Gramext.Stoken ("", ":"); Gramext.Sself],
Gramext.action
(fun (t : 'ctyp) _ (i : 'a_QUESTIONIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyOlb", [Qast.Loc; i; t]) : 'ctyp));
[Gramext.Snterm
(Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e));
Gramext.Sself],
Gramext.action
(fun (t : 'ctyp) (i : 'a_LABEL)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyLab", [Qast.Loc; i; t]) : 'ctyp));
[Gramext.Snterm
(Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e));
Gramext.Stoken ("", ":"); Gramext.Sself],
Gramext.action
(fun (t : 'ctyp) _ (i : 'a_TILDEIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyLab", [Qast.Loc; i; t]) : 'ctyp))];
None, Some Gramext.LeftA,
[[Gramext.Sself; Gramext.Sself],
Gramext.action
(fun (t2 : 'ctyp) (t1 : 'ctyp)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyApp", [Qast.Loc; t1; t2]) : 'ctyp))];
None, Some Gramext.LeftA,
[[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (t2 : 'ctyp) _ (t1 : 'ctyp)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyAcc", [Qast.Loc; t1; t2]) : 'ctyp))];
Some "simple", None,
[[Gramext.Stoken ("", "{");
Gramext.Stoken ("", ";"))],
Gramext.action
(fun (a : 'label_declaration list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "}")],
Gramext.action
- (fun _ (ldl : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
- (Qast.Node ("TyRec", [Qast.Loc; Qast.Bool false; ldl]) : 'ctyp));
+ (fun _ (ldl : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Node ("TyRec", [Qast.Loc; ldl]) : 'ctyp));
[Gramext.Stoken ("", "[");
Gramext.srules
[[Gramext.Slist0sep
Gramext.Stoken ("", "|"))],
Gramext.action
(fun (a : 'constructor_declaration list)
- (loc : Lexing.position * Lexing.position) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
- (a : 'a_list))];
- Gramext.Stoken ("", "]")],
- Gramext.action
- (fun _ (cdl : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
- (Qast.Node ("TySum", [Qast.Loc; Qast.Bool false; cdl]) : 'ctyp));
- [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "{");
- Gramext.srules
- [[Gramext.Slist1sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (label_declaration : 'label_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", ";"))],
- Gramext.action
- (fun (a : 'label_declaration list)
- (loc : Lexing.position * Lexing.position) ->
- (Qast.List a : 'a_list));
- [Gramext.Snterm
- (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
- Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
- (a : 'a_list))];
- Gramext.Stoken ("", "}")],
- Gramext.action
- (fun _ (ldl : 'a_list) _ _
- (loc : Lexing.position * Lexing.position) ->
- (Qast.Node ("TyRec", [Qast.Loc; Qast.Bool true; ldl]) : 'ctyp));
- [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "[");
- Gramext.srules
- [[Gramext.Slist0sep
- (Gramext.Snterm
- (Grammar.Entry.obj
- (constructor_declaration :
- 'constructor_declaration Grammar.Entry.e)),
- Gramext.Stoken ("", "|"))],
- Gramext.action
- (fun (a : 'constructor_declaration list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "]")],
Gramext.action
- (fun _ (cdl : 'a_list) _ _
- (loc : Lexing.position * Lexing.position) ->
- (Qast.Node ("TySum", [Qast.Loc; Qast.Bool true; cdl]) : 'ctyp));
+ (fun _ (cdl : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Node ("TySum", [Qast.Loc; cdl]) : 'ctyp));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (t : 'ctyp) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (t : 'ctyp) _ (_loc : Lexing.position * Lexing.position) ->
(t : 'ctyp));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "*");
Gramext.srules
(Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)),
Gramext.Stoken ("", "*"))],
Gramext.action
- (fun (a : 'ctyp list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'ctyp list)
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (tl : 'a_list) _ (t : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyTup", [Qast.Loc; Qast.Cons (t, tl)]) : 'ctyp));
[Gramext.Snterm
(Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_UIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyUid", [Qast.Loc; i]) : 'ctyp));
[Gramext.Snterm
(Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyLid", [Qast.Loc; i]) : 'ctyp));
[Gramext.Stoken ("", "_")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyAny", [Qast.Loc]) : 'ctyp));
[Gramext.Stoken ("", "'");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyQuo", [Qast.Loc; i]) : 'ctyp))]];
Grammar.Entry.obj
(constructor_declaration : 'constructor_declaration Grammar.Entry.e),
[[Gramext.Snterm
(Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
Gramext.action
- (fun (ci : 'a_UIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (ci : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [Qast.Loc; ci; Qast.List []] :
'constructor_declaration));
[Gramext.Snterm
(Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)),
Gramext.Stoken ("", "and"))],
Gramext.action
- (fun (a : 'ctyp list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'ctyp list)
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
(fun (cal : 'a_list) _ (ci : 'a_UIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [Qast.Loc; ci; cal] : 'constructor_declaration))]];
Grammar.Entry.obj
(label_declaration : 'label_declaration Grammar.Entry.e),
[[Gramext.Stoken ("", "mutable")],
Gramext.action
(fun (x : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Str x : 'e__10))])],
Gramext.action
(fun (a : 'e__10 option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) (mf : 'a_opt) _ (i : 'a_LIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [Qast.Loc; i; o2b mf; t] : 'label_declaration))]];
Grammar.Entry.obj (ident : 'ident Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm
(Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_UIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) ->
(i : 'ident));
[Gramext.Snterm
(Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) ->
(i : 'ident))]];
Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e), None,
[None, Some Gramext.RightA,
Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (j : 'mod_ident) _ (i : 'a_UIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Cons (i, j) : 'mod_ident));
[Gramext.Snterm
(Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.List [i] : 'mod_ident));
[Gramext.Snterm
(Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_UIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.List [i] : 'mod_ident))]];
Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None,
[None, None,
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (a : 'class_type_declaration list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
- (fun (ctd : 'a_list) _ _ (loc : Lexing.position * Lexing.position) ->
+ (fun (ctd : 'a_list) _ _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("StClt", [Qast.Loc; ctd]) : 'str_item));
[Gramext.Stoken ("", "class");
Gramext.srules
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (a : 'class_declaration list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
- (fun (cd : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (cd : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("StCls", [Qast.Loc; cd]) : 'str_item))]];
Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None,
[None, None,
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (a : 'class_type_declaration list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
- (fun (ctd : 'a_list) _ _ (loc : Lexing.position * Lexing.position) ->
+ (fun (ctd : 'a_list) _ _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("SgClt", [Qast.Loc; ctd]) : 'sig_item));
[Gramext.Stoken ("", "class");
Gramext.srules
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (a : 'class_description list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
- (fun (cd : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (cd : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("SgCls", [Qast.Loc; cd]) : 'sig_item))]];
Grammar.Entry.obj
(class_declaration : 'class_declaration Grammar.Entry.e),
[[Gramext.Stoken ("", "virtual")],
Gramext.action
(fun (x : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Str x : 'e__11))])],
Gramext.action
(fun (a : 'e__11 option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Snterm
(Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e));
Gramext.action
(fun (cfb : 'class_fun_binding) (ctp : 'class_type_parameters)
(i : 'a_LIDENT) (vf : 'a_opt)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Record
["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", i;
"ciExp", cfb] :
Gramext.Sself],
Gramext.action
(fun (cfb : 'class_fun_binding) (p : 'ipatt)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CeFun", [Qast.Loc; p; cfb]) : 'class_fun_binding));
[Gramext.Stoken ("", ":");
Gramext.Snterm
(Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))],
Gramext.action
(fun (ce : 'class_expr) _ (ct : 'class_type) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CeTyc", [Qast.Loc; ce; ct]) : 'class_fun_binding));
[Gramext.Stoken ("", "=");
Gramext.Snterm
(Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))],
Gramext.action
- (fun (ce : 'class_expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (ce : 'class_expr) _
+ (_loc : Lexing.position * Lexing.position) ->
(ce : 'class_fun_binding))]];
Grammar.Entry.obj
(class_type_parameters : 'class_type_parameters Grammar.Entry.e),
Gramext.Stoken ("", ","))],
Gramext.action
(fun (a : 'type_parameter list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "]")],
Gramext.action
- (fun _ (tpl : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (tpl : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [Qast.Loc; tpl] : 'class_type_parameters));
[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
+ (fun (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [Qast.Loc; Qast.List []] : 'class_type_parameters))]];
Grammar.Entry.obj (class_fun_def : 'class_fun_def Grammar.Entry.e), None,
[None, None,
Gramext.Snterm
(Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))],
Gramext.action
- (fun (ce : 'class_expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (ce : 'class_expr) _
+ (_loc : Lexing.position * Lexing.position) ->
(ce : 'class_fun_def));
[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
Gramext.Sself],
Gramext.action
(fun (ce : 'class_fun_def) (p : 'ipatt)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CeFun", [Qast.Loc; p; ce]) : 'class_fun_def))]];
Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), None,
[Some "top", None,
[[Gramext.Stoken ("", "rec")],
Gramext.action
(fun (x : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Str x : 'e__12))])],
Gramext.action
(fun (a : 'e__12 option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.srules
[[Gramext.Slist1sep
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (a : 'let_binding list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "in"); Gramext.Sself],
Gramext.action
(fun (ce : 'class_expr) _ (lb : 'a_list) (rf : 'a_opt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CeLet", [Qast.Loc; o2b rf; lb; ce]) : 'class_expr));
[Gramext.Stoken ("", "fun");
Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
(class_fun_def : 'class_fun_def Grammar.Entry.e))],
Gramext.action
(fun (ce : 'class_fun_def) (p : 'ipatt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CeFun", [Qast.Loc; p; ce]) : 'class_expr))];
Some "apply", Some Gramext.NonA,
[[Gramext.Sself;
(Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), "label")],
Gramext.action
(fun (e : 'expr) (ce : 'class_expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CeApp", [Qast.Loc; ce; e]) : 'class_expr))];
Some "simple", None,
[[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (ce : 'class_expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(ce : 'class_expr));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
Gramext.Snterm
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (ct : 'class_type) _ (ce : 'class_expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CeTyc", [Qast.Loc; ce; ct]) : 'class_expr));
[Gramext.Stoken ("", "object");
Gramext.srules
(class_self_patt : 'class_self_patt Grammar.Entry.e)))],
Gramext.action
(fun (a : 'class_self_patt option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Snterm
(Grammar.Entry.obj
Gramext.Stoken ("", "end")],
Gramext.action
(fun _ (cf : 'class_structure) (cspo : 'a_opt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CeStr", [Qast.Loc; cspo; cf]) : 'class_expr));
[Gramext.Snterm
(Grammar.Entry.obj
(class_longident : 'class_longident Grammar.Entry.e))],
Gramext.action
(fun (ci : 'class_longident)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CeCon", [Qast.Loc; ci; Qast.List []]) : 'class_expr));
[Gramext.Snterm
(Grammar.Entry.obj
(Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)),
Gramext.Stoken ("", ","))],
Gramext.action
- (fun (a : 'ctyp list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'ctyp list)
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (ctcl : 'a_list) _ (ci : 'class_longident)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CeCon", [Qast.Loc; ci; ctcl]) : 'class_expr))]];
Grammar.Entry.obj (class_structure : 'class_structure Grammar.Entry.e),
None,
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (cf : 'class_str_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(cf : 'e__13))])],
Gramext.action
(fun (a : 'e__13 list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
- (fun (cf : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (cf : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(cf : 'class_structure))]];
Grammar.Entry.obj (class_self_patt : 'class_self_patt Grammar.Entry.e),
None,
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (t : 'ctyp) _ (p : 'patt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'class_self_patt));
[Gramext.Stoken ("", "(");
Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (p : 'patt) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (p : 'patt) _ (_loc : Lexing.position * Lexing.position) ->
(p : 'class_self_patt))]];
Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e),
None,
[[Gramext.Stoken ("", "initializer");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (se : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (se : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CrIni", [Qast.Loc; se]) : 'class_str_item));
[Gramext.Stoken ("", "type");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t2 : 'ctyp) _ (t1 : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CrCtr", [Qast.Loc; t1; t2]) : 'class_str_item));
[Gramext.Stoken ("", "method");
Gramext.srules
[[Gramext.Stoken ("", "private")],
Gramext.action
(fun (x : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Str x : 'e__17))])],
Gramext.action
(fun (a : 'e__17 option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
Gramext.srules
(Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e)))],
Gramext.action
(fun (a : 'polyt option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Snterm
(Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))],
Gramext.action
(fun (e : 'fun_binding) (topt : 'a_opt) (l : 'label) (pf : 'a_opt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CrMth", [Qast.Loc; l; o2b pf; e; topt]) :
'class_str_item));
[Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual");
[[Gramext.Stoken ("", "private")],
Gramext.action
(fun (x : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Str x : 'e__16))])],
Gramext.action
(fun (a : 'e__16 option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CrVir", [Qast.Loc; l; o2b pf; t]) : 'class_str_item));
[Gramext.Stoken ("", "value");
Gramext.srules
[[Gramext.Stoken ("", "mutable")],
Gramext.action
(fun (x : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Str x : 'e__15))])],
Gramext.action
(fun (a : 'e__15 option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
Gramext.Snterm
(cvalue_binding : 'cvalue_binding Grammar.Entry.e))],
Gramext.action
(fun (e : 'cvalue_binding) (lab : 'label) (mf : 'a_opt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CrVal", [Qast.Loc; lab; o2b mf; e]) :
'class_str_item));
[Gramext.Stoken ("", "inherit");
(as_lident : 'as_lident Grammar.Entry.e)))],
Gramext.action
(fun (a : 'as_lident option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))]],
Gramext.action
(fun (pb : 'a_opt) (ce : 'class_expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CrInh", [Qast.Loc; ce; pb]) : 'class_str_item));
[Gramext.Stoken ("", "declare");
Gramext.srules
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (s : 'class_str_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(s : 'e__14))])],
Gramext.action
(fun (a : 'e__14 list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "end")],
Gramext.action
- (fun _ (st : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (st : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CrDcl", [Qast.Loc; st]) : 'class_str_item))]];
Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e), None,
[None, None,
Gramext.Snterm
(Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_LIDENT) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_LIDENT) _ (_loc : Lexing.position * Lexing.position) ->
(i : 'as_lident))]];
Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
- (fun (t : 'ctyp) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (t : 'ctyp) _ (_loc : Lexing.position * Lexing.position) ->
(t : 'polyt))]];
Grammar.Entry.obj (cvalue_binding : 'cvalue_binding Grammar.Entry.e),
None,
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
(fun (e : 'expr) _ (t : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option None; t]) :
'cvalue_binding));
[Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
(fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option (Some t); t2]) :
'cvalue_binding));
[Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
(fun (e : 'expr) _ (t : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExTyc", [Qast.Loc; e; t]) : 'cvalue_binding));
[Gramext.Stoken ("", "=");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(e : 'cvalue_binding))]];
Grammar.Entry.obj (label : 'label Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm
(Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) ->
(i : 'label))]];
Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None,
[None, None,
(class_self_type : 'class_self_type Grammar.Entry.e)))],
Gramext.action
(fun (a : 'class_self_type option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.srules
[[Gramext.Slist0
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (csf : 'class_sig_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(csf : 'e__18))])],
Gramext.action
(fun (a : 'e__18 list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "end")],
Gramext.action
(fun _ (csf : 'a_list) (cst : 'a_opt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CtSig", [Qast.Loc; cst; csf]) : 'class_type));
[Gramext.Snterm
(Grammar.Entry.obj
(clty_longident : 'clty_longident Grammar.Entry.e))],
Gramext.action
(fun (id : 'clty_longident)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CtCon", [Qast.Loc; id; Qast.List []]) : 'class_type));
[Gramext.Snterm
(Grammar.Entry.obj
(Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)),
Gramext.Stoken ("", ","))],
Gramext.action
- (fun (a : 'ctyp list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'ctyp list)
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (tl : 'a_list) _ (id : 'clty_longident)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CtCon", [Qast.Loc; id; tl]) : 'class_type));
[Gramext.Stoken ("", "[");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", "]"); Gramext.Stoken ("", "->"); Gramext.Sself],
Gramext.action
(fun (ct : 'class_type) _ _ (t : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CtFun", [Qast.Loc; t; ct]) : 'class_type))]];
Grammar.Entry.obj (class_self_type : 'class_self_type Grammar.Entry.e),
None,
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (t : 'ctyp) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (t : 'ctyp) _ (_loc : Lexing.position * Lexing.position) ->
(t : 'class_self_type))]];
Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e),
None,
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t2 : 'ctyp) _ (t1 : 'ctyp) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CgCtr", [Qast.Loc; t1; t2]) : 'class_sig_item));
[Gramext.Stoken ("", "method");
Gramext.srules
[[Gramext.Stoken ("", "private")],
Gramext.action
(fun (x : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Str x : 'e__22))])],
Gramext.action
(fun (a : 'e__22 option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CgMth", [Qast.Loc; l; o2b pf; t]) : 'class_sig_item));
[Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual");
Gramext.srules
[[Gramext.Stoken ("", "private")],
Gramext.action
(fun (x : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Str x : 'e__21))])],
Gramext.action
(fun (a : 'e__21 option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CgVir", [Qast.Loc; l; o2b pf; t]) : 'class_sig_item));
[Gramext.Stoken ("", "value");
Gramext.srules
[[Gramext.Stoken ("", "mutable")],
Gramext.action
(fun (x : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Str x : 'e__20))])],
Gramext.action
(fun (a : 'e__20 option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; t]) : 'class_sig_item));
[Gramext.Stoken ("", "inherit");
Gramext.Snterm
(Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
Gramext.action
- (fun (cs : 'class_type) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (cs : 'class_type) _
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CgInh", [Qast.Loc; cs]) : 'class_sig_item));
[Gramext.Stoken ("", "declare");
Gramext.srules
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (s : 'class_sig_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(s : 'e__19))])],
Gramext.action
(fun (a : 'e__19 list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "end")],
Gramext.action
- (fun _ (st : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (st : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("CgDcl", [Qast.Loc; st]) : 'class_sig_item))]];
Grammar.Entry.obj
(class_description : 'class_description Grammar.Entry.e),
[[Gramext.Stoken ("", "virtual")],
Gramext.action
(fun (x : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Str x : 'e__23))])],
Gramext.action
(fun (a : 'e__23 option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Snterm
(Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e));
Gramext.action
(fun (ct : 'class_type) _ (ctp : 'class_type_parameters)
(n : 'a_LIDENT) (vf : 'a_opt)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Record
["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", n;
"ciExp", ct] :
[[Gramext.Stoken ("", "virtual")],
Gramext.action
(fun (x : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Str x : 'e__24))])],
Gramext.action
(fun (a : 'e__24 option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Snterm
(Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e));
Gramext.action
(fun (cs : 'class_type) _ (ctp : 'class_type_parameters)
(n : 'a_LIDENT) (vf : 'a_opt)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Record
["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", n;
"ciExp", cs] :
(class_longident : 'class_longident Grammar.Entry.e))],
Gramext.action
(fun (i : 'class_longident) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExNew", [Qast.Loc; i]) : 'expr))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
Some (Gramext.Level "."),
Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e))],
Gramext.action
(fun (lab : 'label) _ (e : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExSnd", [Qast.Loc; e; lab]) : 'expr))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
Some (Gramext.Level "simple"),
Gramext.Stoken ("", ";"))],
Gramext.action
(fun (a : 'field_expr list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", ">}")],
Gramext.action
- (fun _ (fel : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (fel : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExOvr", [Qast.Loc; fel]) : 'expr));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":>");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (t : 'ctyp) _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option None; t]) : 'expr));
[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option (Some t); t2]) :
'expr))]];
Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e), None,
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
(fun (e : 'expr) _ (l : 'label)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [l; e] : 'field_expr))]];
Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e),
Some (Gramext.Level "simple"),
Gramext.Stoken ("", ";"))],
Gramext.action
(fun (a : 'field list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.srules
[[Gramext.Sopt
[[Gramext.Stoken ("", "..")],
Gramext.action
(fun (x : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Str x : 'e__25))])],
Gramext.action
(fun (a : 'e__25 option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Stoken ("", ">")],
Gramext.action
(fun _ (v : 'a_opt) (ml : 'a_list) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyObj", [Qast.Loc; ml; o2b v]) : 'ctyp));
[Gramext.Stoken ("", "#");
Gramext.Snterm
(class_longident : 'class_longident Grammar.Entry.e))],
Gramext.action
(fun (id : 'class_longident) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyCls", [Qast.Loc; id]) : 'ctyp))]];
Grammar.Entry.obj (field : 'field Grammar.Entry.e), None,
[None, None,
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (lab : 'a_LIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Tuple [lab; t] : 'field))]];
Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "'");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) ->
(i : 'typevar))]];
Grammar.Entry.obj (clty_longident : 'clty_longident Grammar.Entry.e),
None,
[[Gramext.Snterm
(Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.List [i] : 'clty_longident));
[Gramext.Snterm
(Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (l : 'clty_longident) _ (m : 'a_UIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Cons (m, l) : 'clty_longident))]];
Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e),
None,
[[Gramext.Snterm
(Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_LIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.List [i] : 'class_longident));
[Gramext.Snterm
(Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e));
Gramext.Stoken ("", "."); Gramext.Sself],
Gramext.action
(fun (l : 'class_longident) _ (m : 'a_UIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Cons (m, l) : 'class_longident))]];
Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e),
Some (Gramext.Level "simple"),
(Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e)))],
Gramext.action
(fun (a : 'name_tag list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (ntl : 'a_list) _ (rfl : 'row_field_list) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("TyVrn",
[Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))]) :
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (rfl : 'row_field_list) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("TyVrn",
[Qast.Loc; rfl;
(Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e)))],
Gramext.action
(fun (a : 'name_tag list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (ntl : 'a_list) _ (rfl : 'row_field_list) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("TyVrn",
[Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))]) :
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (rfl : 'row_field_list) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("TyVrn",
[Qast.Loc; rfl;
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (rfl : 'row_field_list) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("TyVrn",
[Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))]) :
Gramext.Stoken ("", "]")],
Gramext.action
(fun _ (rfl : 'row_field_list) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyVrn", [Qast.Loc; rfl; Qast.Option None]) :
'ctyp))]];
Grammar.Entry.obj (row_field_list : 'row_field_list Grammar.Entry.e),
Gramext.Stoken ("", "|"))],
Gramext.action
(fun (a : 'row_field list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
- (fun (rfl : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (rfl : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(rfl : 'row_field_list))]];
Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
- (fun (t : 'ctyp) (loc : Lexing.position * Lexing.position) ->
+ (fun (t : 'ctyp) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("RfInh", [t]) : 'row_field));
[Gramext.Stoken ("", "`");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e));
[[Gramext.Stoken ("", "&")],
Gramext.action
(fun (x : string)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Str x : 'e__26))])],
Gramext.action
(fun (a : 'e__26 option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.srules
[[Gramext.Slist1sep
(Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)),
Gramext.Stoken ("", "&"))],
Gramext.action
- (fun (a : 'ctyp list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'ctyp list)
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
(fun (l : 'a_list) (ao : 'a_opt) _ (i : 'ident) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("RfTag", [i; o2b ao; l]) : 'row_field));
[Gramext.Stoken ("", "`");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("RfTag", [i; Qast.Bool true; Qast.List []]) :
'row_field))]];
Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e), None,
[[Gramext.Stoken ("", "`");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (i : 'ident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) ->
(i : 'name_tag))]];
Grammar.Entry.obj (patt : 'patt Grammar.Entry.e),
Some (Gramext.Level "simple"),
(Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))],
Gramext.action
(fun (a : 'eq_expr option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (eo : 'a_opt) (p : 'patt_tcon) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("PaOlb",
[Qast.Loc; Qast.Str "";
(a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))],
Gramext.action
(fun (i : 'a_QUESTIONIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option None]) : 'patt));
[Gramext.Snterm
(Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e));
(Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))],
Gramext.action
(fun (a : 'eq_expr option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (eo : 'a_opt) (p : 'patt_tcon) _ (i : 'a_OPTLABEL)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("PaOlb",
[Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) :
(Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))],
Gramext.action
(fun (a : 'eq_expr option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (eo : 'a_opt) (p : 'patt_tcon) _ _ (i : 'a_QUESTIONIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("PaOlb",
[Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) :
[Gramext.Snterm
(Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_TILDEIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_TILDEIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option None]) : 'patt));
[Gramext.Snterm
(Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e));
Gramext.Sself],
Gramext.action
(fun (p : 'patt) (i : 'a_LABEL)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) :
'patt));
[Gramext.Snterm
Gramext.Stoken ("", ":"); Gramext.Sself],
Gramext.action
(fun (p : 'patt) _ (i : 'a_TILDEIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) :
'patt));
[Gramext.Stoken ("", "#");
Gramext.Snterm
(Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))],
Gramext.action
- (fun (sl : 'mod_ident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (sl : 'mod_ident) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaTyp", [Qast.Loc; sl]) : 'patt));
[Gramext.Stoken ("", "`");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (s : 'ident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'ident) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaVrn", [Qast.Loc; s]) : 'patt))]];
Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))],
Gramext.action
- (fun (p : 'patt) (loc : Lexing.position * Lexing.position) ->
+ (fun (p : 'patt) (_loc : Lexing.position * Lexing.position) ->
(p : 'patt_tcon));
[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (p : 'patt)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'patt_tcon))]];
Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None,
[None, None,
(Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))],
Gramext.action
(fun (a : 'eq_expr option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("PaOlb",
[Qast.Loc; Qast.Str "";
(a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))],
Gramext.action
(fun (i : 'a_QUESTIONIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option None]) : 'ipatt));
[Gramext.Snterm
(Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e));
(Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))],
Gramext.action
(fun (a : 'eq_expr option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ (i : 'a_OPTLABEL)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("PaOlb",
[Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) :
(Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))],
Gramext.action
(fun (a : 'eq_expr option)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Option a : 'a_opt));
[Gramext.Snterm
(Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_opt) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_opt))];
Gramext.Stoken ("", ")")],
Gramext.action
(fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ _ (i : 'a_QUESTIONIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("PaOlb",
[Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) :
[Gramext.Snterm
(Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_TILDEIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_TILDEIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option None]) : 'ipatt));
[Gramext.Snterm
(Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e));
Gramext.Sself],
Gramext.action
(fun (p : 'ipatt) (i : 'a_LABEL)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) :
'ipatt));
[Gramext.Snterm
Gramext.Stoken ("", ":"); Gramext.Sself],
Gramext.action
(fun (p : 'ipatt) _ (i : 'a_TILDEIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) :
'ipatt))]];
Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e), None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))],
Gramext.action
- (fun (p : 'ipatt) (loc : Lexing.position * Lexing.position) ->
+ (fun (p : 'ipatt) (_loc : Lexing.position * Lexing.position) ->
(p : 'ipatt_tcon));
[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e));
Gramext.Stoken ("", ":");
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (p : 'ipatt)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'ipatt_tcon))]];
Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "=");
Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) ->
(e : 'eq_expr))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
Some (Gramext.After "apply"),
(a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))],
Gramext.action
(fun (i : 'a_QUESTIONIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option None]) : 'expr));
[Gramext.Snterm
(Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e));
Gramext.Sself],
Gramext.action
(fun (e : 'expr) (i : 'a_OPTLABEL)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option (Some e)]) :
'expr));
[Gramext.Snterm
Gramext.Stoken ("", ":"); Gramext.Sself],
Gramext.action
(fun (e : 'expr) _ (i : 'a_QUESTIONIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option (Some e)]) :
'expr));
[Gramext.Snterm
(Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))],
Gramext.action
- (fun (i : 'a_TILDEIDENT) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : 'a_TILDEIDENT) (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option None]) : 'expr));
[Gramext.Snterm
(Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e));
Gramext.Sself],
Gramext.action
(fun (e : 'expr) (i : 'a_LABEL)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option (Some e)]) :
'expr));
[Gramext.Snterm
Gramext.Stoken ("", ":"); Gramext.Sself],
Gramext.action
(fun (e : 'expr) _ (i : 'a_TILDEIDENT)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option (Some e)]) :
'expr))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
[[Gramext.Stoken ("", "`");
Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))],
Gramext.action
- (fun (s : 'ident) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (s : 'ident) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExVrn", [Qast.Loc; s]) : 'expr))]];
Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e),
None,
[None, None,
[[Gramext.Stoken ("", "downto")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Bool false : 'direction_flag));
[Gramext.Stoken ("", "to")],
Gramext.action
- (fun _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Bool true : 'direction_flag))]];
Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e),
Some (Gramext.Level "simple"),
(Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e)))],
Gramext.action
(fun (a : 'name_tag list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "|]")],
Gramext.action
(fun _ (ntl : 'a_list) _ (rfl : 'row_field_list) _ _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("TyVrn",
[Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))]) :
Gramext.Stoken ("", "|]")],
Gramext.action
(fun _ (rfl : 'row_field_list) _ _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("TyVrn",
[Qast.Loc; rfl;
Gramext.Stoken ("", "|]")],
Gramext.action
(fun _ (rfl : 'row_field_list) _ _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node
("TyVrn",
[Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))]) :
Gramext.Stoken ("", "|]")],
Gramext.action
(fun _ (rfl : 'row_field_list) _ _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyVrn", [Qast.Loc; rfl; Qast.Option None]) :
'ctyp))]];
Grammar.Entry.obj (warning_variant : 'warning_variant Grammar.Entry.e),
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
+ (fun (_loc : Lexing.position * Lexing.position) ->
(warn_variant Qast.Loc : 'warning_variant))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
Some (Gramext.Level "top"),
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (e : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(e : 'e__29))])],
Gramext.action
(fun (a : 'e__29 list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Snterm
(Grammar.Entry.obj
Gramext.Stoken ("", "done")],
Gramext.action
(fun _ _ (seq : 'a_list) _ (e : 'expr) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExWhi", [Qast.Loc; e; seq]) : 'expr));
[Gramext.Stoken ("", "for");
Gramext.Snterm
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (e : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(e : 'e__28))])],
Gramext.action
(fun (a : 'e__28 list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Snterm
(Grammar.Entry.obj
Gramext.action
(fun _ _ (seq : 'a_list) _ (e2 : 'expr) (df : 'direction_flag)
(e1 : 'expr) _ (i : 'a_LIDENT) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExFor", [Qast.Loc; i; e1; e2; df; seq]) : 'expr));
[Gramext.Stoken ("", "do");
Gramext.srules
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (e : 'expr)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(e : 'e__27))])],
Gramext.action
(fun (a : 'e__27 list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "return");
Gramext.Snterm
Gramext.Sself],
Gramext.action
(fun (e : 'expr) _ _ (seq : 'a_list) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExSeq", [Qast.Loc; append_elem seq e]) : 'expr))]];
Grammar.Entry.obj (warning_sequence : 'warning_sequence Grammar.Entry.e),
None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
+ (fun (_loc : Lexing.position * Lexing.position) ->
(warn_sequence Qast.Loc : 'warning_sequence))]];
Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("ANTIQUOT", "list")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "list" loc a : 'sequence))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "list" _loc a : 'sequence))]];
Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'expr_ident))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'expr_ident))]];
Grammar.Entry.obj (patt_label_ident : 'patt_label_ident Grammar.Entry.e),
Some (Gramext.Level "simple"),
[None, None,
[[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'patt_label_ident))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'patt_label_ident))]];
Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("ANTIQUOT", "when")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "when" loc a : 'when_expr_opt))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "when" _loc a : 'when_expr_opt))]];
Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'mod_ident))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'mod_ident))]];
Grammar.Entry.obj (clty_longident : 'clty_longident Grammar.Entry.e),
None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'clty_longident))]];
Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e),
None,
[None, None,
[[Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'class_longident))]];
Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e),
None,
[None, None,
[[Gramext.Stoken ("ANTIQUOT", "to")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "to" loc a : 'direction_flag))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "to" _loc a : 'direction_flag))]];
Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e),
Some (Gramext.Level "simple"),
[None, None,
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (cf : 'class_str_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(cf : 'e__30))])],
Gramext.action
(fun (a : 'e__30 list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "end")],
Gramext.action
(fun _ (csl : 'a_list) _ (x : string) _
- (loc : Lexing.position * Lexing.position) ->
- (let _ = warn_antiq loc "3.05" in
+ (_loc : Lexing.position * Lexing.position) ->
+ (let _ = warn_antiq _loc "3.05" in
Qast.Node
("CeStr",
[Qast.Loc; Qast.Option None;
- Qast.Cons (antiquot "" loc x, csl)]) :
+ Qast.Cons (antiquot "" _loc x, csl)]) :
'class_expr));
[Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", "");
Gramext.Snterm
Gramext.Stoken ("", "end")],
Gramext.action
(fun _ (cf : 'class_structure) (x : string) _
- (loc : Lexing.position * Lexing.position) ->
- (let _ = warn_antiq loc "3.05" in
- Qast.Node ("CeStr", [Qast.Loc; antiquot "" loc x; cf]) :
+ (_loc : Lexing.position * Lexing.position) ->
+ (let _ = warn_antiq _loc "3.05" in
+ Qast.Node ("CeStr", [Qast.Loc; antiquot "" _loc x; cf]) :
'class_expr))]];
Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None,
[None, None,
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (csf : 'class_sig_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(csf : 'e__32))])],
Gramext.action
(fun (a : 'e__32 list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "end")],
Gramext.action
(fun _ (csf : 'a_list) _ (x : string) _
- (loc : Lexing.position * Lexing.position) ->
- (let _ = warn_antiq loc "3.05" in
+ (_loc : Lexing.position * Lexing.position) ->
+ (let _ = warn_antiq _loc "3.05" in
Qast.Node
("CtSig",
[Qast.Loc; Qast.Option None;
- Qast.Cons (antiquot "" loc x, csf)]) :
+ Qast.Cons (antiquot "" _loc x, csf)]) :
'class_type));
[Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", "");
Gramext.srules
Gramext.Stoken ("", ";")],
Gramext.action
(fun _ (csf : 'class_sig_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(csf : 'e__31))])],
Gramext.action
(fun (a : 'e__31 list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "end")],
Gramext.action
(fun _ (csf : 'a_list) (x : string) _
- (loc : Lexing.position * Lexing.position) ->
- (let _ = warn_antiq loc "3.05" in
- Qast.Node ("CtSig", [Qast.Loc; antiquot "" loc x; csf]) :
+ (_loc : Lexing.position * Lexing.position) ->
+ (let _ = warn_antiq _loc "3.05" in
+ Qast.Node ("CtSig", [Qast.Loc; antiquot "" _loc x; csf]) :
'class_type))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
Some (Gramext.Level "top"),
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (a : 'let_binding list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "in"); Gramext.Sself],
Gramext.action
(fun (x : 'expr) _ (l : 'a_list) (r : string) _
- (loc : Lexing.position * Lexing.position) ->
- (let _ = warn_antiq loc "3.06+18" in
- Qast.Node ("ExLet", [Qast.Loc; antiquot "rec" loc r; l; x]) :
+ (_loc : Lexing.position * Lexing.position) ->
+ (let _ = warn_antiq _loc "3.06+18" in
+ Qast.Node ("ExLet", [Qast.Loc; antiquot "rec" _loc r; l; x]) :
'expr))]];
Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e),
Some (Gramext.Level "top"),
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (a : 'let_binding list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))]],
Gramext.action
(fun (l : 'a_list) (r : string) _
- (loc : Lexing.position * Lexing.position) ->
- (let _ = warn_antiq loc "3.06+18" in
- Qast.Node ("StVal", [Qast.Loc; antiquot "rec" loc r; l]) :
+ (_loc : Lexing.position * Lexing.position) ->
+ (let _ = warn_antiq _loc "3.06+18" in
+ Qast.Node ("StVal", [Qast.Loc; antiquot "rec" _loc r; l]) :
'str_item))]];
Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e),
Some (Gramext.Level "top"),
Gramext.Stoken ("", "and"))],
Gramext.action
(fun (a : 'let_binding list)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.List a : 'a_list));
[Gramext.Snterm
(Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) ->
(a : 'a_list))];
Gramext.Stoken ("", "in"); Gramext.Sself],
Gramext.action
(fun (ce : 'class_expr) _ (lb : 'a_list) (r : string) _
- (loc : Lexing.position * Lexing.position) ->
- (let _ = warn_antiq loc "3.06+18" in
- Qast.Node ("CeLet", [Qast.Loc; antiquot "rec" loc r; lb; ce]) :
+ (_loc : Lexing.position * Lexing.position) ->
+ (let _ = warn_antiq _loc "3.06+18" in
+ Qast.Node ("CeLet", [Qast.Loc; antiquot "rec" _loc r; lb; ce]) :
'class_expr))]];
Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e),
None,
(cvalue_binding : 'cvalue_binding Grammar.Entry.e))],
Gramext.action
(fun (e : 'cvalue_binding) (lab : 'label) (mf : string) _
- (loc : Lexing.position * Lexing.position) ->
- (let _ = warn_antiq loc "3.06+18" in
- Qast.Node ("CrVal", [Qast.Loc; lab; antiquot "mut" loc mf; e]) :
+ (_loc : Lexing.position * Lexing.position) ->
+ (let _ = warn_antiq _loc "3.06+18" in
+ Qast.Node ("CrVal", [Qast.Loc; lab; antiquot "mut" _loc mf; e]) :
'class_str_item));
[Gramext.Stoken ("", "inherit");
Gramext.Snterm
Gramext.Stoken ("ANTIQUOT", "as")],
Gramext.action
(fun (pb : string) (ce : 'class_expr) _
- (loc : Lexing.position * Lexing.position) ->
- (let _ = warn_antiq loc "3.06+18" in
- Qast.Node ("CrInh", [Qast.Loc; ce; antiquot "as" loc pb]) :
+ (_loc : Lexing.position * Lexing.position) ->
+ (let _ = warn_antiq _loc "3.06+18" in
+ Qast.Node ("CrInh", [Qast.Loc; ce; antiquot "as" _loc pb]) :
'class_str_item))]];
Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e),
None,
Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
Gramext.action
(fun (t : 'ctyp) _ (l : 'label) (mf : string) _
- (loc : Lexing.position * Lexing.position) ->
- (let _ = warn_antiq loc "3.06+18" in
- Qast.Node ("CgVal", [Qast.Loc; l; antiquot "mut" loc mf; t]) :
+ (_loc : Lexing.position * Lexing.position) ->
+ (let _ = warn_antiq _loc "3.06+18" in
+ Qast.Node ("CgVal", [Qast.Loc; l; antiquot "mut" _loc mf; t]) :
'class_sig_item))]]]);;
Grammar.extend
(Grammar.Entry.obj (dir_param : 'dir_param Grammar.Entry.e))],
Gramext.action
(fun (dp : 'dir_param) (n : 'a_LIDENT) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("StDir", [Qast.Loc; n; dp]) : 'str_item))]];
Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None,
[None, None,
(Grammar.Entry.obj (dir_param : 'dir_param Grammar.Entry.e))],
Gramext.action
(fun (dp : 'dir_param) (n : 'a_LIDENT) _
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("SgDir", [Qast.Loc; n; dp]) : 'sig_item))]];
Grammar.Entry.obj (dir_param : 'dir_param Grammar.Entry.e), None,
[None, None,
[[],
Gramext.action
- (fun (loc : Lexing.position * Lexing.position) ->
+ (fun (_loc : Lexing.position * Lexing.position) ->
(Qast.Option None : 'dir_param));
[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))],
Gramext.action
- (fun (e : 'expr) (loc : Lexing.position * Lexing.position) ->
+ (fun (e : 'expr) (_loc : Lexing.position * Lexing.position) ->
(Qast.Option (Some e) : 'dir_param));
[Gramext.Stoken ("ANTIQUOT", "opt")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "opt" loc a : 'dir_param))]]]);;
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "opt" _loc a : 'dir_param))]]]);;
(* Antiquotations *)
[None, None,
[[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'module_expr));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'module_expr));
[Gramext.Stoken ("ANTIQUOT", "mexp")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "mexp" loc a : 'module_expr))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "mexp" _loc a : 'module_expr))]];
Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e),
Some (Gramext.Level "top"),
[None, None,
[[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'str_item));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'str_item));
[Gramext.Stoken ("ANTIQUOT", "stri")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "stri" loc a : 'str_item))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "stri" _loc a : 'str_item))]];
Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e),
Some (Gramext.Level "simple"),
[None, None,
[[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'module_type));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'module_type));
[Gramext.Stoken ("ANTIQUOT", "mtyp")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "mtyp" loc a : 'module_type))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "mtyp" _loc a : 'module_type))]];
Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e),
Some (Gramext.Level "top"),
[None, None,
[[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'sig_item));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'sig_item));
[Gramext.Stoken ("ANTIQUOT", "sigi")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "sigi" loc a : 'sig_item))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "sigi" _loc a : 'sig_item))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
Some (Gramext.Level "simple"),
[None, None,
Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (el : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (el : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExTup", [Qast.Loc; el]) : 'expr));
[Gramext.Stoken ("ANTIQUOT", "anti")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (Qast.Node ("ExAnt", [Qast.Loc; antiquot "anti" loc a]) : 'expr));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Node ("ExAnt", [Qast.Loc; antiquot "anti" _loc a]) : 'expr));
[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'expr));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'expr));
[Gramext.Stoken ("ANTIQUOT", "exp")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "exp" loc a : 'expr))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "exp" _loc a : 'expr))]];
Grammar.Entry.obj (patt : 'patt Grammar.Entry.e),
Some (Gramext.Level "simple"),
[None, None,
Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (pl : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (pl : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaTup", [Qast.Loc; pl]) : 'patt));
[Gramext.Stoken ("ANTIQUOT", "anti")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (Qast.Node ("PaAnt", [Qast.Loc; antiquot "anti" loc a]) : 'patt));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Node ("PaAnt", [Qast.Loc; antiquot "anti" _loc a]) : 'patt));
[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'patt));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'patt));
[Gramext.Stoken ("ANTIQUOT", "pat")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "pat" loc a : 'patt))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "pat" _loc a : 'patt))]];
Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "(");
Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (pl : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (pl : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaTup", [Qast.Loc; pl]) : 'ipatt));
[Gramext.Stoken ("ANTIQUOT", "anti")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (Qast.Node ("PaAnt", [Qast.Loc; antiquot "anti" loc a]) : 'ipatt));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (Qast.Node ("PaAnt", [Qast.Loc; antiquot "anti" _loc a]) : 'ipatt));
[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'ipatt));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'ipatt));
[Gramext.Stoken ("ANTIQUOT", "pat")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "pat" loc a : 'ipatt))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "pat" _loc a : 'ipatt))]];
Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e),
Some (Gramext.Level "simple"),
[None, None,
Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e));
Gramext.Stoken ("", ")")],
Gramext.action
- (fun _ (tl : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (tl : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("TyTup", [Qast.Loc; tl]) : 'ctyp));
[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'ctyp));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'ctyp));
[Gramext.Stoken ("ANTIQUOT", "typ")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "typ" loc a : 'ctyp))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "typ" _loc a : 'ctyp))]];
Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e),
Some (Gramext.Level "simple"),
[None, None,
[[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'class_expr))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'class_expr))]];
Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'class_str_item))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'class_str_item))]];
Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'class_sig_item))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'class_sig_item))]];
Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'class_type))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'class_type))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
Some (Gramext.Level "simple"),
[None, None,
Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e));
Gramext.Stoken ("", ">}")],
Gramext.action
- (fun _ (fel : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun _ (fel : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("ExOvr", [Qast.Loc; fel]) : 'expr))]];
Grammar.Entry.obj (patt : 'patt Grammar.Entry.e),
Some (Gramext.Level "simple"),
[[Gramext.Stoken ("", "#");
Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))],
Gramext.action
- (fun (a : 'a_list) _ (loc : Lexing.position * Lexing.position) ->
+ (fun (a : 'a_list) _ (_loc : Lexing.position * Lexing.position) ->
(Qast.Node ("PaTyp", [Qast.Loc; a]) : 'patt))]];
Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("ANTIQUOT", "list")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "list" loc a : 'a_list))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "list" _loc a : 'a_list))]];
Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("ANTIQUOT", "opt")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "opt" loc a : 'a_opt))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "opt" _loc a : 'a_opt))]];
Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("UIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
(Qast.Str i : 'a_UIDENT));
[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'a_UIDENT));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'a_UIDENT));
[Gramext.Stoken ("ANTIQUOT", "uid")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "uid" loc a : 'a_UIDENT))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "uid" _loc a : 'a_UIDENT))]];
Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("LIDENT", "")],
Gramext.action
- (fun (i : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (i : string) (_loc : Lexing.position * Lexing.position) ->
(Qast.Str i : 'a_LIDENT));
[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'a_LIDENT));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'a_LIDENT));
[Gramext.Stoken ("ANTIQUOT", "lid")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "lid" loc a : 'a_LIDENT))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "lid" _loc a : 'a_LIDENT))]];
Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("INT", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
(Qast.Str s : 'a_INT));
[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'a_INT));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'a_INT));
[Gramext.Stoken ("ANTIQUOT", "int")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "int" loc a : 'a_INT))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "int" _loc a : 'a_INT))]];
Grammar.Entry.obj (a_INT32 : 'a_INT32 Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("INT32", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
(Qast.Str s : 'a_INT32));
[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'a_INT32));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'a_INT32));
[Gramext.Stoken ("ANTIQUOT", "int32")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "int32" loc a : 'a_INT32))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "int32" _loc a : 'a_INT32))]];
Grammar.Entry.obj (a_INT64 : 'a_INT64 Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("INT64", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
(Qast.Str s : 'a_INT64));
[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'a_INT64));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'a_INT64));
[Gramext.Stoken ("ANTIQUOT", "int64")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "int64" loc a : 'a_INT64))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "int64" _loc a : 'a_INT64))]];
Grammar.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("NATIVEINT", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
(Qast.Str s : 'a_NATIVEINT));
[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'a_NATIVEINT));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'a_NATIVEINT));
[Gramext.Stoken ("ANTIQUOT", "nativeint")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "nativeint" loc a : 'a_NATIVEINT))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "nativeint" _loc a : 'a_NATIVEINT))]];
Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("FLOAT", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
(Qast.Str s : 'a_FLOAT));
[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'a_FLOAT));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'a_FLOAT));
[Gramext.Stoken ("ANTIQUOT", "flo")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "flo" loc a : 'a_FLOAT))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "flo" _loc a : 'a_FLOAT))]];
Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("STRING", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
(Qast.Str s : 'a_STRING));
[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'a_STRING));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'a_STRING));
[Gramext.Stoken ("ANTIQUOT", "str")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "str" loc a : 'a_STRING))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "str" _loc a : 'a_STRING))]];
Grammar.Entry.obj (a_CHAR : 'a_CHAR Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("CHAR", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
(Qast.Str s : 'a_CHAR));
[Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'a_CHAR));
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'a_CHAR));
[Gramext.Stoken ("ANTIQUOT", "chr")],
Gramext.action
- (fun (a : string) (loc : Lexing.position * Lexing.position) ->
- (antiquot "chr" loc a : 'a_CHAR))]];
+ (fun (a : string) (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "chr" _loc a : 'a_CHAR))]];
Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("TILDEIDENT", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
(Qast.Str s : 'a_TILDEIDENT));
[Gramext.Stoken ("", "~"); Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) _ (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'a_TILDEIDENT))]];
+ (fun (a : string) _ (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'a_TILDEIDENT))]];
Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("LABEL", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
(Qast.Str s : 'a_LABEL))]];
Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e),
None,
[None, None,
[[Gramext.Stoken ("QUESTIONIDENT", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
(Qast.Str s : 'a_QUESTIONIDENT));
[Gramext.Stoken ("", "?"); Gramext.Stoken ("ANTIQUOT", "")],
Gramext.action
- (fun (a : string) _ (loc : Lexing.position * Lexing.position) ->
- (antiquot "" loc a : 'a_QUESTIONIDENT))]];
+ (fun (a : string) _ (_loc : Lexing.position * Lexing.position) ->
+ (antiquot "" _loc a : 'a_QUESTIONIDENT))]];
Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("OPTLABEL", "")],
Gramext.action
- (fun (s : string) (loc : Lexing.position * Lexing.position) ->
+ (fun (s : string) (_loc : Lexing.position * Lexing.position) ->
(Qast.Str s : 'a_OPTLABEL))]]];;
let apply_entry e =
(Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e));
Gramext.Stoken ("EOI", "")],
Gramext.action
- (fun _ (x : 'sig_item) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (x : 'sig_item) (_loc : Lexing.position * Lexing.position) ->
(x : 'sig_item_eoi))]]];
Quotation.add "sig_item" (apply_entry sig_item_eoi);;
(Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e));
Gramext.Stoken ("EOI", "")],
Gramext.action
- (fun _ (x : 'str_item) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (x : 'str_item) (_loc : Lexing.position * Lexing.position) ->
(x : 'str_item_eoi))]]];
Quotation.add "str_item" (apply_entry str_item_eoi);;
[[Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e));
Gramext.Stoken ("EOI", "")],
Gramext.action
- (fun _ (x : 'ctyp) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (x : 'ctyp) (_loc : Lexing.position * Lexing.position) ->
(x : 'ctyp_eoi))]]];
Quotation.add "ctyp" (apply_entry ctyp_eoi);;
[[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e));
Gramext.Stoken ("EOI", "")],
Gramext.action
- (fun _ (x : 'patt) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (x : 'patt) (_loc : Lexing.position * Lexing.position) ->
(x : 'patt_eoi))]]];
Quotation.add "patt" (apply_entry patt_eoi);;
[[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e));
Gramext.Stoken ("EOI", "")],
Gramext.action
- (fun _ (x : 'expr) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (x : 'expr) (_loc : Lexing.position * Lexing.position) ->
(x : 'expr_eoi))]]];
Quotation.add "expr" (apply_entry expr_eoi);;
(Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e));
Gramext.Stoken ("EOI", "")],
Gramext.action
- (fun _ (x : 'module_type) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (x : 'module_type) (_loc : Lexing.position * Lexing.position) ->
(x : 'module_type_eoi))]]];
Quotation.add "module_type" (apply_entry module_type_eoi);;
(Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e));
Gramext.Stoken ("EOI", "")],
Gramext.action
- (fun _ (x : 'module_expr) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (x : 'module_expr) (_loc : Lexing.position * Lexing.position) ->
(x : 'module_expr_eoi))]]];
Quotation.add "module_expr" (apply_entry module_expr_eoi);;
(Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e));
Gramext.Stoken ("EOI", "")],
Gramext.action
- (fun _ (x : 'class_type) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (x : 'class_type) (_loc : Lexing.position * Lexing.position) ->
(x : 'class_type_eoi))]]];
Quotation.add "class_type" (apply_entry class_type_eoi);;
(Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e));
Gramext.Stoken ("EOI", "")],
Gramext.action
- (fun _ (x : 'class_expr) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (x : 'class_expr) (_loc : Lexing.position * Lexing.position) ->
(x : 'class_expr_eoi))]]];
Quotation.add "class_expr" (apply_entry class_expr_eoi);;
Gramext.Stoken ("EOI", "")],
Gramext.action
(fun _ (x : 'class_sig_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(x : 'class_sig_item_eoi))]]];
Quotation.add "class_sig_item" (apply_entry class_sig_item_eoi);;
Gramext.Stoken ("EOI", "")],
Gramext.action
(fun _ (x : 'class_str_item)
- (loc : Lexing.position * Lexing.position) ->
+ (_loc : Lexing.position * Lexing.position) ->
(x : 'class_str_item_eoi))]]];
Quotation.add "class_str_item" (apply_entry class_str_item_eoi);;
(Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e));
Gramext.Stoken ("EOI", "")],
Gramext.action
- (fun _ (x : 'with_constr) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (x : 'with_constr) (_loc : Lexing.position * Lexing.position) ->
(x : 'with_constr_eoi))]]];
Quotation.add "with_constr" (apply_entry with_constr_eoi);;
(Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e));
Gramext.Stoken ("EOI", "")],
Gramext.action
- (fun _ (x : 'row_field) (loc : Lexing.position * Lexing.position) ->
+ (fun _ (x : 'row_field) (_loc : Lexing.position * Lexing.position) ->
(x : 'row_field_eoi))]]];
Quotation.add "row_field" (apply_entry row_field_eoi);;
-# $Id: Makefile,v 1.6 2004/05/12 15:22:48 mauny Exp $
+# $Id: Makefile,v 1.8 2004/11/30 18:57:03 doligez Exp $
include ../config/Makefile
-# $Id: Makefile,v 1.15.4.6 2004/07/28 13:11:07 mauny Exp $
+# $Id: Makefile,v 1.20 2004/11/30 18:57:03 doligez Exp $
include ../config/Makefile
(* *)
(***********************************************************************)
-(* $Id: odyl.ml,v 1.2.6.1 2004/06/23 13:31:38 mauny Exp $ *)
+(* $Id: odyl.ml,v 1.3 2004/07/13 12:19:14 xleroy Exp $ *)
value apply_load () =
let i = ref 1 in
(* *)
(***********************************************************************)
-(* $Id: odyl_main.ml,v 1.4.4.1 2004/06/23 14:43:58 mauny Exp $ *)
+(* $Id: odyl_main.ml,v 1.5 2004/07/13 12:19:14 xleroy Exp $ *)
value go = ref (fun () -> ());
value name = ref "odyl";
#!/bin/sh
-# $Id: apply.sh,v 1.4.4.1 2004/07/07 16:22:26 mauny Exp $
+# $Id: apply.sh,v 1.5 2004/07/13 12:19:15 xleroy Exp $
P4TOP=..
ARGS1=
-# $Id: Makefile,v 1.12.2.1 2004/07/09 15:10:57 mauny Exp $
+# $Id: Makefile,v 1.15 2004/11/30 18:57:03 doligez Exp $
include ../config/Makefile
(* *)
(***********************************************************************)
-(* $Id: camlp4_top.ml,v 1.13.2.1 2004/10/07 09:18:13 mauny Exp $ *)
+(* $Id: camlp4_top.ml,v 1.17 2005/10/21 15:51:42 mauny Exp $ *)
open Parsetree;
open Lexing;
lb.lex_curr_pos := lb.lex_curr_pos + 1;
Some c
}
- })
- in
- try f cs with
+ }) in
+ let parse_fun = f lb.lex_curr_p in
+ try parse_fun cs with
[ Exc_located _ (Sys.Break as x) -> raise x
| End_of_file as x -> raise x
| x ->
value first_phrase = ref True;
-value toplevel_phrase cs =
+value toplevel_phrase pos cs =
do {
if Sys.interactive.val && first_phrase.val then do {
first_phrase.val := False;
- Printf.eprintf "\tCamlp4 Parsing version %s\n\n" Pcaml.version;
- flush stderr;
+ Printf.printf "\tCamlp4 Parsing version %s\n\n%!" Pcaml.version;
}
else ();
match Grammar.Entry.parse Pcaml.top_phrase cs with
}
;
-value use_file cs =
+value use_file pos cs =
let v = Pcaml.input_file.val in
let (bolpos,lnum,fname) = Pcaml.position.val in
let restore =
} in
do {
Pcaml.input_file.val := Toploop.input_name.val;
- bolpos.val := 0; lnum.val := 1; fname.val := Toploop.input_name.val;
+ bolpos.val := pos.pos_bol; lnum.val := pos.pos_lnum; fname.val := Toploop.input_name.val;
try
let (pl0, eoi) =
loop () where rec loop () =
Pcaml.warning.val :=
fun loc txt ->
Toploop.print_warning (Ast2pt.mkloc loc) Format.err_formatter
- (Warnings.Other txt);
+ (Warnings.Camlp4 txt);
(* *)
(***********************************************************************)
-(* $Id: rprint.ml,v 1.14.2.1 2005/06/17 12:25:57 mauny Exp $ *)
+(* $Id: rprint.ml,v 1.18 2005/06/29 04:11:26 garrigue Exp $ *)
open Format;
open Outcometree;
print_ident id
| Otyp_manifest ty1 ty2 ->
fprintf ppf "@[<2>%a ==@ %a@]" print_out_type ty1 print_out_type ty2
- | Otyp_sum constrs priv ->
- fprintf ppf "@[<hv>%a[ %a ]@]" print_private priv
+ | Otyp_sum constrs ->
+ fprintf ppf "@[<hv>[ %a ]@]"
(print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
- | Otyp_record lbls priv ->
- fprintf ppf "@[<hv 2>%a{ %a }@]" print_private priv
+ | Otyp_record lbls ->
+ fprintf ppf "@[<hv 2>{ %a }@]"
(print_list print_out_label (fun ppf -> fprintf ppf ";@ ")) lbls
| Otyp_abstract -> fprintf ppf "'abstract"
| Otyp_alias _ _ | Otyp_poly _ _
| Otyp_arrow _ _ _ | Otyp_constr _ [_ :: _] as ty ->
fprintf ppf "@[<1>(%a)@]" print_out_type ty ]
- and print_private ppf =
- fun
- [ Asttypes.Public -> ()
- | Asttypes.Private -> fprintf ppf "private "
- ]
in
print_tkind ppf
and print_out_constr ppf (name, tyl) =
fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl ]
;
+value type_parameter ppf (ty, (co, cn)) =
+ fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "")
+ ty
+;
+
value print_out_class_params ppf =
fun
[ [] -> ()
| tyl ->
fprintf ppf "@[<1>[%a]@]@ "
- (print_list (fun ppf x -> fprintf ppf "'%s" x)
- (fun ppf -> fprintf ppf ", "))
+ (print_list type_parameter (fun ppf -> fprintf ppf ", "))
tyl ]
;
fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name
Toploop.print_out_type.val ty pr_prims prims ]
-and print_out_type_decl kwd ppf (name, args, ty, constraints) =
+and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) =
let constrain ppf (ty, ty') =
fprintf ppf "@ @[<2>constraint %a =@ %a@]" Toploop.print_out_type.val ty
Toploop.print_out_type.val ty'
in
let print_constraints ppf params = List.iter (constrain ppf) params in
- let type_parameter ppf (ty, (co, cn)) =
- fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "")
- ty
- in
let type_defined ppf =
match args with
[ [] -> fprintf ppf "%s" name
| _ ->
fprintf ppf "%s@ %a" name
(print_list type_parameter (fun ppf -> fprintf ppf "@ ")) args ]
+ and print_kind ppf ty =
+ fprintf ppf "%s@ %a"
+ (if priv = Asttypes.Private then " private" else "")
+ Toploop.print_out_type.val ty
+ in
+ let print_types ppf = fun
+ [ Otyp_manifest ty1 ty2 ->
+ fprintf ppf "@ @[<2>%a ==%a@]"
+ Toploop.print_out_type.val ty1
+ print_kind ty2
+ | ty -> print_kind ppf ty ]
in
- fprintf ppf "@[<2>@[<hv 2>@[%s %t@] =@ %a@]%a@]" kwd type_defined
- Toploop.print_out_type.val ty print_constraints constraints
+ fprintf ppf "@[<2>@[<hv 2>@[%s %t@] =%a@]%a@]" kwd type_defined
+ print_types ty print_constraints constraints
;
(* Phrases *)
(* ../../../LICENSE. *)
(* *)
(***********************************************************************)
-(* $Id: pa_format.ml,v 1.1.2.1 2004/07/07 16:22:27 mauny Exp $ *)
+(* $Id: pa_format.ml,v 1.2 2004/07/13 12:25:05 xleroy Exp $ *)
open Pcaml;
(* ../../../LICENSE. *)
(* *)
(***********************************************************************)
-(* $Id: pa_lefteval.ml,v 1.1.2.1 2004/07/07 16:22:28 mauny Exp $ *)
+(* $Id: pa_lefteval.ml,v 1.2 2004/07/13 12:25:06 xleroy Exp $ *)
value not_impl name x =
let desc =
(* ../../../LICENSE. *)
(* *)
(***********************************************************************)
-(* $Id: pa_ocamllex.ml,v 1.1.2.1 2004/07/07 16:22:29 mauny Exp $ *)
+(* $Id: pa_ocamllex.ml,v 1.2 2004/07/13 12:25:06 xleroy Exp $ *)
open Syntax
open Lexgen
(* *)
(***********************************************************************)
-(* $Id: pa_olabl.ml,v 1.1.2.1 2004/07/07 16:22:31 mauny Exp $ *)
+(* $Id: pa_olabl.ml,v 1.2 2004/07/13 12:25:07 xleroy Exp $ *)
module Plexer =
struct
; ../../../LICENSE.
;
; **********************************************************************
-; $Id: pa_scheme.sc,v 1.1.2.1 2004/07/07 16:22:33 mauny Exp $
+; $Id: pa_scheme.sc,v 1.2 2004/07/13 12:25:08 xleroy Exp $
(open Pcaml)
(open Stdpp)
(* ../../../LICENSE. *)
(* *)
(***********************************************************************)
-(* $Id: pr_scheme.ml,v 1.1.2.1 2004/07/07 16:22:33 mauny Exp $ *)
+(* $Id: pr_scheme.ml,v 1.2 2004/07/13 12:25:08 xleroy Exp $ *)
open Pcaml;
open Format;
(* ../../../LICENSE. *)
(* *)
(***********************************************************************)
-(* $Id: pr_schp_main.ml,v 1.1.2.1 2004/07/07 16:22:34 mauny Exp $ *)
+(* $Id: pr_schp_main.ml,v 1.2 2004/07/13 12:25:09 xleroy Exp $ *)
open Format;
open Pcaml;
(* *)
(***********************************************************************)
-(* $Id: pa_sml.ml,v 1.1.2.1 2004/07/07 16:37:10 mauny Exp $ *)
+(* $Id: pa_sml.ml,v 1.2 2004/07/13 12:25:09 xleroy Exp $ *)
open Stdpp;
open Pcaml;
(* *)
(***********************************************************************)
-(* $Id: smllib.sml,v 1.1.2.1 2004/07/07 16:37:11 mauny Exp $ *)
+(* $Id: smllib.sml,v 1.2 2004/07/13 12:25:09 xleroy Exp $ *)
datatype 'a option = SOME of 'a | NONE
exception Fail of string
# #
#########################################################################
-# $Id: Makefile.mingw,v 1.12 2004/04/01 13:08:56 xleroy Exp $
+# $Id: Makefile.mingw,v 1.13 2005/08/01 15:51:09 xleroy Exp $
# Configuration for Windows, Mingw compiler
PARTIALLD=ld -r $(NATIVECCLINKOPTS)
PACKLD=$(PARTIALLD)
-### nm and objcopy from GNU binutils
-BINUTILS_NM=nm
-BINUTILS_OBJCOPY=objcopy
-
############# Configuration for the contributed libraries
OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray labltk
# #
#########################################################################
-# $Id: Makefile.msvc,v 1.12.4.2 2005/02/02 15:39:40 xleroy Exp $
+# $Id: Makefile.msvc,v 1.14 2005/08/01 15:51:09 xleroy Exp $
# Configuration for Windows, Visual C++ compiler
PARTIALLD=lib /nologo /debugtype:cv
PACKLD=ld -r --oformat pe-i386
-### nm and objcopy are missing
-BINUTILS_NM=nm
-BINUTILS_OBJCOPY=objcopy
-
############# Configuration for the contributed libraries
OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray labltk
/* */
/***********************************************************************/
-/* $Id: ia32sse2.c,v 1.1.6.1 2005/01/31 17:25:42 doligez Exp $ */
+/* $Id: ia32sse2.c,v 1.2 2005/03/24 17:20:53 doligez Exp $ */
/* Test whether IA32 assembler supports SSE2 instructions */
/* */
/***********************************************************************/
-/* $Id: m-nt.h,v 1.10 2002/06/07 09:49:37 xleroy Exp $ */
+/* $Id: m-nt.h,v 1.11 2005/09/22 14:21:50 xleroy Exp $ */
/* Machine configuration, Intel x86 processors, Win32,
Visual C++ or Mingw compiler */
#undef ARCH_ALIGN_DOUBLE
#define SIZEOF_INT 4
#define SIZEOF_LONG 4
+#define SIZEOF_PTR 4
#define SIZEOF_SHORT 2
#ifdef __MINGW32__
#define ARCH_INT64_TYPE long long
/* */
/***********************************************************************/
-/* $Id: m-templ.h,v 1.14 2001/12/07 13:39:40 xleroy Exp $ */
+/* $Id: m-templ.h,v 1.15 2005/09/22 14:21:50 xleroy Exp $ */
/* Processor dependencies */
#define ARCH_SIXTYFOUR
/* Define ARCH_SIXTYFOUR if the processor has a natural word size of 64 bits.
- That is, both sizeof(long) = 8 and sizeof(char *) = 8.
- Otherwise, leave ARCH_SIXTYFOUR undefined. This assumes
- sizeof(long) = sizeof(char *) = 4. */
+ That is, sizeof(char *) = 8.
+ Otherwise, leave ARCH_SIXTYFOUR undefined.
+ This assumes sizeof(char *) = 4. */
#define ARCH_BIG_ENDIAN
#define SIZEOF_INT 4
#define SIZEOF_LONG 4
+#define SIZEOF_PTR 4
#define SIZEOF_SHORT 2
-/* Define SIZEOF_INT, SIZEOF_LONG and SIZEOF_SHORT to the sizes in byte
- of the C types "int", "long" and "short", respectively. */
+/* Define SIZEOF_INT, SIZEOF_LONG, SIZEOF_PTR and SIZEOF_SHORT
+ to the sizes in bytes of the C types "int", "long", "char *" and "short",
+ respectively. */
#define ARCH_INT64_TYPE long long
#define ARCH_UINT64_TYPE unsigned long long
# #
#########################################################################
-# $Id: configure,v 1.215.2.10 2005/06/12 13:36:42 xleroy Exp $
+# $Id: configure,v 1.228 2005/09/24 09:19:09 xleroy Exp $
configure_options="$*"
prefix=/usr/local
verbose=no
withcurses=yes
withsharedlibs=yes
-binutils_dir=''
gcc_warnings="-Wall"
# Try to turn internationalization off, can cause config.guess to malfunction!
dl_defs="$2"; shift;;
-dllibs*|--dllibs*)
dllib="$2"; shift;;
- -binutils*|--binutils*)
- binutils_dir=$2; shift;;
-verbose|--verbose)
verbose=yes;;
*) echo "Unknown option \"$1\"." 1>&2; exit 2;;
case "$2,$3" in
4,4) echo "OK, this is a regular 32 bit architecture."
echo "#undef ARCH_SIXTYFOUR" >> m.h;;
- 8,8) echo "Wow! A 64 bit architecture!"
- echo "#define ARCH_SIXTYFOUR" >> m.h;;
*,8) echo "Wow! A 64 bit architecture!"
- echo "Unfortunately, Objective Caml cannot work in the case"
- echo "sizeof(long) != sizeof(long *)."
- echo "Objective Caml won't run on this architecture."
- exit 2;;
+ echo "#define ARCH_SIXTYFOUR" >> m.h;;
*,*) echo "This architecture seems to be neither 32 bits nor 64 bits."
echo "Objective Caml won't run on this architecture."
exit 2;;
echo "#define SIZEOF_INT $1" >> m.h
echo "#define SIZEOF_LONG $2" >> m.h
+echo "#define SIZEOF_PTR $3" >> m.h
echo "#define SIZEOF_SHORT $4" >> m.h
if test $2 = 8; then
esac
fi
+if test $3 = 8 && test $int64_native = false; then
+ echo "This architecture has 64-bit pointers but no 64-bit integer type."
+ echo "Objective Caml won't run on this architecture."
+ exit 2
+fi
+
# Determine endianness
sh ./runtest endian.c
*) profiling='noprof';;
esac
-# Where are GNU binutils?
-
-binutils_objcopy=''
-binutils_install_objcopy=':'
-binutils_nm=''
-
-case "$host" in
- powerpc-*-darwin*)
- binutils_objcopy='$(LIBDIR)/ocaml-objcopy'
- binutils_install_objcopy=cp
- binutils_nm=/usr/bin/nm
- ;;
- *)
- if test "$arch" != "none"; then
- binutils_path="${binutils_dir}:${PATH}:/usr/libexec/binutils"
- old_IFS="$IFS"
- IFS=':'
- for d in ${binutils_path}; do
- if test -z "$d"; then continue; fi
- if test -f "$d/objcopy" && test -f "$d/nm"; then
- echo "objcopy and nm found in $d"
- if test `$d/objcopy --help | grep -s -c 'redefine-sym'` -eq 0; then
- echo "$d/objcopy does not support option --redefine-sym, discarded"
- continue;
- fi
- if test `$d/nm --version | grep -s -c 'GNU nm'` -eq 0; then
- echo "$d/nm is not from GNU binutils, discarded"
- continue;
- fi
- binutils_objcopy="$d/objcopy"
- binutils_nm="$d/nm"
- break
- fi
- done
- IFS="$old_IFS"
- fi
- ;;
-esac
-
# Where is ranlib?
if sh ./searchpath ranlib; then
# Determine if system stack overflows can be detected
case "$arch,$system" in
- i386,linux_elf)
+ i386,linux_elf|amd64,linux)
echo "System stack overflow can be detected."
echo "#define HAS_STACK_OVERFLOW_DETECTION" >> s.h;;
*)
# Determine if the POSIX threads library is supported
+systhread_support=false
+
if test "$pthread_wanted" = "yes"; then
case "$host" in
*-*-solaris*) pthread_link="-lpthread -lposix4";;
esac
if ./hasgot -i pthread.h $pthread_link pthread_self; then
echo "POSIX threads library supported."
+ systhread_support=true
otherlibraries="$otherlibraries systhreads"
bytecccompopts="$bytecccompopts -D_REENTRANT"
nativecccompopts="$nativecccompopts -D_REENTRANT"
if test $has_tk = true; then
tcl_version=''
tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- if test -z "$tcl_version" && test -z "$tk_defs"; then
- tk_defs=-I/usr/local/include
+ for tk_incs in \
+ "-I/usr/local/include" \
+ "-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" \
+ "-I/usr/include/tcl8.3 -I/usr/include/tk8.3" \
+ "-I/usr/local/include/tcl8.2 -I/usr/local/include/tk8.2" \
+ "-I/usr/include/tcl8.2 -I/usr/include/tk8.2" \
+ "-I/sw/include"
+ do if test -z "$tcl_version"; then
+ tk_defs="$tk_incs"
tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- fi
- if test -z "$tcl_version"; then
- tk_defs="-I/usr/local/include/tcl8.2 -I/usr/local/include/tk8.2"
- tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- fi
- if test -z "$tcl_version"; then
- tk_defs="-I/usr/local/include/tcl8.3 -I/usr/local/include/tk8.3"
- tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- fi
- if test -z "$tcl_version"; then
- tk_defs="-I/usr/local/include/tcl8.4 -I/usr/local/include/tk8.4"
- tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- fi
- if test -z "$tcl_version"; then
- tk_defs="-I/usr/include/tcl8.2 -I/usr/include/tk8.2"
- tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- fi
- if test -z "$tcl_version"; then
- tk_defs="-I/usr/include/tcl8.3 -I/usr/include/tk8.3"
- tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- fi
- if test -z "$tcl_version"; then
- tk_defs="-I/usr/include/tcl8.4 -I/usr/include/tk8.4"
- tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- fi
- if test -z "$tcl_version"; then
- tk_defs="-I/sw/include"
- tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c`
- fi
- if test -n "$tcl_version"; then
- echo "tcl.h version $tcl_version found with \"$tk_defs\"."
+ fi; done
+ if test -n "$tcl_version" && test "x$tcl_version" != "xnone"; then
+ echo "tcl.h and tk.h version $tcl_version found with \"$tk_defs\"."
case $tcl_version in
7.5) tclmaj=7 tclmin=5 tkmaj=4 tkmin=1 ;;
7.6) tclmaj=7 tclmin=6 tkmaj=4 tkmin=2 ;;
fi
fi
-# FIXME redundant?
-if test $has_tk = true; then
- if sh ./hasgot $tk_x11_include $tk_defs -i tk.h; then
- echo "tk.h found."
- else
- echo "tk.h not found."
- has_tk=false
- fi
-fi
-
tkauxlibs="$mathlib $dllib"
tcllib=''
tklib=''
if test $has_tk = true; then
- if sh ./hasgot $tk_libs $tk_x11_libs $tkauxlibs Tcl_DoOneEvent
+ if test -n "$tk_libs" && \
+ sh ./hasgot $tk_libs $tk_x11_libs $tkauxlibs Tcl_DoOneEvent
then tk_libs="$tk_libs $dllib"
elif sh ./hasgot $tk_libs -ltcl$tclmaj.$tclmin $tkauxlibs Tcl_DoOneEvent
then
elif sh ./hasgot $tk_libs -ltcl$tclmaj$tclmin $tkauxlibs Tcl_DoOneEvent
then
tk_libs="$tk_libs -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin $dllib"
-# elif sh ./hasgot $tk_libs -ltcl $tkauxlibs Tcl_DoOneEvent; then
-# tk_libs="$tk_libs -ltk -ltcl"
elif sh ./hasgot -L/sw/lib $tk_libs -ltcl$tclmaj.$tclmin $tkauxlibs \
Tcl_DoOneEvent
then tk_libs="-L/sw/lib -ltk$tkmaj.$tkmin -ltcl$tclmaj.$tclmin $dllib"
echo "ASPPFLAGS=$asppflags" >> Makefile
echo "ASPPPROFFLAGS=$asppprofflags" >> Makefile
echo "PROFILING=$profiling" >> Makefile
-echo "BINUTILS_OBJCOPY=$binutils_objcopy" >> Makefile
-echo "BINUTILS_INSTALL_OBJCOPY=$binutils_install_objcopy" >> Makefile
-echo "BINUTILS_NM=$binutils_nm" >> Makefile
echo "DYNLINKOPTS=$dllib" >> Makefile
echo "OTHERLIBRARIES=$otherlibraries" >> Makefile
echo "DEBUGGER=$debugger" >> Makefile
echo "CC_PROFILE=$cc_profile" >> Makefile
+echo "SYSTHREAD_SUPPORT=$systhread_support" >>Makefile
rm -f tst hasgot.c
rm -f ../m.h ../s.h ../Makefile
else
echo " profiling with gprof ..... not supported"
fi
- if test -n "$binutils_objcopy" && test -n "$binutils_nm"; then
- echo " ocamlopt -pack ........... supported"
- else
- echo " ocamlopt -pack ........... not supported (no binutils)"
- fi
fi
if test "$debugger" = "ocamldebugger"; then
../typing/env.cmi debugcom.cmi
program_loading.cmi: primitives.cmi
show_information.cmi: ../bytecomp/instruct.cmi
+show_source.cmi: ../bytecomp/instruct.cmi
symbols.cmi: ../bytecomp/instruct.cmi
time_travel.cmi: primitives.cmi
unix_tools.cmi: ../otherlibs/unix/unix.cmi
../typing/types.cmi time_travel.cmi symbols.cmi source.cmi \
show_source.cmi show_information.cmi program_management.cmi \
program_loading.cmi printval.cmi primitives.cmi pos.cmi parser_aux.cmi \
- parser.cmi parameters.cmi ../utils/misc.cmi loadprinter.cmi lexer.cmi \
- int64ops.cmi ../bytecomp/instruct.cmi input_handling.cmi history.cmi \
- frames.cmi events.cmi eval.cmi envaux.cmi debugger_config.cmi \
- debugcom.cmi ../typing/ctype.cmi ../utils/config.cmi checkpoints.cmi \
- breakpoints.cmi command_line.cmi
+ parser.cmi parameters.cmi ../utils/misc.cmi ../parsing/location.cmi \
+ loadprinter.cmi lexer.cmi int64ops.cmi ../bytecomp/instruct.cmi \
+ input_handling.cmi history.cmi frames.cmi events.cmi eval.cmi envaux.cmi \
+ debugger_config.cmi debugcom.cmi ../typing/ctype.cmi ../utils/config.cmi \
+ checkpoints.cmi breakpoints.cmi command_line.cmi
command_line.cmx: unix_tools.cmx ../otherlibs/unix/unix.cmx \
../typing/types.cmx time_travel.cmx symbols.cmx source.cmx \
show_source.cmx show_information.cmx program_management.cmx \
program_loading.cmx printval.cmx primitives.cmx pos.cmx parser_aux.cmi \
- parser.cmx parameters.cmx ../utils/misc.cmx loadprinter.cmx lexer.cmx \
- int64ops.cmx ../bytecomp/instruct.cmx input_handling.cmx history.cmx \
- frames.cmx events.cmx eval.cmx envaux.cmx debugger_config.cmx \
- debugcom.cmx ../typing/ctype.cmx ../utils/config.cmx checkpoints.cmx \
- breakpoints.cmx command_line.cmi
+ parser.cmx parameters.cmx ../utils/misc.cmx ../parsing/location.cmx \
+ loadprinter.cmx lexer.cmx int64ops.cmx ../bytecomp/instruct.cmx \
+ input_handling.cmx history.cmx frames.cmx events.cmx eval.cmx envaux.cmx \
+ debugger_config.cmx debugcom.cmx ../typing/ctype.cmx ../utils/config.cmx \
+ checkpoints.cmx breakpoints.cmx command_line.cmi
debugcom.cmo: primitives.cmi ../utils/misc.cmi int64ops.cmi \
input_handling.cmi debugcom.cmi
debugcom.cmx: primitives.cmx ../utils/misc.cmx int64ops.cmx \
../bytecomp/instruct.cmx ../typing/ident.cmx frames.cmx ../typing/env.cmx \
debugger_config.cmx debugcom.cmx ../typing/ctype.cmx ../typing/btype.cmx \
eval.cmi
-events.cmo: symbols.cmi primitives.cmi ../bytecomp/instruct.cmi \
+events.cmo: primitives.cmi ../parsing/location.cmi ../bytecomp/instruct.cmi \
checkpoints.cmi events.cmi
-events.cmx: symbols.cmx primitives.cmx ../bytecomp/instruct.cmx \
+events.cmx: primitives.cmx ../parsing/location.cmx ../bytecomp/instruct.cmx \
checkpoints.cmx events.cmi
exec.cmo: exec.cmi
exec.cmx: exec.cmi
pattern_matching.cmx: ../typing/typedtree.cmx parser_aux.cmi \
../utils/misc.cmx debugger_config.cmx debugcom.cmx ../typing/ctype.cmx \
pattern_matching.cmi
-pos.cmo: source.cmi primitives.cmi ../bytecomp/instruct.cmi pos.cmi
-pos.cmx: source.cmx primitives.cmx ../bytecomp/instruct.cmx pos.cmi
+pos.cmo: source.cmi primitives.cmi ../parsing/location.cmi \
+ ../bytecomp/instruct.cmi pos.cmi
+pos.cmx: source.cmx primitives.cmx ../parsing/location.cmx \
+ ../bytecomp/instruct.cmx pos.cmi
primitives.cmo: ../otherlibs/unix/unix.cmi primitives.cmi
primitives.cmx: ../otherlibs/unix/unix.cmx primitives.cmi
printval.cmo: ../typing/types.cmi ../bytecomp/symtable.cmi \
input_handling.cmx history.cmx debugger_config.cmx debugcom.cmx \
breakpoints.cmx program_management.cmi
show_information.cmo: symbols.cmi show_source.cmi printval.cmi primitives.cmi \
- ../utils/misc.cmi ../bytecomp/instruct.cmi frames.cmi events.cmi \
- debugcom.cmi checkpoints.cmi breakpoints.cmi show_information.cmi
+ ../utils/misc.cmi ../parsing/location.cmi ../bytecomp/instruct.cmi \
+ frames.cmi events.cmi debugcom.cmi checkpoints.cmi breakpoints.cmi \
+ show_information.cmi
show_information.cmx: symbols.cmx show_source.cmx printval.cmx primitives.cmx \
- ../utils/misc.cmx ../bytecomp/instruct.cmx frames.cmx events.cmx \
- debugcom.cmx checkpoints.cmx breakpoints.cmx show_information.cmi
+ ../utils/misc.cmx ../parsing/location.cmx ../bytecomp/instruct.cmx \
+ frames.cmx events.cmx debugcom.cmx checkpoints.cmx breakpoints.cmx \
+ show_information.cmi
show_source.cmo: source.cmi primitives.cmi parameters.cmi ../utils/misc.cmi \
+ ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi \
debugger_config.cmi show_source.cmi
show_source.cmx: source.cmx primitives.cmx parameters.cmx ../utils/misc.cmx \
+ ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmx \
debugger_config.cmx show_source.cmi
source.cmo: primitives.cmi ../utils/misc.cmi ../utils/config.cmi source.cmi
source.cmx: primitives.cmx ../utils/misc.cmx ../utils/config.cmx source.cmi
symbols.cmo: ../bytecomp/symtable.cmi primitives.cmi ../bytecomp/instruct.cmi \
- debugger_config.cmi debugcom.cmi ../bytecomp/bytesections.cmi symbols.cmi
+ events.cmi debugger_config.cmi debugcom.cmi checkpoints.cmi \
+ ../bytecomp/bytesections.cmi symbols.cmi
symbols.cmx: ../bytecomp/symtable.cmx primitives.cmx ../bytecomp/instruct.cmx \
- debugger_config.cmx debugcom.cmx ../bytecomp/bytesections.cmx symbols.cmi
+ events.cmx debugger_config.cmx debugcom.cmx checkpoints.cmx \
+ ../bytecomp/bytesections.cmx symbols.cmi
time_travel.cmo: trap_barrier.cmi symbols.cmi program_loading.cmi \
primitives.cmi ../utils/misc.cmi int64ops.cmi ../bytecomp/instruct.cmi \
input_handling.cmi exec.cmi events.cmi debugger_config.cmi debugcom.cmi \
# #
#########################################################################
-# $Id: Makefile,v 1.29 2004/02/22 15:07:51 xleroy Exp $
+# $Id: Makefile,v 1.30 2005/08/25 15:35:16 doligez Exp $
include ../config/Makefile
source.cmo \
pos.cmo \
checkpoints.cmo \
- symbols.cmo \
events.cmo \
+ symbols.cmo \
breakpoints.cmo \
trap_barrier.cmo \
history.cmo \
(* *)
(***********************************************************************)
-(* $Id: breakpoints.ml,v 1.12 2003/11/21 16:10:56 doligez Exp $ *)
+(* $Id: breakpoints.ml,v 1.13 2005/08/23 20:16:43 doligez Exp $ *)
(******************************* Breakpoints ***************************)
(* Remove a breakpoint from lists. *)
let remove_breakpoint number =
try
- let pos = (List.assoc number !breakpoints).ev_pos in
+ let ev = List.assoc number !breakpoints in
+ let pos = ev.ev_pos in
Exec.protect
(function () ->
breakpoints := assoc_remove !breakpoints number;
- remove_position pos)
+ remove_position pos;
+ printf "Removed breakpoint %d at %d : %s" number ev.ev_pos
+ (Pos.get_desc ev);
+ print_newline ()
+ )
with
Not_found ->
prerr_endline ("No breakpoint number " ^ (string_of_int number) ^ ".");
(* *)
(***********************************************************************)
-(* $Id: command_line.ml,v 1.21 2003/11/21 16:10:56 doligez Exp $ *)
+(* $Id: command_line.ml,v 1.23 2005/08/25 15:35:16 doligez Exp $ *)
(************************ Reading and executing commands ***************)
else m)
| None ->
try
- let (x, _) = current_point () in x
+ (get_current_event ()).ev_module
with
| Not_found ->
error "Not in a module."
fprintf ppf "(More frames follow)@."
end;
!frame_counter < last_frame in
+ fprintf ppf "Backtrace:@.";
if number = 0 then
do_backtrace (print_frame 0 max_int)
else if number > 0 then
ensure_loaded ();
let mdle = convert_module (opt_identifier_eol Lexer.lexeme lexbuf) in
print_endline ("Module : " ^ mdle);
- print_endline " Address Character Kind Repr.";
+ print_endline " Address Characters Kind Repr.";
List.iter
(function ev ->
Printf.printf
- "%10d %10d %10s %10s\n"
+ "%10d %6d-%-6d %10s %10s\n"
ev.ev_pos
- ev.ev_char.Lexing.pos_cnum
+ ev.ev_loc.Location.loc_start.Lexing.pos_cnum
+ ev.ev_loc.Location.loc_end.Lexing.pos_cnum
((match ev.ev_kind with
Event_before -> "before"
| Event_after _ -> "after"
(* *)
(***********************************************************************)
-(* $Id: events.ml,v 1.5 2002/11/02 22:36:42 doligez Exp $ *)
+(* $Id: events.ml,v 1.6 2005/08/25 15:35:16 doligez Exp $ *)
(********************************* Events ******************************)
open Primitives
open Checkpoints
-(* Previous `pc'. *)
-(* Save time if `update_current_event' is called *)
-(* several times at the same point. *)
-let old_pc = ref (None : int option)
+let get_pos ev =
+ match ev.ev_kind with
+ | Event_before -> ev.ev_loc.Location.loc_start
+ | Event_after _ -> ev.ev_loc.Location.loc_end
+ | _ -> ev.ev_loc.Location.loc_start
+;;
+
(*** Current events. ***)
let current_event =
ref (None : debug_event option)
-(* Recompute the current event *)
-let update_current_event () =
- match current_pc () with
- None ->
- current_event := None;
- old_pc := None
- | (Some pc) as opt_pc when opt_pc <> !old_pc ->
- current_event := begin try
- Some (Symbols.event_at_pc pc)
- with Not_found ->
- None
- end;
- old_pc := opt_pc
- | _ ->
- ()
-
(* Current position in source. *)
(* Raise `Not_found' if not on an event (beginning or end of program). *)
-let current_point () =
+let get_current_event () =
match !current_event with
- None ->
- raise Not_found
- | Some {ev_char = point; ev_module = mdle} ->
- (mdle, point.Lexing.pos_cnum)
+ | None -> raise Not_found
+ | Some ev -> ev
let current_event_is_before () =
match !current_event with
(* *)
(***********************************************************************)
-(* $Id: events.mli,v 1.3 1999/11/17 18:57:24 xleroy Exp $ *)
+(* $Id: events.mli,v 1.4 2005/08/25 15:35:16 doligez Exp $ *)
open Instruct
+val get_pos : debug_event -> Lexing.position;;
+
(** Current events. **)
(* The event at current position. *)
val current_event : debug_event option ref
-(* Recompute the current event *)
-val update_current_event : unit -> unit
-
(* Current position in source. *)
(* Raise `Not_found' if not on an event (beginning or end of program). *)
-val current_point : unit -> string * int
+val get_current_event : unit -> debug_event
val current_event_is_before : unit -> bool
(* *)
(***********************************************************************)
-(* $Id: frames.ml,v 1.9 2002/11/02 22:36:42 doligez Exp $ *)
+(* $Id: frames.ml,v 1.10 2005/08/25 15:35:16 doligez Exp $ *)
(***************************** Frames **********************************)
match !selected_event with
None ->
raise Not_found
- | Some {ev_char = point; ev_module = mdle} ->
- (mdle, point.Lexing.pos_cnum)
+ | Some ev ->
+ (ev.ev_module, (Events.get_pos ev).Lexing.pos_cnum)
let selected_event_is_before () =
match !selected_event with
(* *)
(***********************************************************************)
-(* $Id: loadprinter.ml,v 1.18 2003/07/17 13:55:37 doligez Exp $ *)
+(* $Id: loadprinter.ml,v 1.19 2004/11/29 02:27:25 garrigue Exp $ *)
(* Loading and installation of user-defined printer functions *)
raise(Error(Unavailable_module(s, lid))) in
let print_function =
if is_old_style then
- (fun formatter repr -> (Obj.obj v) (Obj.obj repr))
+ (fun formatter repr -> Obj.obj v (Obj.obj repr))
else
- (fun formatter repr -> (Obj.obj v) formatter (Obj.obj repr)) in
+ (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
Printval.install_printer path ty_arg ppf print_function
let remove_printer lid =
(* *)
(***********************************************************************)
-(* $Id: main.ml,v 1.15 2003/12/04 12:32:04 starynke Exp $ *)
+(* $Id: main.ml,v 1.16 2004/11/27 01:04:19 doligez Exp $ *)
open Primitives
open Misc
checkpoint_max_count := n
let set_directory dir =
Sys.chdir dir
-let set_emacs () =
- emacs := true
+let print_version () =
+ printf "The Objective Caml debugger, version %s@." Sys.ocaml_version;
+ exit 0;
+;;
-let speclist =
- ["-I", Arg.String add_include,
- "<dir> Add <dir> to the list of include directories";
- "-s", Arg.String set_socket,
- "<filename> Set the name of the communication socket";
+let speclist = [
"-c", Arg.Int set_checkpoints,
"<count> Set max number of checkpoints kept";
"-cd", Arg.String set_directory,
"<dir> Change working directory";
- "-emacs", Arg.Unit set_emacs,
- "For running the debugger under emacs"]
+ "-emacs", Arg.Set emacs,
+ "For running the debugger under emacs";
+ "-I", Arg.String add_include,
+ "<dir> Add <dir> to the list of include directories";
+ "-s", Arg.String set_socket,
+ "<filename> Set the name of the communication socket";
+ "-version", Arg.Unit print_version,
+ " Print version and exit";
+ ]
let main () =
try
(* *)
(***********************************************************************)
-(* $Id: pos.ml,v 1.1 2003/11/21 16:10:56 doligez Exp $ *)
+(* $Id: pos.ml,v 1.2 2005/08/25 15:35:16 doligez Exp $ *)
open Instruct;;
open Lexing;;
+open Location;;
open Primitives;;
open Source;;
let get_desc ev =
- if ev.ev_char.pos_fname <> ""
- then Printf.sprintf "file %s, line %d, character %d"
- ev.ev_char.pos_fname ev.ev_char.pos_lnum
- (ev.ev_char.pos_cnum - ev.ev_char.pos_bol + 1)
+ let loc = ev.ev_loc in
+ if loc.loc_start.pos_fname <> ""
+ then Printf.sprintf "file %s, line %d, characters %d-%d"
+ loc.loc_start.pos_fname loc.loc_start.pos_lnum
+ (loc.loc_start.pos_cnum - loc.loc_start.pos_bol + 1)
+ (loc.loc_end.pos_cnum - loc.loc_start.pos_bol + 1)
else begin
let filename = source_of_module ev.ev_module in
try
let (start, line) = line_of_pos (get_buffer ev.ev_module)
- ev.ev_char.pos_cnum
+ loc.loc_start.pos_cnum
in
- Printf.sprintf "file %s, line %d, character %d"
- filename line (ev.ev_char.pos_cnum - start + 1)
+ Printf.sprintf "file %s, line %d, characters %d-%d"
+ filename line (loc.loc_start.pos_cnum - start + 1)
+ (loc.loc_end.pos_cnum - start + 1)
with Not_found | Out_of_range ->
- Printf.sprintf "file %s, character %d"
- filename (ev.ev_char.pos_cnum + 1)
+ Printf.sprintf "file %s, characters %d-%d"
+ filename (loc.loc_start.pos_cnum + 1)
+ (loc.loc_end.pos_cnum + 1)
end
;;
(* *)
(***********************************************************************)
-(* $Id: program_loading.ml,v 1.6.16.1 2005/08/02 14:04:13 doligez Exp $ *)
+(* $Id: program_loading.ml,v 1.7 2005/08/13 20:59:37 doligez Exp $ *)
(* Program loading *)
(* *)
(***********************************************************************)
-(* $Id: show_information.ml,v 1.12 2002/11/02 22:36:44 doligez Exp $ *)
+(* $Id: show_information.ml,v 1.13 2005/08/25 15:35:16 doligez Exp $ *)
open Instruct
open Format
| None ->
fprintf ppf "@.Beginning of program.@.";
show_no_point ()
- | Some {rep_type = (Event | Breakpoint); rep_program_pointer = pc} ->
- let (mdle, point) = current_point () in
- fprintf ppf " - module %s@." mdle;
+ | Some {rep_type = (Event | Breakpoint); rep_program_pointer = pc} ->
+ let ev = get_current_event () in
+ fprintf ppf " - module %s@." ev.ev_module;
(match breakpoints_at_pc pc with
| [] ->
()
List.iter
(function x -> fprintf ppf "%i " x) l)
(List.sort compare breakpoints));
- show_point mdle point (current_event_is_before ()) true
+ show_point ev true
| Some {rep_type = Exited} ->
fprintf ppf "@.Program exit.@.";
show_no_point ()
let show_one_frame framenum ppf event =
fprintf ppf "#%i Pc : %i %s char %i@."
- framenum event.ev_pos event.ev_module event.ev_char.Lexing.pos_cnum
+ framenum event.ev_pos event.ev_module
+ (Events.get_pos event).Lexing.pos_cnum
(* Display information about the current frame. *)
(* --- `select frame' must have succeded before calling this function. *)
List.iter (function x -> fprintf ppf "%i " x) l)
(List.sort compare breakpoints);
end;
- show_point sel_ev.ev_module sel_ev.ev_char.Lexing.pos_cnum
- (selected_event_is_before ()) selected
+ show_point sel_ev selected
(* *)
(***********************************************************************)
-(* $Id: show_source.ml,v 1.12 2000/03/07 18:22:18 weis Exp $ *)
+(* $Id: show_source.ml,v 1.13 2005/08/25 15:35:16 doligez Exp $ *)
open Debugger_config
-open Parameters
+open Instruct
open Misc
+open Parameters
open Primitives
-open Source
open Printf
+open Source
(* Print a line; return the beginning of the next line *)
let print_line buffer line_number start point before =
if !emacs then printf "\026\026H\n"
(* Print the line containing the point *)
-let show_point mdle point before selected =
+let show_point ev selected =
+ let mdle = ev.ev_module in
+ let before = (ev.ev_kind = Event_before) in
if !emacs && selected then
begin try
let source = source_of_module mdle in
- printf "\026\026M%s:%i" source point;
- printf "%s\n" (if before then ":before" else ":after")
+ printf "\026\026M%s:%i:%i" source
+ ev.ev_loc.Location.loc_start.Lexing.pos_cnum
+ ev.ev_loc.Location.loc_end.Lexing.pos_cnum;
+ printf "%s\n" (if before then ":before" else ":after")
with
Not_found -> (* get_buffer *)
prerr_endline ("No source file for " ^ mdle ^ ".");
else
begin try
let buffer = get_buffer mdle in
+ let point = (Events.get_pos ev).Lexing.pos_cnum in
let (start, line_number) = line_of_pos buffer point in
ignore(print_line buffer line_number start point before)
with
(* *)
(***********************************************************************)
-(* $Id: show_source.mli,v 1.3 1999/11/17 18:57:28 xleroy Exp $ *)
+(* $Id: show_source.mli,v 1.4 2005/08/25 15:35:16 doligez Exp $ *)
(* Print the line containing the point *)
-val show_point : string -> int -> bool -> bool -> unit;;
+val show_point : Instruct.debug_event -> bool -> unit;;
(* Tell Emacs we are nowhere in the source. *)
val show_no_point : unit -> unit;;
(* *)
(***********************************************************************)
-(* $Id: symbols.ml,v 1.17 2002/11/02 22:36:45 doligez Exp $ *)
+(* $Id: symbols.ml,v 1.18 2005/08/25 15:35:16 doligez Exp $ *)
(* Handling of symbol tables (globals and events) *)
[] -> ()
| ev :: _ as evl ->
let md = ev.ev_module in
- let cmp ev1 ev2 = compare ev1.ev_char.Lexing.pos_cnum
- ev2.ev_char.Lexing.pos_cnum
+ let cmp ev1 ev2 = compare (Events.get_pos ev1).Lexing.pos_cnum
+ (Events.get_pos ev2).Lexing.pos_cnum
in
let sorted_evl = List.sort cmp evl in
modules := md :: !modules;
let find_event ev char =
let rec bsearch lo hi =
if lo >= hi then begin
- if ev.(hi).ev_char.Lexing.pos_cnum < char then raise Not_found;
- hi
+ if (Events.get_pos ev.(hi)).Lexing.pos_cnum < char
+ then raise Not_found
+ else hi
end else begin
let pivot = (lo + hi) / 2 in
let e = ev.(pivot) in
- if char <= e.ev_char.Lexing.pos_cnum then bsearch lo pivot
- else bsearch (pivot + 1) hi
+ if char <= (Events.get_pos e).Lexing.pos_cnum
+ then bsearch lo pivot
+ else bsearch (pivot + 1) hi
end
in
bsearch 0 (Array.length ev - 1)
let pos = find_event ev char in
(* Desired event is either ev.(pos) or ev.(pos - 1),
whichever is closest *)
- if pos > 0 && char - ev.(pos - 1).ev_char.Lexing.pos_cnum
- <= ev.(pos).ev_char.Lexing.pos_cnum - char
+ if pos > 0 && char - (Events.get_pos ev.(pos - 1)).Lexing.pos_cnum
+ <= (Events.get_pos ev.(pos)).Lexing.pos_cnum - char
then ev.(pos - 1)
else ev.(pos)
with Not_found ->
Event_pseudo -> ()
| _ -> Debugcom.set_event ev.ev_pos)
events_by_pc
+
+
+(* Previous `pc'. *)
+(* Save time if `update_current_event' is called *)
+(* several times at the same point. *)
+let old_pc = ref (None : int option)
+
+(* Recompute the current event *)
+let update_current_event () =
+ match Checkpoints.current_pc () with
+ None ->
+ Events.current_event := None;
+ old_pc := None
+ | (Some pc) as opt_pc when opt_pc <> !old_pc ->
+ Events.current_event :=
+ begin try
+ Some (event_at_pc pc)
+ with Not_found ->
+ None
+ end;
+ old_pc := opt_pc
+ | _ ->
+ ()
(* *)
(***********************************************************************)
-(* $Id: symbols.mli,v 1.6 1999/11/17 18:57:29 xleroy Exp $ *)
+(* $Id: symbols.mli,v 1.7 2005/08/25 15:35:16 doligez Exp $ *)
(* Modules used by the program. *)
val modules : string list ref
(* --- Raise `Not_found' if no such event. *)
val event_near_pos : string -> int -> Instruct.debug_event
+(* Recompute the current event *)
+val update_current_event : unit -> unit
(* *)
(***********************************************************************)
-(* $Id: time_travel.ml,v 1.17 2004/06/21 08:39:32 xleroy Exp $ *)
+(* $Id: time_travel.ml,v 1.19 2005/08/25 15:35:16 doligez Exp $ *)
(**************************** Time travel ******************************)
{rep_type = Breakpoint; rep_program_pointer = pc;
rep_stack_pointer = sp} ->
last_breakpoint := Some (pc, sp);
- update_current_event ();
+ Symbols.update_current_event ();
begin match !current_event with
None -> find_event ()
| Some _ -> ()
(* --- Assume 0 <= time < time_max *)
let rec back_to time time_max =
let
- {c_time = t} as checkpoint = find_checkpoint_before (pre64 time_max)
+ {c_time = t} = find_checkpoint_before (pre64 time_max)
in
go_to (max time t);
let (new_time, break) = find_last_breakpoint time_max in
(* Finish current function. *)
let finish () =
- update_current_event ();
+ Symbols.update_current_event ();
match !current_event with
None ->
prerr_endline "`finish' not meaningful in outermost frame.";
done))
let next_1 () =
- update_current_event ();
+ Symbols.update_current_event ();
match !current_event with
None -> (* Beginning of the program. *)
step _1
let (frame1, pc1) = initial_frame() in
step _1;
if not !interrupted then begin
- update_current_event ();
+ Symbols.update_current_event ();
match !current_event with
None -> ()
| Some event2 ->
(* Run backward until just before current function. *)
let start () =
- update_current_event ();
+ Symbols.update_current_event ();
match !current_event with
None ->
prerr_endline "`start not meaningful in outermost frame.";
done
let previous_1 () =
- update_current_event ();
+ Symbols.update_current_event ();
match !current_event with
None -> (* End of the program. *)
step _minus1
let (frame1, pc1) = initial_frame() in
step _minus1;
if not !interrupted then begin
- update_current_event ();
+ Symbols.update_current_event ();
match !current_event with
None -> ()
| Some event2 ->
(* *)
(***********************************************************************)
-(* $Id: compile.ml,v 1.54 2004/06/13 12:46:41 xleroy Exp $ *)
+(* $Id: compile.ml,v 1.58 2005/08/08 09:41:51 xleroy Exp $ *)
(* The batch compiler *)
let exp_dirs =
List.map (expand_directory Config.standard_library) dirs in
load_path := "" :: List.rev_append exp_dirs (Clflags.std_include_dir ());
- Env.reset_cache()
+ Env.reset_cache ()
(* Return the initial environment in which compilation proceeds. *)
(* Compile a .mli file *)
let interface ppf sourcefile outputprefix =
- init_path();
+ init_path ();
let modulename =
String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in
+ Env.set_unit_name modulename;
let inputfile = Pparse.preprocess sourcefile in
try
let ast =
let (++) x f = f x
let implementation ppf sourcefile outputprefix =
- init_path();
+ init_path ();
let modulename =
String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in
+ Env.set_unit_name modulename;
let inputfile = Pparse.preprocess sourcefile in
let env = initial_env() in
if !Clflags.print_types then begin
try
Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
++ print_if ppf Clflags.dump_parsetree Printast.implementation
+ ++ Unused_var.warn ppf
++ Typemod.type_implementation sourcefile outputprefix modulename env
++ Translmod.transl_implementation modulename
++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
(* *)
(***********************************************************************)
-(* $Id: main.ml,v 1.67 2004/06/13 12:46:41 xleroy Exp $ *)
+(* $Id: main.ml,v 1.68 2005/05/09 13:39:17 doligez Exp $ *)
open Config
open Clflags
let impl = process_implementation_file Format.err_formatter;;
let intf = process_interface_file Format.err_formatter;;
+let show_config () =
+ Config.print_config stdout;
+ exit 0;
+;;
+
module Options = Main_args.Make_options (struct
let set r () = r := true
let unset r () = r := false
let _cc s = c_compiler := s; c_linker := 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]
(* *)
(***********************************************************************)
-(* $Id: main_args.ml,v 1.42 2003/07/17 08:38:27 xleroy Exp $ *)
+(* $Id: main_args.ml,v 1.47 2005/08/01 15:51:09 xleroy Exp $ *)
module Make_options (F :
sig
val _cc : string -> unit
val _cclib : string -> unit
val _ccopt : string -> unit
+ val _config : unit -> unit
val _custom : unit -> unit
val _dllib : string -> unit
val _dllpath : string -> unit
"-cclib", Arg.String F._cclib, "<opt> Pass option <opt> to the C linker";
"-ccopt", Arg.String F._ccopt,
"<opt> Pass option <opt> to the C compiler and linker";
+ "-config", Arg.Unit F._config,
+ " print configuration values and exit";
"-custom", Arg.Unit F._custom, " Link in custom mode";
"-dllib", Arg.String F._dllib,
"<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";
+ "-for-pack", Arg.String (fun s -> ()),
+ "<ident> Ignored (for compatibility with ocamlopt)";
"-g", Arg.Unit F._g, " Save debugging information";
"-i", Arg.Unit F._i, " Print inferred interface";
"-I", Arg.String F._I,
"-principal", Arg.Unit F._principal,
" Check principality of type inference";
"-rectypes", Arg.Unit F._rectypes, " Allow arbitrary recursive types";
- "-thread", Arg.Unit F._thread, " Generate code that supports the system threads library";
+ "-thread", Arg.Unit F._thread,
+ " Generate code that supports the system threads library";
"-unsafe", Arg.Unit F._unsafe,
" No bounds checking on array and string access";
"-use-runtime", Arg.String F._use_runtime,
" Print compiler version and location of standard library and exit";
"-version", Arg.Unit F._version, " Print compiler version and exit";
"-verbose", Arg.Unit F._verbose, " Print calls to external commands";
- "-vmthread", Arg.Unit F._vmthread, " Generate code that supports the threads library with VM-level scheduling";
+ "-vmthread", Arg.Unit F._vmthread,
+ " Generate code that supports the threads library with VM-level scheduling";
"-w", Arg.String F._w,
"<flags> Enable or disable warnings according to <flags>:\n\
\032 A/a enable/disable all warnings\n\
\032 S/s enable/disable non-unit statement\n\
\032 U/u enable/disable unused match case\n\
\032 V/v enable/disable hidden instance variable\n\
+ \032 Y/y enable/disable suspicious unused variables\n\
+ \032 Z/z enable/disable all other unused variables\n\
\032 X/x enable/disable all other warnings\n\
- \032 default setting is \"Ale\"\n\
- \032 (all warnings but labels and fragile match enabled)";
+ \032 default setting is \"Aelz\"";
"-warn-error" , Arg.String F._warn_error,
- "<flags> Treat the warnings enabled by <flags> as errors.\n\
+ "<flags> Treat the warnings of <flags> as errors, if they are enabled.\n\
\032 See option -w for the list of flags.\n\
\032 Default setting is \"a\" (warnings are not errors)";
"-where", Arg.Unit F._where,
(* *)
(***********************************************************************)
-(* $Id: main_args.mli,v 1.25 2003/07/17 08:38:27 xleroy Exp $ *)
+(* $Id: main_args.mli,v 1.26 2005/05/09 13:39:17 doligez Exp $ *)
module Make_options (F :
sig
val _cc : string -> unit
val _cclib : string -> unit
val _ccopt : string -> unit
+ val _config : unit -> unit
val _custom : unit -> unit
val _dllib : string -> unit
val _dllpath : string -> unit
(* *)
(***********************************************************************)
-(* $Id: optcompile.ml,v 1.48 2004/06/13 12:46:41 xleroy Exp $ *)
+(* $Id: optcompile.ml,v 1.53 2005/08/08 09:41:51 xleroy Exp $ *)
(* The batch compiler *)
let exp_dirs =
List.map (expand_directory Config.standard_library) dirs in
load_path := "" :: List.rev_append exp_dirs (Clflags.std_include_dir ());
- Env.reset_cache()
+ Env.reset_cache ()
(* Return the initial environment in which compilation proceeds. *)
(* Compile a .mli file *)
let interface ppf sourcefile outputprefix =
- init_path();
+ init_path ();
let modulename =
String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in
+ Env.set_unit_name modulename;
let inputfile = Pparse.preprocess sourcefile in
try
let ast =
let (+++) (x, y) f = (x, f y)
let implementation ppf sourcefile outputprefix =
- init_path();
+ init_path ();
let modulename =
String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in
+ Env.set_unit_name modulename;
let inputfile = Pparse.preprocess sourcefile in
let env = initial_env() in
- Compilenv.reset modulename;
+ Compilenv.reset ?packname:!Clflags.for_package modulename;
try
if !Clflags.print_types then ignore(
Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
++ print_if ppf Clflags.dump_parsetree Printast.implementation
+ ++ Unused_var.warn ppf
++ Typemod.type_implementation sourcefile outputprefix modulename env)
else begin
Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
++ print_if ppf Clflags.dump_parsetree Printast.implementation
+ ++ Unused_var.warn ppf
++ Typemod.type_implementation sourcefile outputprefix modulename env
++ Translmod.transl_store_implementation modulename
+++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
(* *)
(***********************************************************************)
-(* $Id: optmain.ml,v 1.81 2004/06/13 12:46:41 xleroy Exp $ *)
+(* $Id: optmain.ml,v 1.86 2005/08/01 15:51:09 xleroy Exp $ *)
open Config
open Clflags
let usage = "Usage: ocamlopt <options> <files>\nOptions are:"
+let show_config () =
+ Config.print_config stdout;
+ exit 0;
+;;
+
let main () =
native_code := true;
c_compiler := Config.native_c_compiler;
"<opt> Pass option <opt> to the C compiler and linker";
"-compact", Arg.Clear optimize_for_speed,
" 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";
+ "-for-pack", Arg.String (fun s -> for_package := Some s),
+ "<ident> Generate code that can later be `packed' with\n
+ \t\t\tocamlopt -pack -o <ident>.cmx";
"-i", Arg.Unit (fun () -> print_types := true; compile_only := true),
" Print inferred interface";
"-I", Arg.String(fun dir -> include_dirs := dir :: !include_dirs),
"-rectypes", Arg.Set recursive_types,
" Allow arbitrary recursive types";
"-S", Arg.Set keep_asm_file, " Keep intermediate assembly file";
- "-thread", Arg.Set use_threads, " Generate code that supports the system threads library";
+ "-thread", Arg.Set use_threads,
+ " Generate code that supports the system threads library";
"-unsafe", Arg.Set fast,
" No bounds checking on array and string access";
"-v", Arg.Unit print_version_and_library,
\032 S/s enable/disable non-unit statement\n\
\032 U/u enable/disable unused match case\n\
\032 V/v enable/disable hidden instance variables\n\
+ \032 Y/y enable/disable suspicious unused variables\n\
+ \032 Z/z enable/disable all other unused variables\n\
\032 X/x enable/disable all other warnings\n\
- \032 default setting is \"Ale\"\n\
- \032 (all warnings but labels and fragile match enabled)";
+ \032 default setting is \"Aelz\"";
"-warn-error" , Arg.String (Warnings.parse_options true),
- "<flags> Treat the warnings enabled by <flags> as errors.\n\
+ "<flags> Treat the warnings of <flags> as errors, if they are enabled.\n\
\032 See option -w for the list of flags.\n\
\032 Default setting is \"a\" (warnings are not errors)";
"-where", Arg.Unit print_standard_library,
# #
#########################################################################
-# $Id: Makefile,v 1.16.4.1 2004/08/09 16:09:33 doligez Exp $
+# $Id: Makefile,v 1.17 2004/08/20 17:04:35 doligez Exp $
include ../config/Makefile
;(* *)
;(***********************************************************************)
-;(* $Id: caml-compat.el,v 1.2.18.1 2004/08/09 16:09:33 doligez Exp $ *)
+;(* $Id: caml-compat.el,v 1.3 2004/08/20 17:04:35 doligez Exp $ *)
;; function definitions for old versions of emacs
;(* *)
;(***********************************************************************)
-;(* $Id: caml-emacs.el,v 1.6.6.1 2004/08/09 16:09:33 doligez Exp $ *)
+;(* $Id: caml-emacs.el,v 1.7 2004/08/20 17:04:35 doligez Exp $ *)
;; for caml-help.el
(defalias 'caml-info-other-window 'info-other-window)
;(* *)
;(***********************************************************************)
-;(* $Id: caml-font.el,v 1.18.2.1 2004/08/09 16:09:33 doligez Exp $ *)
+;(* $Id: caml-font.el,v 1.19 2004/08/20 17:04:35 doligez Exp $ *)
;; useful colors
;(* *)
;(***********************************************************************)
-;(* $Id: caml-help.el,v 1.16.4.1 2004/08/09 16:09:33 doligez Exp $ *)
+;(* $Id: caml-help.el,v 1.17 2004/08/20 17:04:35 doligez Exp $ *)
;; caml-info.el --- contextual completion and help to caml-mode
;(* *)
;(***********************************************************************)
-;(* $Id: caml-hilit.el,v 1.8.4.1 2004/08/09 16:09:33 doligez Exp $ *)
+;(* $Id: caml-hilit.el,v 1.9 2004/08/20 17:04:35 doligez Exp $ *)
; Highlighting patterns for hilit19 under caml-mode
;(* *)
;(***********************************************************************)
-;(* $Id: caml-types.el,v 1.29.6.4 2005/08/05 12:00:16 doligez Exp $ *)
+;(* $Id: caml-types.el,v 1.32 2005/08/13 20:59:37 doligez Exp $ *)
; An emacs-lisp complement to the "-dtypes" option of ocamlc and ocamlopt.
;(* *)
;(***********************************************************************)
-;(* $Id: caml-xemacs.el,v 1.5.6.2 2004/11/02 10:21:03 doligez Exp $ *)
+;(* $Id: caml-xemacs.el,v 1.7 2005/03/24 17:20:53 doligez Exp $ *)
(require 'overlay)
;(* *)
;(***********************************************************************)
-;(* $Id: caml.el,v 1.36.4.1 2004/08/09 16:09:33 doligez Exp $ *)
+;(* $Id: caml.el,v 1.39 2005/02/04 17:19:21 remy Exp $ *)
;;; caml.el --- O'Caml code editing commands for Emacs
(define-key map [separator-types] '("---"))
;; others
+ (define-key map [camldebug] '("Call debugger..." . camldebug))
(define-key map [run-caml] '("Start subshell..." . run-caml))
(define-key map [compile] '("Compile..." . compile))
(define-key map [switch-view]
(cond
(closing 1)
(comment-mark 1)
- (t caml-comment-indent)))))
+ (t (- (match-end 0) (match-beginning 0)))))))
(t (let* ((leading (looking-at caml-leading-kwops-regexp))
(assoc-val (if leading (assoc (caml-match-string 0)
caml-leading-kwops-alist)))
;(* *)
;(***********************************************************************)
-;(* $Id: camldebug.el,v 1.8.4.1 2004/08/09 16:09:33 doligez Exp $ *)
+;(* $Id: camldebug.el,v 1.11 2005/10/26 13:23:12 doligez Exp $ *)
;;; Run camldebug under Emacs
;;; Derived from gdb.el.
;accumulate onto previous output
(setq camldebug-filter-accumulator
(concat camldebug-filter-accumulator string))
- (if (not (string-match (concat "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+"
- camldebug-goto-position
- "[ \t]*\\(before\\|after\\)\n")
- camldebug-filter-accumulator)) nil
+ (if (not (or (string-match (concat "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+"
+ camldebug-goto-position
+ "-[0-9]+[ \t]*\\(before\\).*\n")
+ camldebug-filter-accumulator)
+ (string-match (concat "\\(\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+[0-9]+-"
+ camldebug-goto-position
+ "[ \t]*\\(after\\).*\n")
+ camldebug-filter-accumulator)))
+ nil
(setq camldebug-goto-output
(match-string 2 camldebug-filter-accumulator))
(setq camldebug-filter-accumulator
;; Process all the complete markers in this chunk.
(while (setq begin
(string-match
- "\032\032\\(H\\|M\\(.+\\):\\(.+\\):\\(before\\|after\\)\\)\n"
+ "\032\032\\(H\\|M\\(.+\\):\\(.+\\):\\(.+\\):\\(before\\|after\\)\\)\n"
camldebug-filter-accumulator))
(setq camldebug-last-frame
(if (char-equal ?H (aref camldebug-filter-accumulator
(1+ (1+ begin)))) nil
- (list (match-string 2 camldebug-filter-accumulator)
- (string-to-int
- (match-string 3 camldebug-filter-accumulator))
- (string= "before"
- (match-string 4
- camldebug-filter-accumulator))))
+ (let ((isbefore
+ (string= "before"
+ (match-string 5 camldebug-filter-accumulator)))
+ (startpos (string-to-int
+ (match-string 3 camldebug-filter-accumulator)))
+ (endpos (string-to-int
+ (match-string 4 camldebug-filter-accumulator))))
+ (list (match-string 2 camldebug-filter-accumulator)
+ (if isbefore startpos endpos)
+ isbefore
+ startpos
+ endpos
+ )))
output (concat output
(substring camldebug-filter-accumulator
0 begin))
(match-end 0))
camldebug-last-frame-displayed-p nil))
+
;; Does the remaining text look like it might end with the
;; beginning of another marker? If it does, then keep it in
;; camldebug-filter-accumulator until we receive the rest of it. Since we
(defun camldebug-display-frame ()
"Find, obey and delete the last filename-and-line marker from CDB.
-The marker looks like \\032\\032FILENAME:CHARACTER\\n.
+The marker looks like \\032\\032Mfilename:startchar:endchar:beforeflag\\n.
Obeying it means displaying in another window the specified file and line."
(interactive)
(camldebug-set-buffer)
(if (not camldebug-last-frame)
(camldebug-remove-current-event)
- (camldebug-display-line (car camldebug-last-frame)
- (car (cdr camldebug-last-frame))
- (car (cdr (cdr camldebug-last-frame)))))
+ (camldebug-display-line (nth 0 camldebug-last-frame)
+ (nth 3 camldebug-last-frame)
+ (nth 4 camldebug-last-frame)
+ (nth 2 camldebug-last-frame)))
(setq camldebug-last-frame-displayed-p t))
;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
;; and that its character CHARACTER is visible.
;; Put the mark on this character in that buffer.
-(defun camldebug-display-line (true-file character kind)
+(defun camldebug-display-line (true-file schar echar kind)
(let* ((pre-display-buffer-function nil) ; screw it, put it all in one screen
(pop-up-windows t)
(buffer (find-file-noselect true-file))
(window (display-buffer buffer t))
- (pos))
+ (spos) (epos) (pos))
(save-excursion
(set-buffer buffer)
(save-restriction
(widen)
- (setq pos (+ (point-min) character))
- (camldebug-set-current-event pos (current-buffer) kind))
+ (setq spos (+ (point-min) schar))
+ (setq epos (+ (point-min) echar))
+ (setq pos (if kind spos epos))
+ (camldebug-set-current-event spos epos (current-buffer) kind))
(cond ((or (< pos (point-min)) (> pos (point-max)))
(widen)
(goto-char pos))))
(delete-overlay camldebug-overlay-under))
(setq overlay-arrow-position nil)))
-(defun camldebug-set-current-event (pos buffer before)
+(defun camldebug-set-current-event (spos epos buffer before)
(if window-system
(if before
(progn
- (move-overlay camldebug-overlay-event pos (1+ pos) buffer)
+ (move-overlay camldebug-overlay-event spos (1+ spos) buffer)
(move-overlay camldebug-overlay-under
- (+ pos 1) (+ pos 3) buffer))
- (move-overlay camldebug-overlay-event (1- pos) pos buffer)
- (move-overlay camldebug-overlay-under (- pos 3) (- pos 1) buffer))
+ (+ spos 1) epos buffer))
+ (move-overlay camldebug-overlay-event (1- epos) epos buffer)
+ (move-overlay camldebug-overlay-under spos (- epos 1) buffer))
(save-excursion
(set-buffer buffer)
(goto-char pos)
;(* *)
;(***********************************************************************)
-;(* $Id: inf-caml.el,v 1.10.8.1 2004/08/09 16:09:33 doligez Exp $ *)
+;(* $Id: inf-caml.el,v 1.11 2004/08/20 17:04:35 doligez Exp $ *)
;;; inf-caml.el --- run the Caml toplevel in an Emacs buffer
;(* *)
;(***********************************************************************)
-;(* $Id: ocamltags.in,v 1.5.18.1 2004/08/09 16:09:33 doligez Exp $ *)
+;(* $Id: ocamltags.in,v 1.6 2004/08/20 17:04:35 doligez Exp $ *)
;; Copyright (C) 1998 Ian Zimmerman <itz@transbay.net>
;; This program is free software; you can redistribute it and/or
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
-;; $Id: ocamltags.in,v 1.5.18.1 2004/08/09 16:09:33 doligez Exp $
+;; $Id: ocamltags.in,v 1.6 2004/08/20 17:04:35 doligez Exp $
(require 'caml)
# #
#########################################################################
-# $Id: Makefile,v 1.17 2002/11/01 15:31:11 doligez Exp $
+# $Id: Makefile,v 1.19 2004/11/29 14:49:24 doligez Exp $
# The lexer generator
CAMLC=../boot/ocamlrun ../boot/ocamlc -nostdlib -I ../boot
(* *)
(***********************************************************************)
-(* $Id: main.ml,v 1.21.2.1 2004/07/22 11:00:35 maranget Exp $ *)
+(* $Id: main.ml,v 1.22 2004/08/20 17:04:35 doligez Exp $ *)
(* The lexer generator. Command-line parsing. *)
#(* *)
#(***********************************************************************)
-# $Id: Makefile,v 1.55.4.1 2005/02/18 16:08:37 guesdon Exp $
+# $Id: Makefile,v 1.60 2005/05/31 11:48:03 habouzit Exp $
include ../config/Makefile
../otherlibs/bigarray/bigarray.mli \
../otherlibs/num/num.mli
-all: exe lib manpages
+all: exe lib
+ $(MAKE) manpages
+
exe: $(OCAMLDOC)
lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST)
(* *)
(***********************************************************************)
-(* $Id: odoc.ml,v 1.7.4.1 2004/07/09 10:42:09 guesdon Exp $ *)
+(* $Id: odoc.ml,v 1.8 2004/07/13 12:25:11 xleroy Exp $ *)
(** Main module for bytecode. *)
exit 0
-(* eof $Id: odoc.ml,v 1.7.4.1 2004/07/09 10:42:09 guesdon Exp $ *)
+(* eof $Id: odoc.ml,v 1.8 2004/07/13 12:25:11 xleroy Exp $ *)
(* *)
(***********************************************************************)
-(* $Id: odoc_analyse.ml,v 1.8.6.2 2005/06/23 14:47:52 guesdon Exp $ *)
+(* $Id: odoc_analyse.ml,v 1.12 2005/08/13 20:59:37 doligez Exp $ *)
(** Analysis of source files. This module is strongly inspired from driver/main.ml :-) *)
let init_path () =
load_path :=
"" :: List.rev (Config.standard_library :: !Clflags.include_dirs);
- Env.reset_cache()
+ Env.reset_cache ()
(** Return the initial environment in which compilation proceeds. *)
let initial_env () =
(** Analysis of an implementation file. Returns (Some typedtree) if
no error occured, else None and an error message is printed.*)
let process_implementation_file ppf sourcefile =
-
- init_path();
+ init_path ();
let prefixname = Filename.chop_extension sourcefile in
let modulename = String.capitalize(Filename.basename prefixname) in
+ Env.set_unit_name modulename;
let inputfile = preprocess sourcefile in
let env = initial_env () in
try
(** Analysis of an interface file. Returns (Some signature) if
no error occured, else None and an error message is printed.*)
let process_interface_file ppf sourcefile =
- init_path();
+ init_path ();
let prefixname = Filename.chop_extension sourcefile in
let modulename = String.capitalize(Filename.basename prefixname) in
+ Env.set_unit_name modulename;
let inputfile = preprocess sourcefile in
let ast = parse_file inputfile Parse.interface ast_intf_magic_number in
let sg = Typemod.transl_signature (initial_env()) ast in
| ele :: q ->
match ele with
Odoc_class.Class_comment [ Odoc_types.Raw "/*" ] ->
- remove_class_elements_between_stop (not keep) q
+ remove_class_elements_between_stop (not keep) q
| Odoc_class.Class_attribute _
| Odoc_class.Class_method _
| Odoc_class.Class_comment _ ->
- if keep then
- ele :: (remove_class_elements_between_stop keep q)
- else
- remove_class_elements_between_stop keep q
+ if keep then
+ ele :: (remove_class_elements_between_stop keep q)
+ else
+ remove_class_elements_between_stop keep q
(** Remove the class elements between the stop special comments in a class kind. *)
let rec remove_class_elements_between_stop_in_class_kind k =
| ele :: q ->
match ele with
Odoc_module.Element_module_comment [ Odoc_types.Raw "/*" ] ->
- f (not keep) q
+ f (not keep) q
| Odoc_module.Element_module_comment _ ->
if keep then
- ele :: (f keep q)
- else
- f keep q
+ ele :: (f keep q)
+ else
+ f keep q
| Odoc_module.Element_module m ->
- if keep then
+ if keep then
(
- m.Odoc_module.m_kind <- remove_module_elements_between_stop_in_module_kind m.Odoc_module.m_kind ;
+ m.Odoc_module.m_kind <- remove_module_elements_between_stop_in_module_kind m.Odoc_module.m_kind ;
(Odoc_module.Element_module m) :: (f keep q)
- )
- else
- f keep q
+ )
+ else
+ f keep q
| Odoc_module.Element_module_type mt ->
- if keep then
- (
+ if keep then
+ (
mt.Odoc_module.mt_kind <- Odoc_misc.apply_opt
- remove_module_elements_between_stop_in_module_type_kind mt.Odoc_module.mt_kind ;
+ remove_module_elements_between_stop_in_module_type_kind mt.Odoc_module.mt_kind ;
(Odoc_module.Element_module_type mt) :: (f keep q)
- )
- else
- f keep q
+ )
+ else
+ f keep q
| Odoc_module.Element_included_module _ ->
- if keep then
+ if keep then
ele :: (f keep q)
- else
- f keep q
+ else
+ f keep q
| Odoc_module.Element_class c ->
- if keep then
- (
+ if keep then
+ (
c.Odoc_class.cl_kind <- remove_class_elements_between_stop_in_class_kind c.Odoc_class.cl_kind ;
(Odoc_module.Element_class c) :: (f keep q)
- )
- else
- f keep q
+ )
+ else
+ f keep q
| Odoc_module.Element_class_type ct ->
if keep then
- (
- ct.Odoc_class.clt_kind <- remove_class_elements_between_stop_in_class_type_kind ct.Odoc_class.clt_kind ;
+ (
+ ct.Odoc_class.clt_kind <- remove_class_elements_between_stop_in_class_type_kind ct.Odoc_class.clt_kind ;
(Odoc_module.Element_class_type ct) :: (f keep q)
- )
- else
- f keep q
+ )
+ else
+ f keep q
| Odoc_module.Element_value _
| Odoc_module.Element_exception _
| Odoc_module.Element_type _ ->
- if keep then
+ if keep then
ele :: (f keep q)
- else
- f keep q
+ else
+ f keep q
(** Remove the module elements between the stop special comments, in the given module kind. *)
raise (Failure s)
-(* eof $Id: odoc_analyse.ml,v 1.8.6.2 2005/06/23 14:47:52 guesdon Exp $ *)
+(* eof $Id: odoc_analyse.ml,v 1.12 2005/08/13 20:59:37 doligez Exp $ *)
(* *)
(***********************************************************************)
-(* $Id: odoc_analyse.mli,v 1.3.6.1 2004/08/06 13:42:16 guesdon Exp $ *)
+(* $Id: odoc_analyse.mli,v 1.4 2004/08/20 17:04:35 doligez Exp $ *)
(** Analysis of source files. *)
(* *)
(***********************************************************************)
-(* cvsid $Id: odoc_args.ml,v 1.15.6.3 2005/02/18 16:08:37 guesdon Exp $ *)
+(* cvsid $Id: odoc_args.ml,v 1.18 2005/03/24 17:20:53 doligez Exp $ *)
(** Command-line arguments. *)
A.B is before A, so we will match against A.B before A in
Odoc_name.hide_modules.*)
hidden_modules := List.sort (fun a -> fun b -> - (compare a b)) !hidden_modules
-
-
-(* eof $Id: odoc_args.ml,v 1.15.6.3 2005/02/18 16:08:37 guesdon Exp $ *)
(* *)
(***********************************************************************)
-(* $Id: odoc_args.mli,v 1.12.6.2 2005/02/18 16:08:37 guesdon Exp $ *)
+(* $Id: odoc_args.mli,v 1.14 2005/03/24 17:20:53 doligez Exp $ *)
(** Analysis of the command line arguments. *)
(* *)
(***********************************************************************)
-(* $Id: odoc_ast.ml,v 1.24 2004/04/17 12:36:14 guesdon Exp $ *)
+(* $Id: odoc_ast.ml,v 1.26 2004/12/03 14:42:09 guesdon Exp $ *)
(** Analysis of implementation files. *)
open Misc
let simple_blank = "[ \013\009\012]"
-(** This module is used to search for structure items by name in a Typedtree.structure.
+(** This module is used to search for structure items by name in a Typedtree.structure.
One function creates two hash tables, which can then be used to search for elements.
Class elements do not use tables.
*)
module Typedtree_search =
struct
- type ele =
+ type ele =
| M of string
| MT of string
| T of string
| Typedtree.Tpat_tuple _ -> None (* A VOIR quand on traitera les tuples *)
| _ -> None
- let add_to_hashes table table_values tt =
+ let add_to_hashes table table_values tt =
match tt with
- | Typedtree.Tstr_module (ident, _) ->
+ | Typedtree.Tstr_module (ident, _) ->
Hashtbl.add table (M (Name.from_ident ident)) tt
| Typedtree.Tstr_recmodule mods ->
List.iter
- (fun (ident,mod_expr) ->
+ (fun (ident,mod_expr) ->
Hashtbl.add table (M (Name.from_ident ident))
(Typedtree.Tstr_module (ident,mod_expr))
)
mods
- | Typedtree.Tstr_modtype (ident, _) ->
+ | Typedtree.Tstr_modtype (ident, _) ->
Hashtbl.add table (MT (Name.from_ident ident)) tt
| Typedtree.Tstr_exception (ident, _) ->
Hashtbl.add table (E (Name.from_ident ident)) tt
Hashtbl.add table (ER (Name.from_ident ident)) tt
| Typedtree.Tstr_type ident_type_decl_list ->
List.iter
- (fun (id, e) ->
- Hashtbl.add table (T (Name.from_ident id))
+ (fun (id, e) ->
+ Hashtbl.add table (T (Name.from_ident id))
(Typedtree.Tstr_type [(id,e)]))
ident_type_decl_list
| Typedtree.Tstr_class info_list ->
List.iter
- (fun ((id,_,_,_) as ci) ->
+ (fun ((id,_,_,_) as ci) ->
Hashtbl.add table (C (Name.from_ident id))
(Typedtree.Tstr_class [ci]))
info_list
| Typedtree.Tstr_cltype info_list ->
List.iter
- (fun ((id,_) as ci) ->
+ (fun ((id,_) as ci) ->
Hashtbl.add table
(CT (Name.from_ident id))
(Typedtree.Tstr_cltype [ci]))
| (Typedtree.Tstr_cltype [(_,cltype_decl)]) -> cltype_decl
| _ -> assert false
- let search_value table name = Hashtbl.find table name
+ let search_value table name = Hashtbl.find table name
let search_primitive table name =
match Hashtbl.find table (P name) with
let rec iter = function
| [] ->
raise Not_found
- | Typedtree.Cf_val (_, ident, exp) :: q
+ | Typedtree.Cf_val (_, ident, exp) :: q
when Name.from_ident ident = name ->
exp.Typedtree.exp_type
| _ :: q ->
iter cls.Typedtree.cl_field
end
-module Analyser =
+module Analyser =
functor (My_ir : Odoc_sig.Info_retriever) ->
struct
(** The function used to get the comments in a module. *)
let get_comments_in_module = Sig.get_comments_in_module
- (** This function takes a parameter pattern and builds the
+ (** This function takes a parameter pattern and builds the
corresponding [parameter] structure. The f_desc function
is used to retrieve a parameter description, if any, from
a parameter name.
Simple_name { sn_name = name ;
sn_text = f_desc name ;
sn_type = Odoc_env.subst_type env pat.pat_type
- }
-
+ }
+
| Typedtree.Tpat_alias (pat, _) ->
iter_pattern pat
Tuple
(List.map iter_pattern patlist,
Odoc_env.subst_type env pat.pat_type)
-
- | Typedtree.Tpat_construct (cons_desc, _) when
+
+ | Typedtree.Tpat_construct (cons_desc, _) when
(* we give a name to the parameter only if it unit *)
(match cons_desc.cstr_res.desc with
Tconstr (p, _, _) ->
- Path.same p Predef.path_unit
+ Path.same p Predef.path_unit
| _ ->
false)
->
Simple_name { sn_name = "()" ;
sn_text = None ;
sn_type = Odoc_env.subst_type env pat.pat_type
- }
+ }
| _ ->
(* implicit pattern matching -> anonymous parameter *)
Simple_name { sn_name = "()" ;
sn_text = None ;
sn_type = Odoc_env.subst_type env pat.pat_type
- }
+ }
in
- iter_pattern pat
+ iter_pattern pat
(** Analysis of the parameter of a function. Return a list of t_parameter created from
the (pattern, expression) structures encountered. *)
[ parameter ]
| (pattern_param, func_body) :: [] ->
- let parameter =
- tt_param_info_from_pattern
+ let parameter =
+ tt_param_info_from_pattern
env
- (Odoc_parameter.desc_from_info_opt current_comment_opt)
+ (Odoc_parameter.desc_from_info_opt current_comment_opt)
pattern_param
in
(* For optional parameters with a default value, a special treatment is required *)
(* we look if the name of the parameter we just add is "*opt*", which means
that there is a let param_name = ... in ... just right now *)
- let (p, next_exp) =
+ let (p, next_exp) =
match parameter with
Simple_name { sn_name = "*opt*" } ->
(
match func_body.exp_desc with
Typedtree.Texp_let (_, ({pat_desc = Typedtree.Tpat_var id } , exp) :: _, func_body2) ->
let name = Name.from_ident id in
- let new_param = Simple_name
+ let new_param = Simple_name
{ sn_name = name ;
sn_text = Odoc_parameter.desc_from_info_opt current_comment_opt name ;
sn_type = Odoc_env.subst_type env exp.exp_type
val_parameters = tt_analyse_function_parameters env comment_opt pat_exp_list2 ;
val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
- }
+ }
in
[ new_value ]
-
+
| (Typedtree.Tpat_var ident, _) ->
- (* a new value is defined *)
+ (* a new value is defined *)
let name_pre = Name.from_ident ident in
let name = Name.parens_if_infix name_pre in
let complete_name = Name.concat current_module_name name in
val_parameters = [] ;
val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
- }
+ }
in
[ new_value ]
-
+
| (Typedtree.Tpat_tuple lpat, _) ->
(* new identifiers are defined *)
(* A VOIR : by now we don't accept to have global variables defined in tuples *)
[]
-
+
| _ ->
(* something else, we don't care ? A VOIR *)
[]
*)
| _ -> Odoc_messages.object_end
- (** Analysis of a method expression to get the method parameters.
+ (** Analysis of a method expression to get the method parameters.
@param first indicates if we're analysing the method for
the first time ; in that case we must not keep the first parameter,
which is "self-*", the object itself.
(* implicit pattern matching -> anonymous parameter *)
(* Note : We can't match this pattern if it is the first call to the function. *)
let new_param = Simple_name
- { sn_name = "??" ; sn_text = None;
+ { sn_name = "??" ; sn_text = None;
sn_type = Odoc_env.subst_type env pattern_param.Typedtree.pat_type }
in
[ new_param ]
-
+
| (pattern_param, body) :: [] ->
(* if this is the first call to the function, this is the first parameter and we skip it *)
if not first then
(
- let parameter =
+ let parameter =
tt_param_info_from_pattern
env
- (Odoc_parameter.desc_from_info_opt comment_opt)
+ (Odoc_parameter.desc_from_info_opt comment_opt)
pattern_param
in
(* For optional parameters with a default value, a special treatment is required. *)
(* We look if the name of the parameter we just add is "*opt*", which means
that there is a let param_name = ... in ... just right now. *)
- let (current_param, next_exp) =
+ let (current_param, next_exp) =
match parameter with
Simple_name { sn_name = "*opt*"} ->
(
match body.exp_desc with
Typedtree.Texp_let (_, ({pat_desc = Typedtree.Tpat_var id } , exp) :: _, body2) ->
let name = Name.from_ident id in
- let new_param = Simple_name
+ let new_param = Simple_name
{ sn_name = name ;
sn_text = Odoc_parameter.desc_from_info_opt comment_opt name ;
- sn_type = Odoc_env.subst_type env exp.Typedtree.exp_type ;
+ sn_type = Odoc_env.subst_type env exp.Typedtree.exp_type ;
}
in
(new_param, body2)
(* no more parameter *)
[]
- (** Analysis of a [Parsetree.class_struture] and a [Typedtree.class_structure] to get a couple
+ (** 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 rec iter acc_inher acc_fields last_pos = function
- | [] ->
+ | [] ->
let s = get_string_of_file last_pos pos_limit in
let (_, ele_coms) = My_ir.all_special !file_name s in
let ele_comments =
with Not_found -> raise (Failure (Odoc_messages.inherit_classexp_not_found_in_typedtree n))
in
let (info_opt, ele_comments) =
- get_comments_in_class last_pos
- p_clexp.Parsetree.pcl_loc.Location.loc_start.Lexing.pos_cnum
+ get_comments_in_class last_pos
+ p_clexp.Parsetree.pcl_loc.Location.loc_start.Lexing.pos_cnum
in
let text_opt = match info_opt with None -> None | Some i -> i.Odoc_types.i_desc in
let name = tt_name_of_class_expr tt_clexp in
let inher =
- {
- ic_name = Odoc_env.full_class_or_class_type_name env name ;
- ic_class = None ;
+ {
+ ic_name = Odoc_env.full_class_or_class_type_name env name ;
+ ic_class = None ;
ic_text = text_opt ;
- }
+ }
in
iter (acc_inher @ [ inher ]) (acc_fields @ ele_comments)
p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum
in
let att =
{
- att_value = { val_name = complete_name ;
+ att_value = { val_name = complete_name ;
val_info = info_opt ;
val_type = Odoc_env.subst_type env type_exp ;
val_recursive = false ;
- val_parameters = [] ;
+ val_parameters = [] ;
val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
} ;
att_mutable = mutable_flag = Asttypes.Mutable ;
- }
+ }
in
iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end.Lexing.pos_cnum q
-
+
| (Parsetree.Pcf_virt (label, private_flag, _, loc)) :: q ->
let complete_name = Name.concat current_class_name label in
let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
- let met_type =
- try Odoc_sig.Signature_search.search_method_type label tt_class_sig
+ let met_type =
+ try Odoc_sig.Signature_search.search_method_type label tt_class_sig
with Not_found -> raise (Failure (Odoc_messages.method_type_not_found current_class_name label))
in
let real_type =
(* ?!? : not an arrow type ! return the original type *)
met_type
in
- let met =
+ let met =
{
met_value = { val_name = complete_name ;
val_info = info_opt ;
} ;
met_private = private_flag = Asttypes.Private ;
met_virtual = true ;
- }
+ }
in
(* update the parameter description *)
Odoc_value.update_value_parameters_text met.met_value;
| (Parsetree.Pcf_meth (label, private_flag, _, loc)) :: q ->
let complete_name = Name.concat current_class_name label in
let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
- let exp =
+ let exp =
try Typedtree_search.search_method_expression tt_cls label
with Not_found -> raise (Failure (Odoc_messages.method_not_found_in_typedtree complete_name))
in
(* ?!? : not an arrow type ! return the original type *)
exp.Typedtree.exp_type
in
- let met =
+ let met =
{
met_value = { val_name = complete_name ;
val_info = info_opt ;
} ;
met_private = private_flag = Asttypes.Private ;
met_virtual = false ;
- }
+ }
in
(* update the parameter description *)
Odoc_value.update_value_parameters_text met.met_value;
iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q
-
+
| Parsetree.Pcf_cstr (_, _, loc) :: q ->
(* don't give a $*%@ ! *)
iter acc_inher acc_fields loc.Location.loc_end.Lexing.pos_cnum q
iter acc_inher acc_fields exp.Parsetree.pexp_loc.Location.loc_end.Lexing.pos_cnum q
in
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 =
match (p_class_expr.Parsetree.pcl_desc, tt_class_exp.Typedtree.cl_desc) with
- (Parsetree.Pcl_constr (lid, _), tt_class_exp_desc ) ->
- let name =
+ (Parsetree.Pcl_constr (lid, _), tt_class_exp_desc ) ->
+ let name =
match tt_class_exp_desc with
- Typedtree.Tclass_ident p -> Name.from_path p
+ Typedtree.Tclass_ident p -> Name.from_path p
| _ ->
(* we try to get the name from the environment. *)
(* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *)
in
(* On n'a pas ici les paramètres de type sous forme de Types.type_expr,
par contre on peut les trouver dans le class_type *)
- let params =
+ let params =
match tt_class_exp.Typedtree.cl_type with
Types.Tcty_constr (p2, type_exp_list, cltyp) ->
(* cltyp is the class type for [type_exp_list] p *)
| _ ->
[]
in
- ([],
+ ([],
Class_constr
{
cco_name = Odoc_env.full_class_name env name ;
cco_class = None ;
- cco_type_parameters = List.map (Odoc_env.subst_type env) params ;
+ cco_type_parameters = List.map (Odoc_env.subst_type env) params ;
} )
| (Parsetree.Pcl_structure p_class_structure, Typedtree.Tclass_structure tt_class_structure) ->
(* we need the class signature to get the type of methods in analyse_class_structure *)
- let tt_class_sig =
+ let tt_class_sig =
match tt_class_exp.Typedtree.cl_type with
Types.Tcty_signature class_sig -> class_sig
| _ -> raise (Failure "analyse_class_kind: no class signature for a class structure.")
in
- let (inherited_classes, class_elements) = analyse_class_structure
+ let (inherited_classes, class_elements) = analyse_class_structure
env
- current_class_name
+ current_class_name
tt_class_sig
last_pos
p_class_expr.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum
in
([],
Class_structure (inherited_classes, class_elements) )
-
+
| (Parsetree.Pcl_fun (label, expression_opt, pattern, p_class_expr2),
Typedtree.Tclass_fun (pat, ident_exp_list, tt_class_expr2, partial)) ->
(* we check that this is not an optional parameter with
)
| _ ->
(* no optional parameter with default value, we create the parameter *)
- let new_param =
+ let new_param =
tt_param_info_from_pattern
env
(Odoc_parameter.desc_from_info_opt comment_opt)
because if the class applied has no name, the code is kinda ugly, isn't it ? *)
match tt_class_expr2.Typedtree.cl_desc with
Typedtree.Tclass_ident p -> Name.from_path p (* A VOIR : obtenir le nom complet *)
- | _ ->
+ | _ ->
(* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *)
match p_class_expr2.Parsetree.pcl_desc with
Parsetree.Pcl_constr (lid, _) ->
Odoc_messages.object_end
in
let param_exps = List.fold_left
- (fun acc -> fun (exp_opt, _) ->
- match exp_opt with
+ (fun acc -> fun (exp_opt, _) ->
+ match exp_opt with
None -> acc
| Some e -> acc @ [e])
[]
exp_opt_optional_list
in
let param_types = List.map (fun e -> e.Typedtree.exp_type) param_exps in
- let params_code =
- List.map
- (fun e -> get_string_of_file
+ let params_code =
+ List.map
+ (fun e -> get_string_of_file
e.exp_loc.Location.loc_start.Lexing.pos_cnum
e.exp_loc.Location.loc_end.Lexing.pos_cnum)
param_exps
| (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
-
- | (Parsetree.Pcl_constraint (p_class_expr2, p_class_type2),
+
+ | (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 class_type_kind =
+ let class_type_kind =
(*Sig.analyse_class_type_kind
env
""
let type_parameters = tt_type_params in
let virt = p_class_decl.Parsetree.pci_virt = Asttypes.Virtual in
let cltype = Odoc_env.subst_class_type env tt_class_exp.Typedtree.cl_type in
- let (parameters, kind) = analyse_class_kind
+ let (parameters, kind) = analyse_class_kind
env
complete_name
comment_opt
cl_kind = kind ;
cl_parameters = parameters ;
cl_loc = { loc_impl = Some (!file_name, pos_start) ; loc_inter = None } ;
- }
+ }
in
cl
Typedtree.Tmod_ident p -> Name.from_path p
| Typedtree.Tmod_constraint (m_exp, _, _) -> tt_name_from_module_expr m_exp
| Typedtree.Tmod_structure _
- | Typedtree.Tmod_functor _
+ | Typedtree.Tmod_functor _
| Typedtree.Tmod_apply _ ->
Odoc_messages.struct_end
im_name = tt_name_from_module_expr mod_expr ;
im_module = None ;
im_info = None ;
- }
- ]
+ }
+ ]
| _ ->
acc
in
| ([], _) ->
[]
| ((Element_included_module im) :: q, (im_repl :: im_q)) ->
- (Element_included_module { im_repl with im_info = im.im_info })
+ (Element_included_module { im_repl with im_info = im.im_info })
:: (f (q, im_q))
| ((Element_included_module im) :: q, []) ->
(Element_included_module im) :: q
f (module_elements, included_modules)
(** Analysis of a parse tree structure with a typed tree, to return module elements.*)
- let rec analyse_structure env current_module_name last_pos pos_limit parsetree typedtree =
+ let rec analyse_structure env current_module_name last_pos pos_limit parsetree typedtree =
print_DEBUG "Odoc_ast:analyse_struture";
let (table, table_values) = Typedtree_search.tables typedtree in
let rec iter env last_pos = function
- [] ->
+ [] ->
let s = get_string_of_file last_pos pos_limit in
let (_, ele_coms) = My_ir.all_special !file_name s in
let ele_comments =
ele_coms
in
ele_comments
- | item :: q ->
- let (comment_opt, ele_comments) =
- get_comments_in_module last_pos item.Parsetree.pstr_loc.Location.loc_start.Lexing.pos_cnum
+ | item :: q ->
+ let (comment_opt, ele_comments) =
+ get_comments_in_module last_pos item.Parsetree.pstr_loc.Location.loc_start.Lexing.pos_cnum
in
let pos_limit2 =
match q with
comment_opt
item.Parsetree.pstr_desc
typedtree
- table
+ table
table_values
in
ele_comments @ elements @ (iter new_env (item.Parsetree.pstr_loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q)
iter env last_pos parsetree
(** Analysis of a parse tree structure item to obtain a new environment and a list of elements.*)
- and analyse_structure_item env current_module_name loc pos_limit comment_opt parsetree_item_desc typedtree
- table table_values =
+ and analyse_structure_item env current_module_name loc pos_limit comment_opt parsetree_item_desc typedtree
+ table table_values =
print_DEBUG "Odoc_ast:analyse_struture_item";
match parsetree_item_desc with
Parsetree.Pstr_eval _ ->
(comment_opt, [])
else
get_comments_in_module
- last_pos
+ last_pos
pat.Parsetree.ppat_loc.Location.loc_start.Lexing.pos_cnum
in
- let l_values = tt_analyse_value
+ let l_values = tt_analyse_value
env
current_module_name
info_opt
pat_exp
rec_flag
in
- let new_env = List.fold_left
+ let new_env = List.fold_left
(fun e -> fun v ->
Odoc_env.add_value e v.val_name
)
l_values
in
let l_ele = List.map (fun v -> Element_value v) l_values in
- iter
- new_last_pos
- new_env
+ iter
+ new_last_pos
+ new_env
(acc @ ele_comments @ l_ele)
q
with
val_parameters = [] ;
val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
- }
+ }
in
let new_env = Odoc_env.add_value env new_value.val_name in
(0, new_env, [Element_value new_value])
(* of (string * type_declaration) list *)
(* we start by extending the environment *)
let new_env =
- List.fold_left
+ List.fold_left
(fun acc_env -> fun (name, _) ->
let complete_name = Name.concat current_module_name name in
Odoc_env.add_type acc_env complete_name
let complete_name = Name.concat current_module_name name in
let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in
let loc_end = type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum in
- let pos_limit2 =
- match q with
+ let pos_limit2 =
+ match q with
[] -> pos_limit
| (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum
in
- let (maybe_more, name_comment_list) =
+ let (maybe_more, name_comment_list) =
Sig.name_comment_from_type_kind
- loc_start loc_end
+ loc_end
pos_limit2
type_decl.Parsetree.ptype_kind
in
- let tt_type_decl =
- try Typedtree_search.search_type_declaration table name
+ let tt_type_decl =
+ try Typedtree_search.search_type_declaration table name
with Not_found -> raise (Failure (Odoc_messages.type_not_found_in_typedtree complete_name))
in
let (com_opt, ele_comments) = (* the comment for the first type was already retrieved *)
{
ty_name = complete_name ;
ty_info = com_opt ;
- ty_parameters =
+ ty_parameters =
List.map2
(fun p (co,cn,_) ->
(Odoc_env.subst_type new_env p,
None -> None
| Some t -> Some (Odoc_env.subst_type new_env t));
ty_loc = { loc_impl = Some (!file_name, loc_start) ; loc_inter = None } ;
- ty_code =
+ ty_code =
(
if !Odoc_args.keep_code then
- Some (get_string_of_file loc_start new_end)
+ Some (get_string_of_file loc_start new_end)
else
None
) ;
- }
+ }
in
- let (maybe_more2, info_after_opt) =
+ let (maybe_more2, info_after_opt) =
My_ir.just_after_special
!file_name
(get_string_of_file new_end pos_limit2)
(* a new exception is defined *)
let complete_name = Name.concat current_module_name name in
(* we get the exception declaration in the typed tree *)
- let tt_excep_decl =
- try Typedtree_search.search_exception table name
- with Not_found ->
+ let tt_excep_decl =
+ try Typedtree_search.search_exception table name
+ with Not_found ->
raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name))
in
let new_env = Odoc_env.add_exception env complete_name in
let loc_start = loc.Location.loc_start.Lexing.pos_cnum in
let loc_end = loc.Location.loc_end.Lexing.pos_cnum in
- let new_ex =
+ let new_ex =
{
ex_name = complete_name ;
ex_info = comment_opt ;
ex_args = List.map (Odoc_env.subst_type new_env) tt_excep_decl ;
ex_alias = None ;
ex_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
- ex_code =
+ ex_code =
(
if !Odoc_args.keep_code then
Some (get_string_of_file loc_start loc_end)
else
None
) ;
- }
+ }
in
(0, new_env, [ Element_exception new_ex ])
(* a new exception is defined *)
let complete_name = Name.concat current_module_name name in
(* we get the exception rebind in the typed tree *)
- let tt_path =
- try Typedtree_search.search_exception_rebind table name
- with Not_found ->
+ let tt_path =
+ try Typedtree_search.search_exception_rebind table name
+ with Not_found ->
raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name))
in
let new_env = Odoc_env.add_exception env complete_name in
- let new_ex =
+ let new_ex =
{
ex_name = complete_name ;
ex_info = comment_opt ;
ea_ex = None ; } ;
ex_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
ex_code = None ;
- }
+ }
in
(0, new_env, [ Element_exception new_ex ])
(* of string * module_expr *)
try
let tt_module_expr = Typedtree_search.search_module table name in
- let new_module_pre = analyse_module
+ let new_module_pre = analyse_module
env
current_module_name
name
module_expr
tt_module_expr
in
- let code =
+ let code =
if !Odoc_args.keep_code then
let loc = module_expr.Parsetree.pmod_loc in
let st = loc.Location.loc_start.Lexing.pos_cnum in
{ new_module_pre with m_code = code }
in
let new_env = Odoc_env.add_module env new_module.m_name in
- let new_env2 =
+ let new_env2 =
match new_module.m_type with
(* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
- Types.Tmty_signature s ->
+ Types.Tmty_signature s ->
Odoc_env.add_signature new_env new_module.m_name
~rel: (Name.simple new_module.m_name) s
- | _ ->
+ | _ ->
new_env
in
(0, new_env2, [ Element_module new_module ])
)
| Parsetree.Pstr_recmodule mods ->
- (* A VOIR ICI ca merde avec /work/tmp/graph.ml: pas de lien avec les module type
+ (* A VOIR ICI ca merde avec /work/tmp/graph.ml: pas de lien avec les module type
dans les contraintes sur les modules *)
let new_env =
- List.fold_left
+ List.fold_left
(fun acc_env (name, _, mod_exp) ->
let complete_name = Name.concat current_module_name name in
let e = Odoc_env.add_module acc_env complete_name in
- let tt_mod_exp =
- try Typedtree_search.search_module table name
+ let tt_mod_exp =
+ try Typedtree_search.search_module table name
with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))
in
- let new_module = analyse_module
+ let new_module = analyse_module
e
current_module_name
name
tt_mod_exp
in
match new_module.m_type with
- Types.Tmty_signature s ->
+ Types.Tmty_signature s ->
Odoc_env.add_signature e new_module.m_name
~rel: (Name.simple new_module.m_name) s
- | _ ->
+ | _ ->
e
)
env
let complete_name = Name.concat current_module_name name in
let loc_start = mod_exp.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in
let loc_end = mod_exp.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in
- let pos_limit2 =
- match q with
- [] -> pos_limit
- | (_, _, me) :: _ -> me.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum
- in
- let tt_mod_exp =
- try Typedtree_search.search_module table name
+ let tt_mod_exp =
+ try Typedtree_search.search_module table name
with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))
in
let (com_opt, ele_comments) = (* the comment for the first type was already retrieved *)
else
get_comments_in_module last_pos loc_start
in
- let new_module = analyse_module
+ let new_module = analyse_module
new_env
current_module_name
name
let complete_name = Name.concat current_module_name name in
let tt_module_type =
try Typedtree_search.search_module_type table name
- with Not_found ->
+ with Not_found ->
raise (Failure (Odoc_messages.module_type_not_found_in_typedtree complete_name))
in
let kind = Sig.analyse_module_type_kind env complete_name
modtype tt_module_type
in
- let mt =
+ let mt =
{
mt_name = complete_name ;
mt_info = comment_opt ;
mt_type = Some tt_module_type ;
mt_is_interface = false ;
mt_file = !file_name ;
- mt_kind = Some kind ;
+ mt_kind = Some kind ;
mt_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
- }
+ }
in
let new_env = Odoc_env.add_module_type env mt.mt_name in
let new_env2 =
- match tt_module_type with
+ match tt_module_type with
(* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on n'aurait pas la signature *)
- Types.Tmty_signature s ->
+ Types.Tmty_signature s ->
Odoc_env.add_signature new_env mt.mt_name ~rel: (Name.simple mt.mt_name) s
- | _ ->
+ | _ ->
new_env
in
(0, new_env2, [ Element_module_type mt ])
-
+
| Parsetree.Pstr_open longident ->
(* A VOIR : enrichir l'environnement quand open ? *)
let ele_comments = match comment_opt with
| Parsetree.Pstr_class class_decl_list ->
(* we start by extending the environment *)
let new_env =
- List.fold_left
+ List.fold_left
(fun acc_env -> fun class_decl ->
let complete_name = Name.concat current_module_name class_decl.Parsetree.pci_name in
Odoc_env.add_class acc_env complete_name
[]
| class_decl :: q ->
let (tt_class_exp, tt_type_params) =
- try Typedtree_search.search_class_exp table class_decl.Parsetree.pci_name
+ try Typedtree_search.search_class_exp table class_decl.Parsetree.pci_name
with Not_found ->
let complete_name = Name.concat current_module_name class_decl.Parsetree.pci_name in
raise (Failure (Odoc_messages.class_not_found_in_typedtree complete_name))
if first then
(comment_opt, [])
else
- get_comments_in_module last_pos class_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
+ get_comments_in_module last_pos class_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
in
let last_pos2 = class_decl.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in
- let new_class = analyse_class
+ let new_class = analyse_class
new_env
current_module_name
com_opt
| Parsetree.Pstr_class_type class_type_decl_list ->
(* we start by extending the environment *)
let new_env =
- List.fold_left
+ List.fold_left
(fun acc_env -> fun class_type_decl ->
let complete_name = Name.concat current_module_name class_type_decl.Parsetree.pci_name in
Odoc_env.add_class_type acc_env complete_name
let complete_name = Name.concat current_module_name name in
let virt = class_type_decl.Parsetree.pci_virt = Asttypes.Virtual in
let tt_cltype_declaration =
- try Typedtree_search.search_class_type_declaration table name
- with Not_found ->
+ try Typedtree_search.search_class_type_declaration table name
+ with Not_found ->
raise (Failure (Odoc_messages.class_type_not_found_in_typedtree complete_name))
in
let type_params = tt_cltype_declaration.Types.clty_params in
if first then
(comment_opt, [])
else
- get_comments_in_module last_pos class_type_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
+ get_comments_in_module last_pos class_type_decl.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum
in
let last_pos2 = class_type_decl.Parsetree.pci_loc.Location.loc_end.Lexing.pos_cnum in
let new_ele =
clt_type_parameters = List.map (Odoc_env.subst_type new_env) type_params ;
clt_virtual = virt ;
clt_kind = kind ;
- clt_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ;
+ clt_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ;
loc_inter = None } ;
- }
+ }
in
ele_comments @ (new_ele :: (f last_pos2 q))
in
(* we add a dummy included module which will be replaced by a correct
one at the end of the module analysis,
to use the Path.t of the included modules in the typdtree. *)
- let im =
+ let im =
{
im_name = "dummy" ;
im_module = None ;
im_info = comment_opt ;
- }
+ }
in
(0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *)
let complete_name = Name.concat current_module_name module_name in
let pos_start = p_module_expr.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in
let pos_end = p_module_expr.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in
- let modtype =
+ let modtype =
(* A VOIR : Odoc_env.subst_module_type env ? *)
- tt_module_expr.Typedtree.mod_type
+ tt_module_expr.Typedtree.mod_type
in
let m_code_intf =
match p_module_expr.Parsetree.pmod_desc with
m_top_deps = [] ;
m_code = None ; (* code is set by the caller, after the module is created *)
m_code_intf = m_code_intf ;
- }
+ }
in
match (p_module_expr.Parsetree.pmod_desc, tt_module_expr.Typedtree.mod_desc) with
(Parsetree.Pmod_ident longident, Typedtree.Tmod_ident path) ->
let alias_name = Odoc_env.full_module_name env (Name.from_path path) in
- { m_base with m_kind = Module_alias { ma_name = alias_name ;
+ { m_base with m_kind = Module_alias { ma_name = alias_name ;
ma_module = None ; } }
-
+
| (Parsetree.Pmod_structure p_structure, Typedtree.Tmod_structure tt_structure) ->
let elements = analyse_structure env complete_name pos_start pos_end p_structure tt_structure in
(* we must complete the included modules *)
let elements2 = replace_dummy_included_modules elements included_modules_from_tt in
{ m_base with m_kind = Module_struct elements2 }
- | (Parsetree.Pmod_functor (_, pmodule_type, p_module_expr2),
+ | (Parsetree.Pmod_functor (_, pmodule_type, p_module_expr2),
Typedtree.Tmod_functor (ident, mtyp, tt_module_expr2)) ->
let loc_start = pmodule_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in
let loc_end = pmodule_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in
let mp_type_code = get_string_of_file loc_start loc_end in
print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);
let mp_name = Name.from_ident ident in
- let mp_kind = Sig.analyse_module_type_kind env
+ let mp_kind = Sig.analyse_module_type_kind env
current_module_name pmodule_type mtyp
in
let param =
mp_type = Odoc_env.subst_module_type env mtyp ;
mp_type_code = mp_type_code ;
mp_kind = mp_kind ;
- }
+ }
in
let dummy_complete_name = (*Name.concat "__"*) param.mp_name in
(* TODO: A VOIR CE __ *)
let new_env = Odoc_env.add_module env dummy_complete_name in
- let m_base2 = analyse_module
+ let m_base2 = analyse_module
new_env
current_module_name
module_name
let kind = m_base2.m_kind in
{ m_base with m_kind = Module_functor (param, kind) }
- | (Parsetree.Pmod_apply (p_module_expr1, p_module_expr2),
+ | (Parsetree.Pmod_apply (p_module_expr1, p_module_expr2),
Typedtree.Tmod_apply (tt_module_expr1, tt_module_expr2, _))
| (Parsetree.Pmod_apply (p_module_expr1, p_module_expr2),
- Typedtree.Tmod_constraint
- ({ Typedtree.mod_desc = Typedtree.Tmod_apply (tt_module_expr1, tt_module_expr2, _)},
+ Typedtree.Tmod_constraint
+ ({ Typedtree.mod_desc = Typedtree.Tmod_apply (tt_module_expr1, tt_module_expr2, _)},
_, _)
) ->
- let m1 = analyse_module
+ let m1 = analyse_module
env
current_module_name
module_name
in
{ m_base with m_kind = Module_apply (m1.m_kind, m2.m_kind) }
- | (Parsetree.Pmod_constraint (p_module_expr2, p_modtype),
+ | (Parsetree.Pmod_constraint (p_module_expr2, p_modtype),
Typedtree.Tmod_constraint (tt_module_expr2, tt_modtype, _)) ->
print_DEBUG ("Odoc_ast: case Parsetree.Pmod_constraint + Typedtree.Tmod_constraint "^module_name);
- (* we create the module with p_module_expr2 and tt_module_expr2
- but we change its type according to the constraint.
+ (* we create the module with p_module_expr2 and tt_module_expr2
+ but we change its type according to the constraint.
A VOIR : est-ce que c'est bien ?
*)
- let m_base2 = analyse_module
+ let m_base2 = analyse_module
env
current_module_name
module_name
p_module_expr2
tt_module_expr2
in
- let mtkind = Sig.analyse_module_type_kind
- env
+ let mtkind = Sig.analyse_module_type_kind
+ env
(Name.concat current_module_name "??")
p_modtype tt_modtype
in
- {
+ {
m_base with
- m_type = Odoc_env.subst_module_type env tt_modtype ;
- m_kind = Module_constraint (m_base2.m_kind,
+ m_type = Odoc_env.subst_module_type env tt_modtype ;
+ m_kind = Module_constraint (m_base2.m_kind,
mtkind)
(* Module_type_alias { mta_name = "Not analyzed" ;
mta_module = None })
*)
}
-
+
| (Parsetree.Pmod_structure p_structure,
- Typedtree.Tmod_constraint
- ({ Typedtree.mod_desc = Typedtree.Tmod_structure tt_structure},
+ Typedtree.Tmod_constraint
+ ({ Typedtree.mod_desc = Typedtree.Tmod_structure tt_structure},
tt_modtype, _)
) ->
(* needed for recursive modules *)
(* we must complete the included modules *)
let included_modules_from_tt = tt_get_included_module_list tt_structure in
let elements2 = replace_dummy_included_modules elements included_modules_from_tt in
- { m_base with
+ { m_base with
m_type = Odoc_env.subst_module_type env tt_modtype ;
m_kind = Module_struct elements2 ;
}
| (parsetree, typedtree) ->
- let s_parse =
- match parsetree with
- Parsetree.Pmod_ident _ -> "Pmod_ident"
- | Parsetree.Pmod_structure _ -> "Pmod_structure"
- | Parsetree.Pmod_functor _ -> "Pmod_functor"
- | Parsetree.Pmod_apply _ -> "Pmod_apply"
- | Parsetree.Pmod_constraint _ -> "Pmod_constraint"
- in
- let s_typed =
- match typedtree with
- Typedtree.Tmod_ident _ -> "Tmod_ident"
- | Typedtree.Tmod_structure _ -> "Tmod_structure"
- | Typedtree.Tmod_functor _ -> "Tmod_functor"
- | Typedtree.Tmod_apply _ -> "Tmod_apply"
- | Typedtree.Tmod_constraint _ -> "Tmod_constraint"
- in
- let code = get_string_of_file pos_start pos_end in
+ (*DEBUG*)let s_parse =
+ (*DEBUG*) match parsetree with
+ (*DEBUG*) Parsetree.Pmod_ident _ -> "Pmod_ident"
+ (*DEBUG*) | Parsetree.Pmod_structure _ -> "Pmod_structure"
+ (*DEBUG*) | Parsetree.Pmod_functor _ -> "Pmod_functor"
+ (*DEBUG*) | Parsetree.Pmod_apply _ -> "Pmod_apply"
+ (*DEBUG*) | Parsetree.Pmod_constraint _ -> "Pmod_constraint"
+ (*DEBUG*)in
+ (*DEBUG*)let s_typed =
+ (*DEBUG*) match typedtree with
+ (*DEBUG*) Typedtree.Tmod_ident _ -> "Tmod_ident"
+ (*DEBUG*) | Typedtree.Tmod_structure _ -> "Tmod_structure"
+ (*DEBUG*) | Typedtree.Tmod_functor _ -> "Tmod_functor"
+ (*DEBUG*) | Typedtree.Tmod_apply _ -> "Tmod_apply"
+ (*DEBUG*) | Typedtree.Tmod_constraint _ -> "Tmod_constraint"
+ (*DEBUG*)in
+ (*DEBUG*)let code = get_string_of_file pos_start pos_end in
print_DEBUG (Printf.sprintf "code=%s\ns_parse=%s\ns_typed=%s\n" code s_parse s_typed);
-
+
raise (Failure "analyse_module: parsetree and typedtree don't match.")
- let analyse_typed_tree source_file input_file
- (parsetree : Parsetree.structure) (typedtree : typedtree) =
+ let analyse_typed_tree source_file input_file
+ (parsetree : Parsetree.structure) (typedtree : typedtree) =
let (tree_structure, _) = typedtree in
let complete_source_file =
try
(* We create the t_module for this file. *)
let mod_name = String.capitalize (Filename.basename (Filename.chop_extension source_file)) in
let (len,info_opt) = My_ir.first_special !file_name !file in
-
+
(* we must complete the included modules *)
let elements = analyse_structure Odoc_env.empty mod_name len (String.length !file) parsetree tree_structure in
let included_modules_from_tt = tt_get_included_module_list tree_structure in
m_top_deps = [] ;
m_code = (if !Odoc_args.keep_code then Some !file else None) ;
m_code_intf = None ;
- }
+ }
end
-(* eof $Id: odoc_ast.ml,v 1.24 2004/04/17 12:36:14 guesdon Exp $ *)
+(* eof $Id: odoc_ast.ml,v 1.26 2004/12/03 14:42:09 guesdon Exp $ *)
(* *)
(***********************************************************************)
-(* $Id: odoc_dag2html.ml,v 1.3 2003/11/24 10:39:30 starynke Exp $ *)
+(* $Id: odoc_dag2html.ml,v 1.4 2004/12/03 14:42:09 guesdon Exp $ *)
(** The types and functions to create a html table representing a dag. Thanks to Daniel De Rauglaudre. *)
| Ghost _ -> false
| Nothing -> true
in
- let jlast = Array.length t.table.(0) - 1 in
let elem_txt =
function
Elem e -> indi_txt d.dag.(int_of_idag e)
let no_group = ref false;;
let html_of_dag d =
- let print_indi n = print_string n.valu in
let t = table_of_dag phony !no_optim !invert !no_group d in
let hts = html_table_struct indi_txt phony d t in
string_table !border hts
(********************************* Max's code **********************************)
-(** This function takes a list of classes and a list of class types
+(** This function takes a list of classes and a list of class types
and create the associate dag. *)
let create_class_dag cl_list clt_list =
let module M = Odoc_info.Class in
let clt_list2 = List.map (fun ct -> (ct.M.clt_name, Some (M.Cltype (ct, [])))) clt_list in
let list = cl_list2 @ clt_list2 in
let all_classes =
- let rec iter list2 =
+ let rec iter list2 =
List.fold_left
- (fun acc -> fun (name, cct_opt) ->
- let l =
+ (fun acc -> fun (name, cct_opt) ->
+ let l =
match cct_opt with
None -> []
| Some (M.Cl c) ->
- iter
- (List.map
+ iter
+ (List.map
(fun inh ->(inh.M.ic_name, inh.M.ic_class))
(match c.M.cl_kind with
M.Class_structure (inher_l, _) ->
)
)
| Some (M.Cltype (ct, _)) ->
- iter
- (List.map
+ iter
+ (List.map
(fun inh ->(inh.M.ic_name, inh.M.ic_class))
(match ct.M.clt_kind with
M.Class_signature (inher_l, _) ->
distinct ((name, cct_opt) :: acc) q
in
let distinct_classes = distinct [] all_classes in
- let liste_index =
+ let liste_index =
let rec f n = function
[] -> []
| (name, _) :: q -> (name, n) :: (f (n+1) q)
in
let array1 = Array.of_list distinct_classes in
(* create the dag array, filling parents and values *)
- let fmap (name, cct_opt) =
+ let fmap (name, cct_opt) =
{ pare = List.map
(fun inh -> List.assoc inh.M.ic_name liste_index )
(match cct_opt with
);
valu = (name, cct_opt) ;
chil = []
- }
+ }
in
let dag = { dag = Array.map fmap array1 } in
(* fill the children *)
in
Array.iteri fiter dag.dag;
dag
-
-
-
-
(* *)
(***********************************************************************)
-(* $Id: odoc_html.ml,v 1.52.4.3 2005/07/07 13:40:29 guesdon Exp $ *)
+(* $Id: odoc_html.ml,v 1.58 2005/08/16 00:48:56 garrigue Exp $ *)
(** Generation of html documentation. *)
self#html_of_text b t;
bs b "</sub>"
+ method virtual html_of_info_first_sentence : _
+
method html_of_Module_list b l =
bs b "<br>\n<table class=\"indextable\">\n";
List.iter
(** Generate the module types index in the file [index_module_types.html]. *)
method generate_module_types_index module_list =
- let module_types = Odoc_info.Search.module_types module_list in
self#generate_elements_index
self#list_module_types
(fun mt -> mt.mt_name)
)
end
-
-
-(* eof $Id: odoc_html.ml,v 1.52.4.3 2005/07/07 13:40:29 guesdon Exp $ *)
+(* eof $Id: odoc_html.ml,v 1.58 2005/08/16 00:48:56 garrigue Exp $ *)
(* *)
(***********************************************************************)
-(* $Id: odoc_info.ml,v 1.20.4.2 2005/07/07 14:34:18 guesdon Exp $ *)
+(* $Id: odoc_info.ml,v 1.22 2005/08/13 20:59:37 doligez Exp $ *)
(** Interface for analysing documented OCaml source files and to the collected information. *)
(* *)
(***********************************************************************)
-(* $Id: odoc_info.mli,v 1.36.4.3 2005/02/18 16:08:37 guesdon Exp $ *)
+(* $Id: odoc_info.mli,v 1.38 2005/03/24 17:20:53 doligez Exp $ *)
(** Interface to the information collected in source files. *)
(* *)
(***********************************************************************)
-(* $Id: odoc_latex.ml,v 1.36.2.2 2004/08/06 12:35:07 guesdon Exp $ *)
+(* $Id: odoc_latex.ml,v 1.38 2004/08/20 17:04:35 doligez Exp $ *)
(** Generation of LaTeX documentation. *)
prerr_endline s ;
incr Odoc_info.errors
end
-
-(* eof $Id: odoc_latex.ml,v 1.36.2.2 2004/08/06 12:35:07 guesdon Exp $ *)
(* *)
(***********************************************************************)
-(* $Id: odoc_man.ml,v 1.22.4.4 2005/07/07 09:12:05 guesdon Exp $ *)
+(* $Id: odoc_man.ml,v 1.25 2005/08/13 20:59:37 doligez Exp $ *)
(** The man pages generator. *)
open Odoc_info
);
bs b (Name.simple c.cl_name);
bs b " : " ;
- self#man_of_class_type_expr b (Name.father c.cl_name) c.cl_type;
+ self#man_of_class_type_expr b father c.cl_type;
bs b "\n.sp\n";
self#man_of_info b c.cl_info;
bs b "\n.sp\n"
(* *)
(***********************************************************************)
-(* $Id: odoc_messages.ml,v 1.24.4.6 2005/07/07 13:40:29 guesdon Exp $ *)
+(* $Id: odoc_messages.ml,v 1.28 2005/08/13 20:59:37 doligez Exp $ *)
(** The messages of the application. *)
"\t\t(default is \""^default_latex_class_prefix^"\")"
let default_latex_class_type_prefix = "classtype:"
-let latex_class_type_prefix =
+let latex_class_type_prefix =
"<string>\n\t\tUse <string> as prefix for the LaTeX labels of class types.\n"^
"\t\t(default is \""^default_latex_class_type_prefix^"\")"
(* *)
(***********************************************************************)
-(* $Id: odoc_misc.ml,v 1.17.4.2 2004/10/01 09:43:24 guesdon Exp $ *)
+(* $Id: odoc_misc.ml,v 1.19 2005/03/24 17:20:53 doligez Exp $ *)
let input_file_as_string nom =
let chanin = open_in_bin nom in
in
{ typ with Types.desc = iter typ.Types.desc }
-(* eof $Id: odoc_misc.ml,v 1.17.4.2 2004/10/01 09:43:24 guesdon Exp $ *)
+(* eof $Id: odoc_misc.ml,v 1.19 2005/03/24 17:20:53 doligez Exp $ *)
(* *)
(***********************************************************************)
-(* $Id: odoc_misc.mli,v 1.10.4.2 2004/10/01 09:43:24 guesdon Exp $ *)
+(* $Id: odoc_misc.mli,v 1.12 2005/03/24 17:20:53 doligez Exp $ *)
(** Miscelaneous functions *)
(* *)
(***********************************************************************)
-(* $Id: odoc_module.ml,v 1.9.4.1 2004/06/25 13:39:17 guesdon Exp $ *)
+(* $Id: odoc_module.ml,v 1.10 2004/07/13 12:25:12 xleroy Exp $ *)
(** Representation and manipulation of modules and module types. *)
(* *)
(***********************************************************************)
-(* $Id: odoc_sig.ml,v 1.30.2.4 2005/06/23 14:23:27 guesdon Exp $ *)
+(* $Id: odoc_sig.ml,v 1.36 2005/08/13 20:59:37 doligez Exp $ *)
(** Analysis of interface files. *)
let merge_infos = Odoc_merge.merge_info_opt Odoc_types.all_merge_options
- let name_comment_from_type_kind pos_start pos_end pos_limit tk =
+ let name_comment_from_type_kind pos_end pos_limit tk =
match tk with
- Parsetree.Ptype_abstract ->
+ Parsetree.Ptype_abstract | Parsetree.Ptype_private ->
(0, [])
| Parsetree.Ptype_variant (cons_core_type_list_list, _) ->
- (*of (string * core_type list) list *)
- let rec f acc last_pos cons_core_type_list_list =
+ let rec f acc cons_core_type_list_list =
match cons_core_type_list_list with
[] ->
(0, acc)
- | (name, core_type_list) :: [] ->
- let pos = Str.search_forward (Str.regexp_string name) !file last_pos in
- let s = get_string_of_file pos_end pos_limit in
+ | (name, core_type_list, loc) :: [] ->
+ let s = get_string_of_file
+ loc.Location.loc_end.Lexing.pos_cnum
+ pos_limit
+ in
let (len, comment_opt) = My_ir.just_after_special !file_name s in
(len, acc @ [ (name, comment_opt) ])
-
- | (name, core_type_list) :: (name2, core_type_list2) :: q ->
- match (List.rev core_type_list, core_type_list2) with
- ([], []) ->
- let pos = Str.search_forward (Str.regexp_string name) !file last_pos in
- let pos' = pos + (String.length name) in
- let pos2 =
- try Str.search_forward
- (Str.regexp ("|[ \n\t\r]*"^name2)) !file pos'
- with Not_found ->
- failwith (Odoc_messages.misplaced_comment !file_name pos')
- in
- let s = get_string_of_file pos' pos2 in
- let (_,comment_opt) = My_ir.just_after_special !file_name s in
- f (acc @ [name, comment_opt]) pos2 ((name2, core_type_list2) :: q)
-
- | ([], (ct2 :: _)) ->
- let pos = Str.search_forward (Str.regexp_string name) !file last_pos in
- let pos' = pos + (String.length name) in
- let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in
- let pos2' =
- try Str.search_backward
- (Str.regexp ("|[ \n\t\r]*"^name2)) !file pos2
- with Not_found ->
- failwith (Odoc_messages.misplaced_comment !file_name pos')
- in
- let s = get_string_of_file pos' pos2' in
- let (_,comment_opt) = My_ir.just_after_special !file_name s in
- f (acc @ [name, comment_opt]) pos2' ((name2, core_type_list2) :: q)
-
- | ((ct :: _), []) ->
- let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
- let pos2 =
- try
- Str.search_forward
- (Str.regexp ("|[ \n\t\r]*"^name2))
- !file pos
- with Not_found ->
- failwith (Odoc_messages.misplaced_comment !file_name pos)
- in
- let s = get_string_of_file pos pos2 in
- let (_,comment_opt) = My_ir.just_after_special !file_name s in
- let new_pos_end =
- match comment_opt with
- None -> ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum
- | Some _ -> Str.search_forward (Str.regexp "*)") !file pos
- in
- f (acc @ [name, comment_opt]) new_pos_end ((name2, core_type_list2) :: q)
-
- | ((ct:: _), (ct2 :: _)) ->
- let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
- let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in
- let pos2' =
- try Str.search_backward
- (Str.regexp ("|[ \n\t\r]*"^name2)) !file pos2
- with Not_found ->
- failwith (Odoc_messages.misplaced_comment !file_name pos)
- in
- let s = get_string_of_file pos pos2' in
- let (_,comment_opt) = My_ir.just_after_special !file_name s in
- f (acc @ [name, comment_opt]) pos2' ((name2, core_type_list2) :: q)
-
+ | (name, core_type_list, loc) :: (name2, core_type_list2, loc2)
+ :: q ->
+ let pos_end_first = loc.Location.loc_end.Lexing.pos_cnum in
+ let pos_start_second = loc2.Location.loc_start.Lexing.pos_cnum in
+ let s = get_string_of_file pos_end_first pos_start_second in
+ let (_,comment_opt) = My_ir.just_after_special !file_name s in
+ f (acc @ [name, comment_opt])
+ ((name2, core_type_list2, loc2) :: q)
in
- f [] pos_start cons_core_type_list_list
+ f [] cons_core_type_list_list
| Parsetree.Ptype_record (name_mutable_type_list, _) (* of (string * mutable_flag * core_type) list*) ->
let rec f = function
[] ->
[]
- | (name, _, ct) :: [] ->
+ | (name, _, ct, xxloc) :: [] ->
let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
let s = get_string_of_file pos pos_end in
let (_,comment_opt) = My_ir.just_after_special !file_name s in
[name, comment_opt]
- | (name,_,ct) :: ((name2,_,ct2) as ele2) :: q ->
+ | (name,_,ct,xxloc) :: ((name2,_,ct2,xxloc2) as ele2) :: q ->
let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in
let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in
let s = get_string_of_file pos pos2 in
in
let (maybe_more, name_comment_list) =
name_comment_from_type_kind
- type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum
type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum
pos_limit2
type_decl.Parsetree.ptype_kind
}
end
-
-(* eof $Id: odoc_sig.ml,v 1.30.2.4 2005/06/23 14:23:27 guesdon Exp $ *)
(* *)
(***********************************************************************)
-(* $Id: odoc_sig.mli,v 1.5 2003/11/24 10:43:12 starynke Exp $ *)
+(* $Id: odoc_sig.mli,v 1.6 2004/11/03 09:31:19 guesdon Exp $ *)
(** The module for analysing a signature and source code and creating modules, classes, ..., elements.*)
val table : Types.signature -> tab
(** This function returns the type expression for the value whose name is given,
- in the given signature.
+ in the given signature.
@raise Not_found if error.*)
val search_value : tab -> string -> Types.type_expr
(** This function returns the type expression list for the exception whose name is given,
- in the given table.
+ in the given table.
@raise Not_found if error.*)
val search_exception : tab -> string -> Types.exception_declaration
-
+
(** This function returns the Types.type_declaration for the type whose name is given,
- in the given table.
+ in the given table.
@raise Not_found if error.*)
val search_type : tab -> string -> Types.type_declaration
-
+
(** This function returns the Types.class_declaration for the class whose name is given,
- in the given table.
+ in the given table.
@raise Not_found if error.*)
val search_class : tab -> string -> Types.class_declaration
(** This function returns the Types.cltype_declaration for the class type whose name is given,
- in the given table.
+ in the given table.
@raise Not_found if error.*)
val search_class_type : tab -> string -> Types.cltype_declaration
(** This function returns the Types.module_type for the module whose name is given,
- in the given table.
+ in the given table.
@raise Not_found if error.*)
val search_module : tab -> string -> Types.module_type
(** This function returns the optional Types.module_type for the module type whose name is given,
- in the given table.
+ in the given table.
@raise Not_found if error.*)
val search_module_type : tab -> string -> Types.module_type option
(** This function returns the Types.type_expr for the given val name
- in the given class signature.
+ in the given class signature.
@raise Not_found if error.*)
val search_attribute_type :
Types.Vars.key -> Types.class_signature -> Types.type_expr
(** This function returns the Types.type_expr for the given method name
- in the given class signature.
+ in the given class signature.
@raise Not_found if error.*)
val search_method_type :
string -> Types.class_signature -> Types.type_expr
end
-
+
(** Functions to retrieve simple and special comments from strings. *)
module type Info_retriever =
sig
string -> string -> bool
(** [just_after_special file str] return the pair ([length], [info_opt])
- where [info_opt] is the first optional special comment found
+ where [info_opt] is the first optional special comment found
in [str], without any blank line before. [length] is the number
of chars from the beginning of [str] to the end of the special comment. *)
val just_after_special :
string -> string -> (int * Odoc_types.info option)
(** [first_special file str] return the pair ([length], [info_opt])
- where [info_opt] is the first optional special comment found
+ where [info_opt] is the first optional special comment found
in [str]. [length] is the number of chars from the beginning of [str]
to the end of the special comment. *)
val first_special :
string -> string -> (int * Odoc_types.info option)
(** Return a pair [(comment_opt, element_comment_list)], where [comment_opt] is the last special
- comment found in the given string and not followed by a blank line,
+ comment found in the given string and not followed by a blank line,
and [element_comment_list] the list of values built from the other
special comments found and the given function. *)
- val get_comments :
+ val get_comments :
(Odoc_types.text -> 'a) -> string -> string -> (Odoc_types.info option * 'a list)
end
functor (My_ir : Info_retriever) ->
sig
(** This variable is used to load a file as a string and retrieve characters from it.*)
- val file : string ref
+ val file : string ref
(** The name of the analysed file. *)
val file_name : string ref
corresponding to the indexes in the file global variable. The function
prepare_file must have been called to fill the file global variable.*)
val get_string_of_file : int -> int -> string
-
+
(** [prepare_file f input_f] sets [file_name] with [f] and loads the file
[input_f] into [file].*)
val prepare_file : string -> string -> unit
-
+
(** The function used to get the comments in a class. *)
- val get_comments_in_class : int -> int ->
+ val get_comments_in_class : int -> int ->
(Odoc_types.info option * Odoc_class.class_element list)
(** The function used to get the comments in a module. *)
- val get_comments_in_module : int -> int ->
+ val get_comments_in_module : int -> int ->
(Odoc_types.info option * Odoc_module.module_element list)
- (** This function takes a [Parsetree.type_kind] and returns the list of
- (name, optional comment) for the various fields/constructors of the type,
+ (** [name_comment_from_type_kind pos_end pos_limit type_kind].
+ This function takes a [Parsetree.type_kind] and returns the list of
+ (name, optional comment) for the various fields/constructors of the type,
or an empty list for an abstract type.
- [pos_start] and [pos_end] are the first and last char of the complete type definition.
+ [pos_end] is last char of the complete type definition.
[pos_limit] is the position of the last char we could use to look for a comment,
i.e. usually the beginning on the next element.*)
- val name_comment_from_type_kind :
- int -> int -> int -> Parsetree.type_kind -> int * (string * Odoc_types.info option) list
+ val name_comment_from_type_kind :
+ int -> int -> Parsetree.type_kind -> int * (string * Odoc_types.info option) list
(** This function converts a [Types.type_kind] into a [Odoc_type.type_kind],
by associating the comment found in the parsetree of each constructor/field, if any.*)
- val get_type_kind :
- Odoc_env.env -> (string * Odoc_types.info option) list ->
+ val get_type_kind :
+ Odoc_env.env -> (string * Odoc_types.info option) list ->
Types.type_kind -> Odoc_type.type_kind
(** This function merge two optional info structures. *)
- val merge_infos :
- Odoc_types.info option -> Odoc_types.info option ->
+ val merge_infos :
+ Odoc_types.info option -> Odoc_types.info option ->
Odoc_types.info option
(** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *)
- val analyse_module_type_kind :
- Odoc_env.env -> Odoc_name.t ->
+ val analyse_module_type_kind :
+ Odoc_env.env -> Odoc_name.t ->
Parsetree.module_type -> Types.module_type ->
Odoc_module.module_type_kind
Odoc_name.t -> int -> Parsetree.class_type -> Types.class_type ->
Odoc_class.class_type_kind
- (** This function takes an interface file name, a file containg the code, a parse tree
+ (** This function takes an interface file name, a file containg the code, a parse tree
and the signature obtained from the compiler.
It goes through the parse tree, creating values for encountered
functions, modules, ..., looking in the source file for comments,
and in the signature for types information. *)
- val analyse_signature :
+ val analyse_signature :
string -> string ->
Parsetree.signature -> Types.signature -> Odoc_module.t_module
end
(* *)
(***********************************************************************)
-(* $Id: odoc_str.ml,v 1.9.4.2 2004/11/03 08:16:49 guesdon Exp $ *)
+(* $Id: odoc_str.ml,v 1.11 2005/03/24 17:20:53 doligez Exp $ *)
(** The functions to get a string from different kinds of elements (types, modules, ...). *)
None -> ""
| Some i -> Odoc_misc.string_of_info i)
-(* eof $Id: odoc_str.ml,v 1.9.4.2 2004/11/03 08:16:49 guesdon Exp $ *)
+(* eof $Id: odoc_str.ml,v 1.11 2005/03/24 17:20:53 doligez Exp $ *)
(* *)
(***********************************************************************)
-(* $Id: odoc_str.mli,v 1.5.4.1 2004/08/06 12:35:07 guesdon Exp $ *)
+(* $Id: odoc_str.mli,v 1.6 2004/08/20 17:04:35 doligez Exp $ *)
(** The functions to get a string from different kinds of elements (types, modules, ...). *)
(* under the terms of the Q Public License version 1.0. *)
(***********************************************************************)
-(* $Id: odoc_texi.ml,v 1.17.4.1 2004/07/02 12:59:48 guesdon Exp $ *)
+(* $Id: odoc_texi.ml,v 1.19 2004/11/29 02:27:25 garrigue Exp $ *)
(** Generation of Texinfo documentation. *)
(** this method is not used here but is virtual
in a class we will inherit later *)
- method label ?(no_ : bool option) (_ : string) =
- failwith "gni" ; ""
+ method label ?(no_ : bool option) (_ : string) : string =
+ failwith "gni"
(** Return the Texinfo code corresponding to the [text] parameter.*)
method texi_of_text t =
(* *)
(***********************************************************************)
-(* $Id: odoc_to_text.ml,v 1.14.4.2 2004/08/06 12:35:07 guesdon Exp $ *)
+(* $Id: odoc_to_text.ml,v 1.16 2004/08/20 17:04:35 doligez Exp $ *)
(** Text generation.
(* *)
(***********************************************************************)
-(* $Id: odoc_types.ml,v 1.7.4.2 2005/07/07 14:24:48 guesdon Exp $ *)
+(* $Id: odoc_types.ml,v 1.8 2005/08/13 20:59:37 doligez Exp $ *)
type ref_kind =
RK_module
(* *)
(***********************************************************************)
-(* $Id: odoc_value.ml,v 1.5.6.1 2004/07/02 12:59:49 guesdon Exp $ *)
+(* $Id: odoc_value.ml,v 1.6 2004/07/13 12:25:12 xleroy Exp $ *)
(** Representation and manipulation of values, class attributes and class methods. *)
# #
#########################################################################
-# $Id: Makefile,v 1.18 2002/06/27 11:36:00 xleroy Exp $
+# $Id: Makefile,v 1.21 2005/10/19 11:56:24 xleroy Exp $
include ../../config/Makefile
CC=$(BYTECC)
-CFLAGS=-I../../byterun -g -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)
+CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)
CAMLC=../../ocamlcomp.sh -I ../unix
CAMLOPT=../../ocamlcompopt.sh -I ../unix
MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
/* */
/***********************************************************************/
-/* $Id: bigarray.h,v 1.7 2003/07/08 14:24:07 xleroy Exp $ */
+/* $Id: bigarray.h,v 1.8 2005/09/22 14:21:50 xleroy Exp $ */
#ifndef _bigarray_
#define _bigarray_
-
+#include "config.h"
#include "mlvalues.h"
+typedef signed char int8;
+typedef unsigned char uint8;
+#if SIZEOF_SHORT == 2
+typedef short int16;
+typedef unsigned short uint16;
+#else
+#error "No 16-bit integer type available"
+#endif
+
#define MAX_NUM_DIMS 16
enum caml_bigarray_kind {
};
struct caml_bigarray_proxy {
- long refcount; /* Reference count */
+ intnat refcount; /* Reference count */
void * data; /* Pointer to base of actual data */
- unsigned long size; /* Size of data in bytes (if mapped file) */
+ uintnat size; /* Size of data in bytes (if mapped file) */
};
struct caml_bigarray {
void * data; /* Pointer to raw data */
- long num_dims; /* Number of dimensions */
- long flags; /* Kind of element array + memory layout + allocation status */
+ intnat num_dims; /* Number of dimensions */
+ intnat flags; /* Kind of element array + memory layout + allocation status */
struct caml_bigarray_proxy * proxy; /* The proxy for sub-arrays, or NULL */
- long dim[1] /*[num_dims]*/; /* Size in each dimension */
+ intnat dim[1] /*[num_dims]*/; /* Size in each dimension */
};
#define Bigarray_val(v) ((struct caml_bigarray *) Data_custom_val(v))
#define CAMLBAextern CAMLextern
#endif
-CAMLBAextern value alloc_bigarray(int flags, int num_dims, void * data, long * dim);
+CAMLBAextern value alloc_bigarray(int flags, int num_dims, void * data, intnat * dim);
CAMLBAextern value alloc_bigarray_dims(int flags, int num_dims, void * data,
- ... /*dimensions, with type long */);
+ ... /*dimensions, with type intnat */);
#endif
(* *)
(***********************************************************************)
-(* $Id: bigarray.ml,v 1.12 2002/05/25 08:34:05 xleroy Exp $ *)
+(* $Id: bigarray.ml,v 1.15 2005/09/24 08:38:45 xleroy Exp $ *)
(* Module [Bigarray]: large, multi-dimensional, numerical arrays *)
external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill"
let of_array kind layout data =
let ba = create kind layout (Array.length data) in
- let ofs = if (Obj.magic layout : 'a layout) = c_layout then 0 else 1 in
+ let ofs = if layout = c_layout then 0 else 1 in
for i = 0 to Array.length data - 1 do set ba (i + ofs) data.(i) done;
ba
let map_file fd kind layout shared dim =
let dim1 = Array.length data in
let dim2 = if dim1 = 0 then 0 else Array.length data.(0) in
let ba = create kind layout dim1 dim2 in
- let ofs = if (Obj.magic layout : 'a layout) = c_layout then 0 else 1 in
+ let ofs = if layout = c_layout then 0 else 1 in
for i = 0 to dim1 - 1 do
let row = data.(i) in
if Array.length row <> dim2 then
let dim2 = if dim1 = 0 then 0 else Array.length data.(0) in
let dim3 = if dim2 = 0 then 0 else Array.length data.(0).(0) in
let ba = create kind layout dim1 dim2 dim3 in
- let ofs = if (Obj.magic layout : 'a layout) = c_layout then 0 else 1 in
+ let ofs = if layout = c_layout then 0 else 1 in
for i = 0 to dim1 - 1 do
let row = data.(i) in
if Array.length row <> dim2 then
if Array.length col <> dim3 then
invalid_arg("Bigarray.Array3.of_array: non-cubic data");
for k = 0 to dim3 - 1 do
- set ba (i + ofs) (j + ofs) (k + ofs) col.(j)
+ set ba (i + ofs) (j + ofs) (k + ofs) col.(k)
done
done
done;
to those primitives directly in this file *)
let _ =
- let getN = Genarray.get in
- let get1 = Array1.get in
- let get2 = Array2.get in
- let get3 = Array3.get in
+ let _ = Genarray.get in
+ let _ = Array1.get in
+ let _ = Array2.get in
+ let _ = Array3.get in
()
(* *)
(***********************************************************************)
-(* $Id: bigarray.mli,v 1.21.6.1 2005/05/04 14:05:19 doligez Exp $ *)
+(* $Id: bigarray.mli,v 1.22 2005/08/13 20:59:37 doligez Exp $ *)
(** Large, multi-dimensional, numerical arrays.
/* */
/***********************************************************************/
-/* $Id: bigarray_stubs.c,v 1.19.4.1 2005/02/22 14:33:36 doligez Exp $ */
+/* $Id: bigarray_stubs.c,v 1.21 2005/09/22 14:21:50 xleroy Exp $ */
#include <stddef.h>
#include <stdarg.h>
#include "memory.h"
#include "mlvalues.h"
-extern void bigarray_unmap_file(void * addr, unsigned long len);
+extern void bigarray_unmap_file(void * addr, uintnat len);
/* from mmap_xxx.c */
/* Compute the number of elements of a big array */
-static unsigned long bigarray_num_elts(struct caml_bigarray * b)
+static uintnat bigarray_num_elts(struct caml_bigarray * b)
{
- unsigned long num_elts;
+ uintnat num_elts;
int i;
num_elts = 1;
for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
/* Compute the number of bytes for the elements of a big array */
-unsigned long bigarray_byte_size(struct caml_bigarray * b)
+uintnat bigarray_byte_size(struct caml_bigarray * b)
{
return bigarray_num_elts(b)
* bigarray_element_size[b->flags & BIGARRAY_KIND_MASK];
static void bigarray_finalize(value v);
static int bigarray_compare(value v1, value v2);
-static long bigarray_hash(value v);
-static void bigarray_serialize(value, unsigned long *, unsigned long *);
-unsigned long bigarray_deserialize(void * dst);
+static intnat bigarray_hash(value v);
+static void bigarray_serialize(value, uintnat *, uintnat *);
+uintnat bigarray_deserialize(void * dst);
static struct custom_operations bigarray_ops = {
"_bigarray",
bigarray_finalize,
/* Multiplication of unsigned longs with overflow detection */
-static unsigned long
-bigarray_multov(unsigned long a, unsigned long b, int * overflow)
+static uintnat
+bigarray_multov(uintnat a, uintnat b, int * overflow)
{
-#define HALF_SIZE (sizeof(unsigned long) * 4)
-#define LOW_HALF(x) ((x) & ((1UL << HALF_SIZE) - 1))
+#define HALF_SIZE (sizeof(uintnat) * 4)
+#define HALF_MASK (((uintnat)1 << HALF_SIZE) - 1)
+#define LOW_HALF(x) ((x) & HALF_MASK)
#define HIGH_HALF(x) ((x) >> HALF_SIZE)
/* Cut in half words */
- unsigned long al = LOW_HALF(a);
- unsigned long ah = HIGH_HALF(a);
- unsigned long bl = LOW_HALF(b);
- unsigned long bh = HIGH_HALF(b);
+ uintnat al = LOW_HALF(a);
+ uintnat ah = HIGH_HALF(a);
+ uintnat bl = LOW_HALF(b);
+ uintnat bh = HIGH_HALF(b);
/* Exact product is:
al * bl
+ ah * bl << HALF_SIZE
OR the sum al * bl + LOW_HALF(ah * bl) << HALF_SIZE
+ LOW_HALF(al * bh) << HALF_SIZE overflows.
This sum is equal to p = (a * b) modulo word size. */
- unsigned long p1 = al * bh;
- unsigned long p2 = ah * bl;
- unsigned long p = a * b;
+ uintnat p1 = al * bh;
+ uintnat p2 = ah * bl;
+ uintnat p = a * b;
if (ah != 0 && bh != 0) *overflow = 1;
- if (p1 >= (1UL << HALF_SIZE) || p2 >= (1UL << HALF_SIZE)) *overflow = 1;
+ if (HIGH_HALF(p1) != 0 || HIGH_HALF(p2) != 0) *overflow = 1;
p1 <<= HALF_SIZE;
p2 <<= HALF_SIZE;
p1 += p2;
[dim] may point into an object in the Caml heap.
*/
CAMLexport value
-alloc_bigarray(int flags, int num_dims, void * data, long * dim)
+alloc_bigarray(int flags, int num_dims, void * data, intnat * dim)
{
- unsigned long num_elts, size;
+ uintnat num_elts, size;
int overflow, i;
value res;
struct caml_bigarray * b;
- long dimcopy[MAX_NUM_DIMS];
+ intnat dimcopy[MAX_NUM_DIMS];
Assert(num_dims >= 1 && num_dims <= MAX_NUM_DIMS);
Assert((flags & BIGARRAY_KIND_MASK) <= BIGARRAY_COMPLEX64);
}
res = alloc_custom(&bigarray_ops,
sizeof(struct caml_bigarray)
- + (num_dims - 1) * sizeof(long),
+ + (num_dims - 1) * sizeof(intnat),
size, MAX_BIGARRAY_MEMORY);
b = Bigarray_val(res);
b->data = data;
CAMLexport value alloc_bigarray_dims(int flags, int num_dims, void * data, ...)
{
va_list ap;
- long dim[MAX_NUM_DIMS];
+ intnat dim[MAX_NUM_DIMS];
int i;
value res;
va_start(ap, data);
- for (i = 0; i < num_dims; i++) dim[i] = va_arg(ap, long);
+ for (i = 0; i < num_dims; i++) dim[i] = va_arg(ap, intnat);
va_end(ap);
res = alloc_bigarray(flags, num_dims, data, dim);
return res;
CAMLprim value bigarray_create(value vkind, value vlayout, value vdim)
{
- long dim[MAX_NUM_DIMS];
+ intnat dim[MAX_NUM_DIMS];
mlsize_t num_dims;
int i, flags;
are within the bounds and return the offset of the corresponding
array element in the data part of the array. */
-static long bigarray_offset(struct caml_bigarray * b, long * index)
+static long bigarray_offset(struct caml_bigarray * b, intnat * index)
{
- long offset;
+ intnat offset;
int i;
offset = 0;
if ((b->flags & BIGARRAY_LAYOUT_MASK) == BIGARRAY_C_LAYOUT) {
/* C-style layout: row major, indices start at 0 */
for (i = 0; i < b->num_dims; i++) {
- if ((unsigned long) index[i] >= (unsigned long) b->dim[i])
+ if ((uintnat) index[i] >= (uintnat) b->dim[i])
array_bound_error();
offset = offset * b->dim[i] + index[i];
}
} else {
/* Fortran-style layout: column major, indices start at 1 */
for (i = b->num_dims - 1; i >= 0; i--) {
- if ((unsigned long) (index[i] - 1) >= (unsigned long) b->dim[i])
+ if ((uintnat) (index[i] - 1) >= (uintnat) b->dim[i])
array_bound_error();
offset = offset * b->dim[i] + (index[i] - 1);
}
value bigarray_get_N(value vb, value * vind, int nind)
{
struct caml_bigarray * b = Bigarray_val(vb);
- long index[MAX_NUM_DIMS];
+ intnat index[MAX_NUM_DIMS];
int i;
- long offset;
+ intnat offset;
/* Check number of indices = number of dimensions of array
(maybe not necessary if ML typing guarantees this) */
case BIGARRAY_FLOAT64:
return copy_double(((double *) b->data)[offset]);
case BIGARRAY_SINT8:
- return Val_int(((schar *) b->data)[offset]);
+ return Val_int(((int8 *) b->data)[offset]);
case BIGARRAY_UINT8:
- return Val_int(((unsigned char *) b->data)[offset]);
+ return Val_int(((uint8 *) b->data)[offset]);
case BIGARRAY_SINT16:
return Val_int(((int16 *) b->data)[offset]);
case BIGARRAY_UINT16:
case BIGARRAY_INT64:
return copy_int64(((int64 *) b->data)[offset]);
case BIGARRAY_NATIVE_INT:
- return copy_nativeint(((long *) b->data)[offset]);
+ return copy_nativeint(((intnat *) b->data)[offset]);
case BIGARRAY_CAML_INT:
- return Val_long(((long *) b->data)[offset]);
+ return Val_long(((intnat *) b->data)[offset]);
case BIGARRAY_COMPLEX32:
{ float * p = ((float *) b->data) + offset * 2;
return copy_two_doubles(p[0], p[1]); }
/* Generic write to a big array */
-static value bigarray_set_aux(value vb, value * vind, long nind, value newval)
+static value bigarray_set_aux(value vb, value * vind, intnat nind, value newval)
{
struct caml_bigarray * b = Bigarray_val(vb);
- long index[MAX_NUM_DIMS];
+ intnat index[MAX_NUM_DIMS];
int i;
- long offset;
+ intnat offset;
/* Check number of indices = number of dimensions of array
(maybe not necessary if ML typing guarantees this) */
((double *) b->data)[offset] = Double_val(newval); break;
case BIGARRAY_SINT8:
case BIGARRAY_UINT8:
- ((schar *) b->data)[offset] = Int_val(newval); break;
+ ((int8 *) b->data)[offset] = Int_val(newval); break;
case BIGARRAY_SINT16:
case BIGARRAY_UINT16:
((int16 *) b->data)[offset] = Int_val(newval); break;
case BIGARRAY_INT64:
((int64 *) b->data)[offset] = Int64_val(newval); break;
case BIGARRAY_NATIVE_INT:
- ((long *) b->data)[offset] = Nativeint_val(newval); break;
+ ((intnat *) b->data)[offset] = Nativeint_val(newval); break;
case BIGARRAY_CAML_INT:
- ((long *) b->data)[offset] = Long_val(newval); break;
+ ((intnat *) b->data)[offset] = Long_val(newval); break;
case BIGARRAY_COMPLEX32:
{ float * p = ((float *) b->data) + offset * 2;
p[0] = Double_field(newval, 0);
CAMLprim value bigarray_dim(value vb, value vn)
{
struct caml_bigarray * b = Bigarray_val(vb);
- long n = Long_val(vn);
+ intnat n = Long_val(vn);
if (n >= b->num_dims) invalid_argument("Bigarray.dim");
return Val_long(b->dim[n]);
}
{
struct caml_bigarray * b1 = Bigarray_val(v1);
struct caml_bigarray * b2 = Bigarray_val(v2);
- unsigned long n, num_elts;
+ uintnat n, num_elts;
int i;
/* Compare number of dimensions */
if (b1->num_dims != b2->num_dims) return b2->num_dims - b1->num_dims;
/* Same number of dimensions: compare dimensions lexicographically */
for (i = 0; i < b1->num_dims; i++) {
- long d1 = b1->dim[i];
- long d2 = b2->dim[i];
+ intnat d1 = b1->dim[i];
+ intnat d2 = b2->dim[i];
if (d1 != d2) return d1 < d2 ? -1 : 1;
}
/* Same dimensions: compare contents lexicographically */
case BIGARRAY_FLOAT64:
DO_FLOAT_COMPARISON(double);
case BIGARRAY_SINT8:
- DO_INTEGER_COMPARISON(schar);
+ DO_INTEGER_COMPARISON(int8);
case BIGARRAY_UINT8:
- DO_INTEGER_COMPARISON(unsigned char);
+ DO_INTEGER_COMPARISON(uint8);
case BIGARRAY_SINT16:
DO_INTEGER_COMPARISON(int16);
case BIGARRAY_UINT16:
#endif
case BIGARRAY_CAML_INT:
case BIGARRAY_NATIVE_INT:
- DO_INTEGER_COMPARISON(long);
+ DO_INTEGER_COMPARISON(intnat);
default:
Assert(0);
return 0; /* should not happen */
/* Hashing of a bigarray */
-static long bigarray_hash(value v)
+static intnat bigarray_hash(value v)
{
struct caml_bigarray * b = Bigarray_val(v);
- long num_elts, n, h;
+ intnat num_elts, n, h;
int i;
num_elts = 1;
switch (b->flags & BIGARRAY_KIND_MASK) {
case BIGARRAY_SINT8:
case BIGARRAY_UINT8: {
- unsigned char * p = b->data;
+ uint8 * p = b->data;
for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
break;
}
case BIGARRAY_SINT16:
case BIGARRAY_UINT16: {
- unsigned short * p = b->data;
+ uint16 * p = b->data;
for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
break;
}
#endif
#ifdef ARCH_SIXTYFOUR
{
- unsigned long * p = b->data;
+ uintnat * p = b->data;
for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
break;
}
}
static void bigarray_serialize_longarray(void * data,
- long num_elts,
- long min_val, long max_val)
+ intnat num_elts,
+ intnat min_val, intnat max_val)
{
#ifdef ARCH_SIXTYFOUR
int overflow_32 = 0;
- long * p, n;
+ intnat * p, n;
for (n = 0, p = data; n < num_elts; n++, p++) {
if (*p < min_val || *p > max_val) { overflow_32 = 1; break; }
}
}
static void bigarray_serialize(value v,
- unsigned long * wsize_32,
- unsigned long * wsize_64)
+ uintnat * wsize_32,
+ uintnat * wsize_64)
{
struct caml_bigarray * b = Bigarray_val(v);
- long num_elts;
+ intnat num_elts;
int i;
/* Serialize header information */
*wsize_64 = (4 + b->num_dims) * 8;
}
-static void bigarray_deserialize_longarray(void * dest, long num_elts)
+static void bigarray_deserialize_longarray(void * dest, intnat num_elts)
{
int sixty = deserialize_uint_1();
#ifdef ARCH_SIXTYFOUR
if (sixty) {
deserialize_block_8(dest, num_elts);
} else {
- long * p, n;
+ intnat * p, n;
for (n = 0, p = dest; n < num_elts; n++, p++) *p = deserialize_sint_4();
}
#else
#endif
}
-unsigned long bigarray_deserialize(void * dst)
+uintnat bigarray_deserialize(void * dst)
{
struct caml_bigarray * b = dst;
int i, elt_size;
- unsigned long num_elts;
+ uintnat num_elts;
/* Read back header information */
b->num_dims = deserialize_uint_4();
case BIGARRAY_NATIVE_INT:
bigarray_deserialize_longarray(b->data, num_elts); break;
}
- return sizeof(struct caml_bigarray) + (b->num_dims - 1) * sizeof(long);
+ return sizeof(struct caml_bigarray) + (b->num_dims - 1) * sizeof(intnat);
}
/* Create / update proxy to indicate that b2 is a sub-array of b1 */
CAMLparam2 (vb, vind);
#define b ((struct caml_bigarray *) Bigarray_val(vb))
CAMLlocal1 (res);
- long index[MAX_NUM_DIMS];
+ intnat index[MAX_NUM_DIMS];
int num_inds, i;
- long offset;
- long * sub_dims;
+ intnat offset;
+ intnat * sub_dims;
char * sub_data;
/* Check number of indices < number of dimensions of array */
CAMLparam3 (vb, vofs, vlen);
CAMLlocal1 (res);
#define b ((struct caml_bigarray *) Bigarray_val(vb))
- long ofs = Long_val(vofs);
- long len = Long_val(vlen);
+ intnat ofs = Long_val(vofs);
+ intnat len = Long_val(vlen);
int i, changed_dim;
- long mul;
+ intnat mul;
char * sub_data;
/* Compute offset and check bounds */
struct caml_bigarray * src = Bigarray_val(vsrc);
struct caml_bigarray * dst = Bigarray_val(vdst);
int i;
- long num_bytes;
+ intnat num_bytes;
/* Check same numbers of dimensions and same dimensions */
if (src->num_dims != dst->num_dims) goto blit_error;
CAMLprim value bigarray_fill(value vb, value vinit)
{
struct caml_bigarray * b = Bigarray_val(vb);
- long num_elts = bigarray_num_elts(b);
+ intnat num_elts = bigarray_num_elts(b);
switch (b->flags & BIGARRAY_KIND_MASK) {
default:
case BIGARRAY_SINT16:
case BIGARRAY_UINT16: {
int init = Int_val(vinit);
- short * p;
+ int16 * p;
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
break;
}
break;
}
case BIGARRAY_NATIVE_INT: {
- long init = Nativeint_val(vinit);
- long * p;
+ intnat init = Nativeint_val(vinit);
+ intnat * p;
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
break;
}
case BIGARRAY_CAML_INT: {
- long init = Long_val(vinit);
- long * p;
+ intnat init = Long_val(vinit);
+ intnat * p;
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
break;
}
CAMLparam2 (vb, vdim);
CAMLlocal1 (res);
#define b ((struct caml_bigarray *) Bigarray_val(vb))
- long dim[MAX_NUM_DIMS];
+ intnat dim[MAX_NUM_DIMS];
mlsize_t num_dims;
- unsigned long num_elts;
+ uintnat num_elts;
int i;
num_dims = Wosize_val(vdim);
/* */
/***********************************************************************/
-/* $Id: mmap_unix.c,v 1.7 2001/12/07 13:39:50 xleroy Exp $ */
+/* $Id: mmap_unix.c,v 1.8 2005/09/22 14:21:50 xleroy Exp $ */
#include <stddef.h>
#include <string.h>
value vshared, value vdim)
{
int fd, flags, major_dim, shared;
- long num_dims, i;
- long dim[MAX_NUM_DIMS];
- long currpos, file_size;
- unsigned long array_size;
+ intnat num_dims, i;
+ intnat dim[MAX_NUM_DIMS];
+ intnat currpos, file_size;
+ uintnat array_size;
char c;
void * addr;
/* Check if the first/last dimension is unknown */
if (dim[major_dim] == -1) {
/* Determine first/last dimension from file size */
- if ((unsigned long) file_size % array_size != 0)
+ if ((uintnat) file_size % array_size != 0)
failwith("Bigarray.mmap: file size doesn't match array dimensions");
- dim[major_dim] = (unsigned long) file_size / array_size;
+ dim[major_dim] = (uintnat) file_size / array_size;
array_size = file_size;
} else {
/* Check that file is large enough, and grow it otherwise */
#endif
-void bigarray_unmap_file(void * addr, unsigned long len)
+void bigarray_unmap_file(void * addr, uintnat len)
{
#if defined(HAS_MMAP)
munmap(addr, len);
/* */
/***********************************************************************/
-/* $Id: mmap_win32.c,v 1.4 2002/06/07 09:49:38 xleroy Exp $ */
+/* $Id: mmap_win32.c,v 1.5 2005/09/22 14:21:50 xleroy Exp $ */
#include <stddef.h>
#include <stdio.h>
#include "sys.h"
#include "unixsupport.h"
+/* TODO: handle mappings larger than 2^32 bytes on Win64 */
+
extern int bigarray_element_size[]; /* from bigarray_stubs.c */
static void bigarray_sys_error(void);
{
HANDLE fd, fmap;
int flags, major_dim, mode, perm;
- long num_dims, i;
- long dim[MAX_NUM_DIMS];
- long currpos, file_size;
- unsigned long array_size;
+ intnat num_dims, i;
+ intnat dim[MAX_NUM_DIMS];
+ DWORD currpos, file_size;
+ uintnat array_size;
char c;
void * addr;
}
/* Determine file size */
currpos = SetFilePointer(fd, 0, NULL, FILE_CURRENT);
- if (currpos == -1) bigarray_sys_error();
+ if (currpos == INVALID_SET_FILE_POINTER) bigarray_sys_error();
file_size = SetFilePointer(fd, 0, NULL, FILE_END);
- if (file_size == -1) bigarray_sys_error();
+ if (file_size == INVALID_SET_FILE_POINTER) bigarray_sys_error();
/* Determine array size in bytes (or size of array without the major
dimension if that dimension wasn't specified) */
array_size = bigarray_element_size[flags & BIGARRAY_KIND_MASK];
/* Check if the first/last dimension is unknown */
if (dim[major_dim] == -1) {
/* Determine first/last dimension from file size */
- if ((unsigned long) file_size % array_size != 0)
+ if ((uintnat) file_size % array_size != 0)
failwith("Bigarray.mmap: file size doesn't match array dimensions");
- dim[major_dim] = (unsigned long) file_size / array_size;
+ dim[major_dim] = (uintnat) file_size / array_size;
array_size = file_size;
}
/* Restore original file position */
return alloc_bigarray(flags | BIGARRAY_MAPPED_FILE, num_dims, addr, dim);
}
-void bigarray_unmap_file(void * addr, unsigned long len)
+void bigarray_unmap_file(void * addr, uintnat len)
{
UnmapViewOfFile(addr);
}
static void bigarray_sys_error(void)
{
char buffer[512];
- unsigned long errnum;
+ DWORD errnum;
errnum = GetLastError();
if (!FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS,
# #
#########################################################################
-# $Id: Makefile,v 1.23 2002/06/27 11:36:01 xleroy Exp $
+# $Id: Makefile,v 1.25 2004/11/29 14:53:32 doligez Exp $
# Makefile for the ndbm library
# #
#########################################################################
-# $Id: Makefile,v 1.27 2004/02/22 15:07:51 xleroy Exp $
+# $Id: Makefile,v 1.29 2004/11/29 14:53:32 doligez Exp $
# Makefile for the dynamic link library
(* *)
(***********************************************************************)
-(* $Id: dynlink.ml,v 1.31 2003/05/26 13:46:36 xleroy Exp $ *)
+(* $Id: dynlink.ml,v 1.32 2004/11/29 02:27:25 garrigue Exp $ *)
(* Dynamic loading of .cmo files *)
close_in ic;
raise(Error(Corrupted_interface filename))
end;
- input_value ic;
+ ignore (input_value ic);
let crc =
match input_value ic with
(_, crc) :: _ -> crc
# #
#########################################################################
-# $Id: Makefile,v 1.35.4.1 2005/06/22 15:47:33 doligez Exp $
+# $Id: Makefile,v 1.39 2005/08/13 20:59:37 doligez Exp $
# Makefile for the portable graphics library
/* */
/***********************************************************************/
-/* $Id: events.c,v 1.17.2.1 2005/07/29 14:21:18 xleroy Exp $ */
+/* $Id: events.c,v 1.18 2005/08/13 20:59:37 doligez Exp $ */
#include <signal.h>
#include "libgraph.h"
(* *)
(***********************************************************************)
-(* $Id: graphics.ml,v 1.25.2.2 2005/08/05 12:43:47 doligez Exp $ *)
+(* $Id: graphics.ml,v 1.26 2005/08/13 20:59:37 doligez Exp $ *)
exception Graphic_failure of string
(* *)
(***********************************************************************)
-(* $Id: graphics.mli,v 1.36.2.2 2005/08/05 12:43:47 doligez Exp $ *)
+(* $Id: graphics.mli,v 1.37 2005/08/13 20:59:37 doligez Exp $ *)
(** Machine-independent graphics primitives. *)
/* */
/***********************************************************************/
-/* $Id: open.c,v 1.32.2.2 2005/05/26 09:15:22 doligez Exp $ */
+/* $Id: open.c,v 1.34 2005/08/13 20:59:37 doligez Exp $ */
#include <string.h>
#include <fcntl.h>
cd examples_camltk; $(MAKE) all
install:
+ cd support; $(MAKE) install
+ cd lib; $(MAKE) install
cd labltk; $(MAKE) install
cd camltk; $(MAKE) install
- cd lib; $(MAKE) install
- cd support; $(MAKE) install
cd compiler; $(MAKE) install
cd jpf; $(MAKE) install
cd frx; $(MAKE) install
cd browser; $(MAKE) install
installopt:
+ cd support; $(MAKE) installopt
+ cd lib; $(MAKE) installopt
cd labltk; $(MAKE) installopt
cd camltk; $(MAKE) installopt
- cd lib; $(MAKE) installopt
cd jpf; $(MAKE) installopt
cd frx; $(MAKE) installopt
cd tkanim; $(MAKE) installopt
cd browser ; $(MAKEREC) install
installopt:
+ cd support ; $(MAKEREC) installopt
cd labltk ; $(MAKEREC) installopt
cd camltk ; $(MAKEREC) installopt
cd lib ; $(MAKEREC) installopt
CCFLAGS=-I../../../byterun $(TK_DEFS)
ifeq ($(CCOMPTYPE),cc)
-WINDOWS_APP=-cclib "-Wl,--subsystem,windows"
+WINDOWS_APP=-ccopt "-Wl,--subsystem,windows"
else
-WINDOWS_APP=-cclib "/link /subsystem:windows"
+WINDOWS_APP=-ccopt "/link /subsystem:windows"
endif
OBJS = list2.cmo useunix.cmo setpath.cmo lexical.cmo \
(* *)
(*************************************************************************)
-(* $Id: fileselect.ml,v 1.20 2002/08/09 10:34:44 garrigue Exp $ *)
+(* $Id: fileselect.ml,v 1.21 2005/01/28 16:13:11 doligez Exp $ *)
(* file selection box *)
in
let files = if files = [] then [Textvariable.get selection_var]
else files in
- activate [Textvariable.get selection_var]
+ activate files
end
and flb = Button.create cfrm ~text:"Filter"
~command:(fun () -> configure ~filter:(Textvariable.get filter_var))
(* *)
(*************************************************************************)
-(* $Id: main.ml,v 1.30 2003/05/02 13:20:58 weis Exp $ *)
+(* $Id: main.ml,v 1.31 2004/11/27 01:04:19 doligez Exp $ *)
open StdLabels
module Unix = UnixLabels
[] -> raise Not_found
| (k, c, d) :: rem ->
if k = key then
- match c with Arg.Set _ | Arg.Clear _ -> false | _ -> true
+ match c with Arg.Set _ | Arg.Clear _ | Arg.Unit _ -> false | _ -> true
else get_incr key rem
let check ~spec argv =
open Printf
+let print_version () =
+ printf "The Objective Caml browser, version %s\n" Sys.ocaml_version;
+ exit 0;
+;;
+
let usage ~spec errmsg =
let b = Buffer.create 1024 in
bprintf b "%s\n" errmsg;
"-labels", Arg.Clear Clflags.classic, " <obsolete>";
"-nolabels", Arg.Set Clflags.classic,
" Ignore non-optional labels in types";
+ "-oldui", Arg.Clear st, " Revert back to old UI";
"-pp", Arg.String (fun s -> Clflags.preprocessor := Some s),
"<command> Pipe sources through preprocessor <command>";
"-rectypes", Arg.Set Clflags.recursive_types,
" Allow arbitrary recursive types";
- "-oldui", Arg.Clear st, " Revert back to old UI";
+ "-version", Arg.Unit print_version,
+ " Print version and exit";
"-w", Arg.String (fun s -> Shell.warnings := s),
"<flags> Enable or disable warnings according to <flags>:\n\
\032 A/a enable/disable all warnings\n\
(* *)
(*************************************************************************)
-(* $Id: searchid.ml,v 1.22 2004/06/12 08:55:46 xleroy Exp $ *)
+(* $Id: searchid.ml,v 1.23 2005/01/28 16:13:11 doligez Exp $ *)
open StdLabels
open Location
| Tvariant row1, Tvariant row2 ->
let row1 = row_repr row1 and row2 = row_repr row2 in
let fields1 = filter_row_fields false row1.row_fields
- and fields2 = filter_row_fields false row1.row_fields
+ and fields2 = filter_row_fields false row2.row_fields
in
let r1, r2, pairs = merge_row_fields fields1 fields2 in
r1 = [] &&
(* *)
(*************************************************************************)
-(* $Id: searchpos.ml,v 1.44.2.1 2004/06/29 01:50:19 garrigue Exp $ *)
+(* $Id: searchpos.ml,v 1.48 2005/03/23 03:08:37 garrigue Exp $ *)
open StdLabels
open Support
| None -> ()
end;
let rec search_tkind = function
- Ptype_abstract -> ()
+ Ptype_abstract | Ptype_private -> ()
| Ptype_variant (dl, _) ->
List.iter dl
- ~f:(fun (_, tl) -> List.iter tl ~f:(search_pos_type ~pos ~env))
+ ~f:(fun (_, tl, _) -> List.iter tl ~f:(search_pos_type ~pos ~env))
| Ptype_record (dl, _) ->
- List.iter dl ~f:(fun (_, _, t) -> search_pos_type t ~pos ~env) in
+ List.iter dl ~f:(fun (_, _, t, _) -> search_pos_type t ~pos ~env) in
search_tkind td.ptype_kind;
List.iter td.ptype_cstrs ~f:
begin fun (t1, t2, _) ->
[Tsig_class(ident_of_path path ~default:"c", cl, Trec_first)]
end
| `Class (path, cty) ->
- let cld = { cty_params = []; cty_type = cty;
+ let cld = { cty_params = []; cty_variance = []; cty_type = cty;
cty_path = path; cty_new = None } in
view_signature_item ~path ~env
[Tsig_class(ident_of_path path ~default:"c", cld, Trec_first)]
(* *)
(*************************************************************************)
-(* $Id: viewer.ml,v 1.31 2004/06/12 08:55:47 xleroy Exp $ *)
+(* $Id: viewer.ml,v 1.32 2005/03/23 03:08:37 garrigue Exp $ *)
open StdLabels
open Tk
let label = Label.create tl ~anchor:`W ~padx:5 in
let view = Frame.create tl in
let buttons = Frame.create tl in
- let all = Button.create buttons ~text:"Show all" ~padx:20
+ let _all = Button.create buttons ~text:"Show all" ~padx:20
and close = Button.create buttons ~text:"Close all" ~command:close_all_views
and detach = Button.create buttons ~text:"Detach"
and edit = Button.create buttons ~text:"Impl"
cat _tkfgen.ml; \
echo ; \
) > _cTk.ml
- ../../../boot/ocamlrun ../compiler/pp < _cTk.ml > cTk.ml
+ $(CAMLRUN) ../compiler/pp < _cTk.ml > cTk.ml
rm -f _cTk.ml
$(CAMLDEP) -I ../support [a-z]*.mli [a-z]*.ml > .depend
all: cTk.ml camltk.ml .depend
_tkgen.ml: ../Widgets.src ../compiler/tkcompiler.exe
- cd .. ; ../../boot/ocamlrun compiler/tkcompiler.exe -camltk -outdir camltk
+ cd .. ; $(CAMLRUNGEN) compiler/tkcompiler.exe -camltk -outdir camltk
# dependencies are broken: wouldn't work with gmake 3.77
cat _tkfgen.ml; \
echo ; \
) > _cTk.ml
- ../../../boot/ocamlrun ../compiler/pp < _cTk.ml > cTk.ml
+ $(CAMLRUN) ../compiler/pp < _cTk.ml > cTk.ml
rm -f _cTk.ml
$(CAMLDEP) -slash -I ../support [a-z]*.mli [a-z]*.ml > .depend
(* *)
(***********************************************************************)
-(* $Id: compile.ml,v 1.31 2003/07/08 08:50:24 rouaix Exp $ *)
+(* $Id: compile.ml,v 1.32 2005/01/28 16:13:11 doligez Exp $ *)
open StdLabels
open Tables
let newvar = ref newvar1 in
let rec coderec = function
StringArg s -> "TkToken \"" ^ s ^ "\""
- | TypeArg (_, List (Subtype (sup, sub) as ty)) when not !Flags.camltk ->
+ | TypeArg (_, List (Subtype (sup, sub))) when not !Flags.camltk ->
begin try
let typdef = Hashtbl.find types_table sup in
let classdef = List.assoc sub typdef.subtypes in
(* *)
(***********************************************************************)
-(* $Id: maincompile.ml,v 1.19 2002/10/30 23:31:26 weis Exp $ *)
+(* $Id: maincompile.ml,v 1.20 2005/01/28 16:13:11 doligez Exp $ *)
open StdLabels
open Support
let cname = realname name in
output_string oc (Printf.sprintf "module %s = %s;;\n"
(String.capitalize name)
- (String.capitalize name))) module_table;
+ (String.capitalize cname))) module_table;
(* widget typer *)
output_string oc "\n(** Widget typers *)\n\nopen Widget\n\n";
Hashtbl.iter (fun name def ->
| ("#")? [^ '#' '\n']* '\n'? {
begin
let str = Lexing.lexeme lexbuf in
- let line = !linenum in
if String.length str <> 0 && str.[String.length str - 1] = '\n' then
begin
incr linenum
(* *)
(***********************************************************************)
-(* $Id: fileselect.ml,v 1.19 2002/04/26 12:16:12 furuse Exp $ *)
+(* $Id: fileselect.ml,v 1.21 2005/01/28 16:13:11 doligez Exp $ *)
(* file selection box *)
let r,w = pipe () in
match fork () with
0 -> close r; dup2 ~src:w ~dst:stdout;
- execv ~prog:"/bin/sh" ~args:[| "/bin/sh"; "-c"; cmd |];
- exit 127
+ execv ~prog:"/bin/sh" ~args:[| "/bin/sh"; "-c"; cmd |]
| id ->
close w;
let rc = in_channel_of_descr r in
in
let answer = it [] in
close_in rc; (* because of finalize_channel *)
- let p, st = waitpid ~mode:[] id in answer
+ let _ = waitpid ~mode:[] id in answer
(***************************************************************** Path name *)
match fork () with
0 -> close r; dup2 w stdout;
close stderr;
- execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]; exit 127
+ execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
| id ->
close w;
let rc = in_channel_of_descr r in
in
let answer = it() in
close_in rc; (* because of finalize_channel *)
- let p, st = waitpid [] id in answer
+ let _ = waitpid [] id in answer
cat _tkfgen.ml; \
echo ; \
) > _tk.ml
- ../../../boot/ocamlrun ../compiler/pp < _tk.ml > tk.ml
+ $(CAMLRUN) ../compiler/pp < _tk.ml > tk.ml
rm -f _tk.ml
$(CAMLDEP) -I ../support [a-z]*.mli [a-z]*.ml > .depend
all: tk.ml labltk.ml .depend
_tkgen.ml: ../Widgets.src ../compiler/tkcompiler.exe
- cd .. ; ../../boot/ocamlrun compiler/tkcompiler.exe -outdir labltk
+ cd .. ; $(CAMLRUNGEN) compiler/tkcompiler.exe -outdir labltk
# dependencies are broken: wouldn't work with gmake 3.77
cat _tkfgen.ml; \
echo ; \
) > _tk.ml
- ../../../boot/ocamlrun ../compiler/pp < _tk.ml > tk.ml
+ $(CAMLRUN) ../compiler/pp < _tk.ml > tk.ml
rm -f _tk.ml
$(CAMLDEP) -slash -I ../support [a-z]*.mli [a-z]*.ml > .depend
textvariable.cmx: protocol.cmx support.cmx widget.cmx textvariable.cmi
timer.cmo: protocol.cmi support.cmi timer.cmi
timer.cmx: protocol.cmx support.cmx timer.cmi
+tkthread.cmo: protocol.cmi timer.cmi widget.cmi tkthread.cmi
+tkthread.cmx: protocol.cmx timer.cmx widget.cmx tkthread.cmi
widget.cmo: rawwidget.cmi widget.cmi
widget.cmx: rawwidget.cmx widget.cmi
all: support.cmo rawwidget.cmo widget.cmo protocol.cmo \
textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo \
- lib$(LIBNAME).a
+ tkthread.cmo lib$(LIBNAME).a
opt: support.cmx rawwidget.cmx widget.cmx protocol.cmx \
textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx \
- lib$(LIBNAME).a
+ tkthread.cmx lib$(LIBNAME).a
COBJS=cltkCaml.o cltkUtf.o cltkEval.o cltkEvent.o cltkFile.o cltkMain.o \
cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o cltkImg.o
CCFLAGS=-I../../../byterun $(TK_DEFS) $(SHAREDCCCOMPOPTS)
COMPFLAGS=-I $(OTHERS)/unix
+THFLAGS=-I $(OTHERS)/systhreads -I $(OTHERS)/threads
lib$(LIBNAME).a : $(COBJS)
$(MKLIB) -o $(LIBNAME) $(COBJS) $(TK_LINK)
-PUB=fileevent.cmi fileevent.mli \
- protocol.cmi protocol.mli \
- textvariable.cmi textvariable.mli \
- timer.cmi timer.mli \
- rawwidget.cmi rawwidget.mli \
- widget.cmi widget.mli
+PUBMLI=fileevent.mli protocol.mli textvariable.mli timer.mli \
+ rawwidget.mli widget.mli
+PUB= $(PUBMLI) $(PUBMLI:.mli=.cmi) tkthread.mli tkthread.cmi tkthread.cmo
install: lib$(LIBNAME).a $(PUB)
if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi
if test -f dll$(LIBNAME).so; then \
cp dll$(LIBNAME).so $(STUBLIBDIR)/dll$(LIBNAME).so; fi
+installopt: opt
+ @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi
+ cp $(PUBMLI:.mli=.cmx) $(INSTALLDIR)
+ if test -f tkthread.o; then \
+ cp tkthread.o $(INSTALLDIR); \
+ chmod 644 $(INSTALLDIR)/tkthread.o; \
+ fi
+
clean :
rm -f *.cm* *.o *.a *.so
.c.o:
$(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $<
+tkthread.cmi: tkthread.mli
+ $(CAMLCOMP) $(COMPFLAGS) $(THFLAGS) $<
+tkthread.cmo: tkthread.ml
+ $(CAMLCOMP) $(COMPFLAGS) $(THFLAGS) $<
+tkthread.cmx: tkthread.ml
+ if test -f $(OTHERS)/systhreads/threads.cmxa; then \
+ $(CAMLOPT) -c $(COMPFLAGS) $(THFLAGS) $< ; \
+ fi
+
depend:
$(CAMLDEP) *.mli *.ml > .depend
CAMLOPT=$(CAMLRUN) $(TOPDIR)/ocamlopt -I $(TOPDIR)/stdlib
CAMLOPTLIBR=$(CAMLOPT) -a
+CAMLRUNGEN=../../boot/ocamlrun
all: support.cmo rawwidget.cmo widget.cmo protocol.cmo \
textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo \
- dll$(LIBNAME).dll lib$(LIBNAME).$(A)
+ tkthread.cmo dll$(LIBNAME).dll lib$(LIBNAME).$(A)
opt: support.cmx rawwidget.cmx widget.cmx protocol.cmx \
textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx \
- lib$(LIBNAME).$(A)
+ tkthread.cmx lib$(LIBNAME).$(A)
COBJS=cltkCaml.o cltkUtf.o cltkEval.o cltkEvent.o cltkFile.o \
cltkMain.o cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o cltkImg.o
CCFLAGS=-I../../../byterun -I../../win32unix $(TK_DEFS) -DIN_CAMLTKSUPPORT
COMPFLAGS=-I $(OTHERS)/win32unix
+THFLAGS=-I $(OTHERS)/systhreads -I $(OTHERS)/threads
dll$(LIBNAME).dll : $(DCOBJS)
$(call MKDLL,dll$(LIBNAME).dll,dll$(LIBNAME).$(A),\
lib$(LIBNAME).$(A) : $(SCOBJS)
$(call MKLIB,lib$(LIBNAME).$(A), $(SCOBJS))
-PUB=fileevent.cmi fileevent.mli \
- protocol.cmi protocol.mli \
- textvariable.cmi textvariable.mli \
- timer.cmi timer.mli \
- rawwidget.cmi rawwidget.mli \
- widget.cmi widget.mli
+PUBMLI=fileevent.mli protocol.mli textvariable.mli timer.mli \
+ rawwidget.mli widget.mli tkthread.mli
+PUB= $(PUBMLI) $(PUBMLI:.mli=.cmi) tkthread.cmo
install:
mkdir -p $(INSTALLDIR)
cp dll$(LIBNAME).dll $(STUBLIBDIR)/dll$(LIBNAME).dll
cp dll$(LIBNAME).$(A) lib$(LIBNAME).$(A) $(INSTALLDIR)
+installopt:
+ @mkdir -p $(INSTALLDIR)
+ cp $(PUBMLI:.mli=.cmx) $(INSTALLDIR)
+ cp tkthread.$(O) $(INSTALLDIR)
+
clean :
rm -f *.cm* *.$(O) *.dll *.$(A) *.exp
$(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $<
mv $*.$(O) $*.$(SO)
+tkthread.cmi: tkthread.mli
+ $(CAMLCOMP) $(COMPFLAGS) $(THFLAGS) $<
+tkthread.cmo: tkthread.ml
+ $(CAMLCOMP) $(COMPFLAGS) $(THFLAGS) $<
+tkthread.cmx: tkthread.ml
+ if test -f $(OTHERS)/systhreads/threads.cmxa; then \
+ $(CAMLOPT) -c $(COMPFLAGS) $(THFLAGS) $< ; \
+ fi
depend:
$(CAMLDEP) *.mli *.ml > .depend
/* */
/***********************************************************************/
-/* $Id: cltkMain.c,v 1.13 2002/07/23 14:11:59 doligez Exp $ */
+/* $Id: cltkMain.c,v 1.14 2005/09/22 14:21:50 xleroy Exp $ */
#include <string.h>
#include <tcl.h>
/* Register cltclinterp for use in other related extensions */
value *interp = caml_named_value("cltclinterp");
if (interp != NULL)
- Store_field(*interp,0,copy_nativeint((long)cltclinterp));
+ Store_field(*interp,0,copy_nativeint((intnat)cltclinterp));
}
if (Tcl_Init(cltclinterp) != TCL_OK)
--- /dev/null
+(***********************************************************************)
+(* *)
+(* LablTk, Tcl/Tk interface of Objective Caml *)
+(* *)
+(* Jacques Garrigue, Nagoya University Mathematics Dept. *)
+(* *)
+(* Copyright 2004 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file LICENSE found in the Objective Caml source tree. *)
+(* *)
+(***********************************************************************)
+
+(* $Id: tkthread.ml,v 1.1 2004/10/18 02:42:50 garrigue Exp $ *)
+
+let jobs : (unit -> unit) Queue.t = Queue.create ()
+let m = Mutex.create ()
+let with_jobs f =
+ Mutex.lock m; let y = f jobs in Mutex.unlock m; y
+
+let loop_id = ref None
+let reset () = loop_id := None
+let cannot_sync () =
+ match !loop_id with None -> true
+ | Some id -> Thread.id (Thread.self ()) = id
+
+let gui_safe () =
+ not (Sys.os_type = "Win32") || !loop_id = Some(Thread.id (Thread.self ()))
+
+let has_jobs () = not (with_jobs Queue.is_empty)
+let n_jobs () = with_jobs Queue.length
+let do_next_job () = with_jobs Queue.take ()
+let async j x = with_jobs (Queue.add (fun () -> j x))
+let sync f x =
+ if cannot_sync () then f x else
+ let m = Mutex.create () in
+ let res = ref None in
+ Mutex.lock m;
+ let c = Condition.create () in
+ let j x =
+ let y = f x in Mutex.lock m; res := Some y; Mutex.unlock m;
+ Condition.signal c
+ in
+ async j x;
+ Condition.wait c m;
+ match !res with Some y -> y | None -> assert false
+
+let rec job_timer () =
+ Timer.set ~ms:10 ~callback:
+ (fun () -> for i = 1 to n_jobs () do do_next_job () done; job_timer())
+
+let thread_main () =
+ try
+ ignore (Protocol.openTk());
+ job_timer();
+ loop_id := Some (Thread.id (Thread.self ()));
+ Protocol.mainLoop();
+ loop_id := None;
+ with exn ->
+ loop_id := None;
+ raise exn
+
+let start () =
+ Thread.create thread_main ()
+
+let top = Widget.default_toplevel
--- /dev/null
+(***********************************************************************)
+(* *)
+(* LablTk, Tcl/Tk interface of Objective Caml *)
+(* *)
+(* Jacques Garrigue, Nagoya University Mathematics Dept. *)
+(* *)
+(* Copyright 2004 Institut National de Recherche en Informatique et *)
+(* en Automatique and Kyoto University. All rights reserved. *)
+(* This file is distributed under the terms of the GNU Library *)
+(* General Public License, with the special exception on linking *)
+(* described in file LICENSE found in the Objective Caml source tree. *)
+(* *)
+(***********************************************************************)
+
+(* $Id: tkthread.mli,v 1.2 2004/10/18 02:59:33 garrigue Exp $ *)
+
+(* Basic functions *)
+
+(** Start the main loop in a new GUI thread. Do not use recursively. *)
+val start : unit -> Thread.t
+(** The actual function executed in the new thread *)
+val thread_main : unit -> unit
+(** The toplevel widget (an alias of [Widget.default_toplevel]) *)
+val top : Widget.toplevel Widget.widget
+
+(* Jobs are needed for Windows, as you cannot do GUI work from
+ another thread.
+ Even under Unix some calls need to come from the main thread.
+ The basic idea is to either use async (if you don't need a result)
+ or sync whenever you call a Tk related function from another thread
+ (for instance with the threaded toplevel).
+ With sync, beware of deadlocks!
+*)
+
+(** Add an asynchronous job (to do in the main thread) *)
+val async : ('a -> unit) -> 'a -> unit
+(** Add a synchronous job (to do in the main thread) *)
+val sync : ('a -> 'b) -> 'a -> 'b
+(** Whether it is safe to call most Tk functions directly from
+ the current thread *)
+val gui_safe : unit -> bool
nat.cmx: int_misc.cmx nat.cmi
num.cmo: ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi
num.cmx: ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi
-ratio.cmo: string_misc.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi \
- ratio.cmi
-ratio.cmx: string_misc.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx \
- ratio.cmi
-string_misc.cmo: string_misc.cmi
-string_misc.cmx: string_misc.cmi
+ratio.cmo: nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi
+ratio.cmx: nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi
-nat_stubs.dobj: nat_stubs.c ../../byterun/alloc.h ../../byterun/misc.h \
- ../../byterun/config.h ../../byterun/../config/m.h \
- ../../byterun/../config/s.h ../../byterun/mlvalues.h \
- ../../byterun/custom.h ../../byterun/intext.h ../../byterun/io.h \
- ../../byterun/fix_code.h ../../byterun/fail.h ../../byterun/memory.h \
- ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h nat.h bignum/h/BigNum.h bignum/h/BntoBnn.h
+bng.dobj: bng.c bng.h ../../byterun/config.h ../../config/m.h \
+ ../../config/s.h ../../byterun/compatibility.h bng_ppc.c bng_digit.c
+bng_alpha.dobj: bng_alpha.c
+bng_amd64.dobj: bng_amd64.c
+bng_digit.dobj: bng_digit.c
+bng_ia32.dobj: bng_ia32.c
+bng_mips.dobj: bng_mips.c
+bng_ppc.dobj: bng_ppc.c
+bng_sparc.dobj: bng_sparc.c
+nat_stubs.dobj: nat_stubs.c ../../byterun/alloc.h \
+ ../../byterun/compatibility.h ../../byterun/misc.h \
+ ../../byterun/config.h ../../config/m.h ../../config/s.h \
+ ../../byterun/mlvalues.h ../../byterun/custom.h ../../byterun/intext.h \
+ ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/fail.h \
+ ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
+ ../../byterun/freelist.h ../../byterun/minor_gc.h bng.h nat.h
big_int.cmi: nat.cmi
-num.cmi: big_int.cmi nat.cmi ratio.cmi
-ratio.cmi: big_int.cmi nat.cmi
+num.cmi: ratio.cmi nat.cmi big_int.cmi
+ratio.cmi: nat.cmi big_int.cmi
arith_flags.cmo: arith_flags.cmi
arith_flags.cmx: arith_flags.cmi
arith_status.cmo: arith_flags.cmi arith_status.cmi
arith_status.cmx: arith_flags.cmx arith_status.cmi
-big_int.cmo: int_misc.cmi nat.cmi big_int.cmi
-big_int.cmx: int_misc.cmx nat.cmx big_int.cmi
+big_int.cmo: nat.cmi int_misc.cmi big_int.cmi
+big_int.cmx: nat.cmx int_misc.cmx big_int.cmi
int_misc.cmo: int_misc.cmi
int_misc.cmx: int_misc.cmi
nat.cmo: int_misc.cmi nat.cmi
nat.cmx: int_misc.cmx nat.cmi
-num.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi ratio.cmi num.cmi
-num.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx ratio.cmx num.cmi
-ratio.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi string_misc.cmi \
- ratio.cmi
-ratio.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx string_misc.cmx \
- ratio.cmi
-string_misc.cmo: string_misc.cmi
-string_misc.cmx: string_misc.cmi
-nat_stubs.sobj: nat_stubs.c ../../byterun/alloc.h ../../byterun/misc.h \
- ../../byterun/config.h ../../byterun/../config/m.h \
- ../../byterun/../config/s.h ../../byterun/mlvalues.h \
- ../../byterun/custom.h ../../byterun/intext.h ../../byterun/io.h \
- ../../byterun/fix_code.h ../../byterun/fail.h ../../byterun/memory.h \
- ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
- ../../byterun/minor_gc.h nat.h bignum/h/BigNum.h bignum/h/BntoBnn.h
+num.cmo: ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi
+num.cmx: ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi
+ratio.cmo: nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi
+ratio.cmx: nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi
+bng.sobj: bng.c bng.h ../../byterun/config.h ../../config/m.h \
+ ../../config/s.h ../../byterun/compatibility.h bng_ppc.c bng_digit.c
+bng_alpha.sobj: bng_alpha.c
+bng_amd64.sobj: bng_amd64.c
+bng_digit.sobj: bng_digit.c
+bng_ia32.sobj: bng_ia32.c
+bng_mips.sobj: bng_mips.c
+bng_ppc.sobj: bng_ppc.c
+bng_sparc.sobj: bng_sparc.c
+nat_stubs.sobj: nat_stubs.c ../../byterun/alloc.h \
+ ../../byterun/compatibility.h ../../byterun/misc.h \
+ ../../byterun/config.h ../../config/m.h ../../config/s.h \
+ ../../byterun/mlvalues.h ../../byterun/custom.h ../../byterun/intext.h \
+ ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/fail.h \
+ ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
+ ../../byterun/freelist.h ../../byterun/minor_gc.h bng.h nat.h
big_int.cmi: nat.cmi
-num.cmi: big_int.cmi nat.cmi ratio.cmi
-ratio.cmi: big_int.cmi nat.cmi
+num.cmi: ratio.cmi nat.cmi big_int.cmi
+ratio.cmi: nat.cmi big_int.cmi
arith_flags.cmo: arith_flags.cmi
arith_flags.cmx: arith_flags.cmi
arith_status.cmo: arith_flags.cmi arith_status.cmi
arith_status.cmx: arith_flags.cmx arith_status.cmi
-big_int.cmo: int_misc.cmi nat.cmi big_int.cmi
-big_int.cmx: int_misc.cmx nat.cmx big_int.cmi
+big_int.cmo: nat.cmi int_misc.cmi big_int.cmi
+big_int.cmx: nat.cmx int_misc.cmx big_int.cmi
int_misc.cmo: int_misc.cmi
int_misc.cmx: int_misc.cmi
nat.cmo: int_misc.cmi nat.cmi
nat.cmx: int_misc.cmx nat.cmi
-num.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi ratio.cmi num.cmi
-num.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx ratio.cmx num.cmi
-ratio.cmo: arith_flags.cmi big_int.cmi int_misc.cmi nat.cmi string_misc.cmi \
- ratio.cmi
-ratio.cmx: arith_flags.cmx big_int.cmx int_misc.cmx nat.cmx string_misc.cmx \
- ratio.cmi
-string_misc.cmo: string_misc.cmi
-string_misc.cmx: string_misc.cmi
+num.cmo: ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi
+num.cmx: ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi
+ratio.cmo: nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi
+ratio.cmx: nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi
# #
#########################################################################
-# $Id: Makefile,v 1.30 2003/10/24 09:17:31 xleroy Exp $
+# $Id: Makefile,v 1.34 2005/01/21 14:15:44 maranget Exp $
# Makefile for the "num" (exact rational arithmetic) library
CC=$(BYTECC)
CFLAGS=-O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \
-DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL)
-CAMLC=../../ocamlcomp.sh -w s
-CAMLOPT=../../ocamlcompopt.sh -w s
+CAMLC=../../ocamlcomp.sh
+CAMLOPT=../../ocamlcompopt.sh
MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib
COMPFLAGS=-warn-error A
-CAMLOBJS=int_misc.cmo string_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \
+CAMLOBJS=int_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \
ratio.cmo num.cmo arith_status.cmo
CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi
# #
#########################################################################
-# $Id: Makefile.nt,v 1.17.4.1 2004/11/29 08:50:23 xleroy Exp $
+# $Id: Makefile.nt,v 1.19 2005/03/24 17:20:53 doligez Exp $
# Makefile for the "num" (exact rational arithmetic) library
CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../boot -w s
CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -w s
-CAMLOBJS=int_misc.cmo string_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \
+CAMLOBJS=int_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \
ratio.cmo num.cmo arith_status.cmo
CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi
(* *)
(***********************************************************************)
-(* $Id: big_int.ml,v 1.18.4.3 2005/07/19 13:21:08 xleroy Exp $ *)
+(* $Id: big_int.ml,v 1.22 2005/08/13 20:59:37 doligez Exp $ *)
open Int_misc
open Nat
-type big_int =
- { sign : int;
+type big_int =
+ { sign : int;
abs_value : nat }
-let create_big_int sign nat =
+let create_big_int sign nat =
if sign = 1 || sign = -1 ||
(sign = 0 &&
is_zero_nat nat 0 (num_digits_nat nat 0 (length_nat nat)))
- then { sign = sign;
+ then { sign = sign;
abs_value = nat }
else invalid_arg "create_big_int"
{ sign = 0;
abs_value = make_nat 1 }
-let unit_big_int =
+let unit_big_int =
{ sign = 1;
abs_value = nat_of_int 1 }
(* Number of digits in a big_int *)
-let num_digits_big_int bi =
- num_digits_nat (bi.abs_value) 0 (length_nat bi.abs_value)
+let num_digits_big_int bi =
+ num_digits_nat (bi.abs_value) 0 (length_nat bi.abs_value)
(* Opposite of a big_int *)
-let minus_big_int bi =
+let minus_big_int bi =
{ sign = - bi.sign;
abs_value = copy_nat (bi.abs_value) 0 (num_digits_big_int bi)}
(* Absolute value of a big_int *)
-let abs_big_int bi =
+let abs_big_int bi =
{ sign = if bi.sign = 0 then 0 else 1;
abs_value = copy_nat (bi.abs_value) 0 (num_digits_big_int bi)}
(* Comparison operators on big_int *)
-(*
- compare_big_int (bi, bi2) = sign of (bi-bi2)
+(*
+ compare_big_int (bi, bi2) = sign of (bi-bi2)
i.e. 1 if bi > bi2
0 if bi = bi2
-1 if bi < bi2
else if bi1.sign < bi2.sign then -1
else if bi1.sign > bi2.sign then 1
else if bi1.sign = 1 then
- compare_nat (bi1.abs_value) 0 (num_digits_big_int bi1)
+ compare_nat (bi1.abs_value) 0 (num_digits_big_int bi1)
(bi2.abs_value) 0 (num_digits_big_int bi2)
else
- compare_nat (bi2.abs_value) 0 (num_digits_big_int bi2)
+ compare_nat (bi2.abs_value) 0 (num_digits_big_int bi2)
(bi1.abs_value) 0 (num_digits_big_int bi1)
let eq_big_int bi1 bi2 = compare_big_int bi1 bi2 = 0
(* Operations on big_int *)
-let pred_big_int bi =
+let pred_big_int bi =
match bi.sign with
0 -> { sign = -1; abs_value = nat_of_int 1}
| 1 -> let size_bi = num_digits_big_int bi in
let copy_bi = copy_nat (bi.abs_value) 0 size_bi in
- decr_nat copy_bi 0 size_bi 0;
+ ignore (decr_nat copy_bi 0 size_bi 0);
{ sign = if is_zero_nat copy_bi 0 size_bi then 0 else 1;
abs_value = copy_bi }
| _ -> let size_bi = num_digits_big_int bi in
let copy_bi = create_nat (size_res) in
blit_nat copy_bi 0 (bi.abs_value) 0 size_bi;
set_digit_nat copy_bi size_bi 0;
- incr_nat copy_bi 0 size_res 1;
+ ignore (incr_nat copy_bi 0 size_res 1);
{ sign = -1;
abs_value = copy_bi }
0 -> {sign = 1; abs_value = nat_of_int 1}
| -1 -> let size_bi = num_digits_big_int bi in
let copy_bi = copy_nat (bi.abs_value) 0 size_bi in
- decr_nat copy_bi 0 size_bi 0;
+ ignore (decr_nat copy_bi 0 size_bi 0);
{ sign = if is_zero_nat copy_bi 0 size_bi then 0 else -1;
abs_value = copy_bi }
| _ -> let size_bi = num_digits_big_int bi in
let copy_bi = create_nat (size_res) in
blit_nat copy_bi 0 (bi.abs_value) 0 size_bi;
set_digit_nat copy_bi size_bi 0;
- incr_nat copy_bi 0 size_res 1;
+ ignore (incr_nat copy_bi 0 size_res 1);
{ sign = 1;
abs_value = copy_bi }
-let add_big_int bi1 bi2 =
+let add_big_int bi1 bi2 =
let size_bi1 = num_digits_big_int bi1
and size_bi2 = num_digits_big_int bi2 in
if bi1.sign = bi2.sign
then (* Add absolute values if signs are the same *)
{ sign = bi1.sign;
- abs_value =
- match compare_nat (bi1.abs_value) 0 size_bi1
+ abs_value =
+ match compare_nat (bi1.abs_value) 0 size_bi1
(bi2.abs_value) 0 size_bi2 with
-1 -> let res = create_nat (succ size_bi2) in
- (blit_nat res 0 (bi2.abs_value) 0 size_bi2;
+ (blit_nat res 0 (bi2.abs_value) 0 size_bi2;
set_digit_nat res size_bi2 0;
- add_nat res 0 (succ size_bi2)
- (bi1.abs_value) 0 size_bi1 0;
+ ignore
+ (add_nat res 0 (succ size_bi2)
+ (bi1.abs_value) 0 size_bi1 0);
res)
|_ -> let res = create_nat (succ size_bi1) in
(blit_nat res 0 (bi1.abs_value) 0 size_bi1;
set_digit_nat res size_bi1 0;
- add_nat res 0 (succ size_bi1)
- (bi2.abs_value) 0 size_bi2 0;
+ ignore (add_nat res 0 (succ size_bi1)
+ (bi2.abs_value) 0 size_bi2 0);
res)}
else (* Subtract absolute values if signs are different *)
- match compare_nat (bi1.abs_value) 0 size_bi1
+ match compare_nat (bi1.abs_value) 0 size_bi1
(bi2.abs_value) 0 size_bi2 with
0 -> zero_big_int
| 1 -> { sign = bi1.sign;
- abs_value =
+ abs_value =
let res = copy_nat (bi1.abs_value) 0 size_bi1 in
- (sub_nat res 0 size_bi1
- (bi2.abs_value) 0 size_bi2 1;
+ (ignore (sub_nat res 0 size_bi1
+ (bi2.abs_value) 0 size_bi2 1);
res) }
| _ -> { sign = bi2.sign;
- abs_value =
+ abs_value =
let res = copy_nat (bi2.abs_value) 0 size_bi2 in
- (sub_nat res 0 size_bi2
- (bi1.abs_value) 0 size_bi1 1;
+ (ignore (sub_nat res 0 size_bi2
+ (bi1.abs_value) 0 size_bi1 1);
res) }
(* Coercion with int type *)
let res = (create_nat 1)
in (if i = monster_int
then (set_digit_nat res 0 biggest_int;
- incr_nat res 0 1 1; ())
+ ignore (incr_nat res 0 1 1))
else set_digit_nat res 0 (abs i));
res }
then let res = create_nat size_res in
blit_nat res 0 (bi.abs_value) 0 size_bi;
set_digit_nat res size_bi 0;
- mult_digit_nat res 0 size_res (bi.abs_value) 0 size_bi
- (nat_of_int biggest_int) 0;
+ ignore (mult_digit_nat res 0 size_res (bi.abs_value) 0 size_bi
+ (nat_of_int biggest_int) 0);
{ sign = - (sign_big_int bi);
- abs_value = res }
+ abs_value = res }
else let res = make_nat (size_res) in
- mult_digit_nat res 0 size_res (bi.abs_value) 0 size_bi
- (nat_of_int (abs i)) 0;
+ ignore (mult_digit_nat res 0 size_res (bi.abs_value) 0 size_bi
+ (nat_of_int (abs i)) 0);
{ sign = (sign_int i) * (sign_big_int bi);
- abs_value = res }
+ abs_value = res }
let mult_big_int bi1 bi2 =
let size_bi1 = num_digits_big_int bi1
let size_res = size_bi1 + size_bi2 in
let res = make_nat (size_res) in
{ sign = bi1.sign * bi2.sign;
- abs_value =
+ abs_value =
if size_bi2 > size_bi1
- then (mult_nat res 0 size_res (bi2.abs_value) 0 size_bi2
- (bi1.abs_value) 0 size_bi1;res)
- else (mult_nat res 0 size_res (bi1.abs_value) 0 size_bi1
- (bi2.abs_value) 0 size_bi2;res) }
+ then (ignore (mult_nat res 0 size_res (bi2.abs_value) 0 size_bi2
+ (bi1.abs_value) 0 size_bi1);res)
+ else (ignore (mult_nat res 0 size_res (bi1.abs_value) 0 size_bi1
+ (bi2.abs_value) 0 size_bi2);res) }
(* (quotient, rest) of the euclidian division of 2 big_int *)
let quomod_big_int bi1 bi2 =
else
let size_bi1 = num_digits_big_int bi1
and size_bi2 = num_digits_big_int bi2 in
- match compare_nat (bi1.abs_value) 0 size_bi1
+ match compare_nat (bi1.abs_value) 0 size_bi1
(bi2.abs_value) 0 size_bi2 with
-1 -> (* 1/2 -> 0, reste 1, -1/2 -> -1, reste 1 *)
(* 1/-2 -> 0, reste 1, -1/-2 -> 1, reste 1 *)
else
(big_int_of_int 1, sub_big_int bi1 bi2)
| 0 -> (big_int_of_int (bi1.sign * bi2.sign), zero_big_int)
- | _ -> let bi1_negatif = bi1.sign = -1 in
+ | _ -> let bi1_negatif = bi1.sign = -1 in
let size_q =
- if bi1_negatif
+ if bi1_negatif
then succ (max (succ (size_bi1 - size_bi2)) 1)
else max (succ (size_bi1 - size_bi2)) 1
- and size_r = succ (max size_bi1 size_bi2)
+ and size_r = succ (max size_bi1 size_bi2)
(* r is long enough to contain both quotient and remainder *)
(* of the euclidian division *)
in
set_to_zero_nat r size_bi1 (size_r - size_bi1);
(* do the division of |bi1| by |bi2|
- - at the beginning, r contains |bi1|
- - at the end, r contains
- * in the size_bi2 least significant digits, the remainder
+ - at the beginning, r contains |bi1|
+ - at the end, r contains
+ * in the size_bi2 least significant digits, the remainder
* in the size_r-size_bi2 most significant digits, the quotient
- note the conditions for application of div_nat are verified here
+ note the conditions for application of div_nat are verified here
*)
div_nat r 0 size_r (bi2.abs_value) 0 size_bi2;
(* correct the signs, adjusting the quotient and remainder *)
if bi1_negatif && not_null_mod
- then
+ then
(* bi1<0, r>0, noting r for (r, size_bi2) the remainder, *)
(* we have |bi1|=q * |bi2| + r with 0 < r < |bi2|, *)
(* thus -bi1 = q * |bi2| + r *)
(* new_r contains (r, size_bi2) the remainder *)
{ sign = - bi2.sign;
abs_value = (set_digit_nat q (pred size_q) 0;
- incr_nat q 0 size_q 1; q) },
+ ignore (incr_nat q 0 size_q 1); q) },
{ sign = 1;
- abs_value =
- (sub_nat new_r 0 size_bi2 r 0 size_bi2 1;
+ abs_value =
+ (ignore (sub_nat new_r 0 size_bi2 r 0 size_bi2 1);
new_r) })
- else
- (if bi1_negatif then set_digit_nat q (pred size_q) 0;
- { sign = if is_zero_nat q 0 size_q
- then 0
+ else
+ (if bi1_negatif then set_digit_nat q (pred size_q) 0;
+ { sign = if is_zero_nat q 0 size_q
+ then 0
else bi1.sign * bi2.sign;
abs_value = q },
{ sign = if not_null_mod then 1 else 0;
and mod_big_int bi1 bi2 = snd (quomod_big_int bi1 bi2)
let gcd_big_int bi1 bi2 =
- let size_bi1 = num_digits_big_int bi1
+ let size_bi1 = num_digits_big_int bi1
and size_bi2 = num_digits_big_int bi2 in
if is_zero_nat (bi1.abs_value) 0 size_bi1 then abs_big_int bi2
else if is_zero_nat (bi2.abs_value) 0 size_bi2 then
abs_value = bi1.abs_value }
else
{ sign = 1;
- abs_value =
- match compare_nat (bi1.abs_value) 0 size_bi1
+ abs_value =
+ match compare_nat (bi1.abs_value) 0 size_bi1
(bi2.abs_value) 0 size_bi2 with
0 -> bi1.abs_value
| 1 ->
let res = copy_nat (bi1.abs_value) 0 size_bi1 in
- let len =
+ let len =
gcd_nat res 0 size_bi1 (bi2.abs_value) 0 size_bi2 in
copy_nat res 0 len
| _ ->
let res = copy_nat (bi2.abs_value) 0 size_bi2 in
- let len =
+ let len =
gcd_nat res 0 size_bi2 (bi1.abs_value) 0 size_bi1 in
copy_nat res 0 len
}
else failwith "int_of_big_int";;
(* Coercion with nat type *)
-let nat_of_big_int bi =
+let nat_of_big_int bi =
if bi.sign = -1
then failwith "nat_of_big_int"
else copy_nat (bi.abs_value) 0 (num_digits_big_int bi)
let sys_big_int_of_nat nat off len =
- let length = num_digits_nat nat off len in
+ let length = num_digits_nat nat off len in
{ sign = if is_zero_nat nat off length then 0 else 1;
abs_value = copy_nat nat off length }
if is_zero_nat nat off len || base = 1 then nat_of_int 1 else
let power_base = make_nat (succ length_of_digit) in
let (pmax, pint) = make_power_base base power_base in
- let (n, rem) =
- let (x, y) = quomod_big_int (sys_big_int_of_nat nat off len)
+ let (n, rem) =
+ let (x, y) = quomod_big_int (sys_big_int_of_nat nat off len)
(big_int_of_int (succ pmax)) in
- (int_of_big_int x, int_of_big_int y) in
+ (int_of_big_int x, int_of_big_int y) in
if n = 0 then copy_nat power_base (pred rem) 1 else
begin
let res = make_nat n
let len = num_digits_nat res 0 n in
let len2 = min n (2 * len) in
let succ_len2 = succ len2 in
- square_nat res2 0 len2 res 0 len;
+ ignore (square_nat res2 0 len2 res 0 len);
begin
if n land !p > 0
then (set_to_zero_nat res 0 len;
- mult_digit_nat res 0 succ_len2
- res2 0 len2
- power_base pmax; ())
+ ignore (mult_digit_nat res 0 succ_len2
+ res2 0 len2 power_base pmax))
else blit_nat res 0 res2 0 len2
end;
set_to_zero_nat res2 0 len2;
p := !p lsr 1
done;
if rem > 0
- then (mult_digit_nat res2 0 (succ n)
- res 0 n power_base (pred rem);
+ then (ignore (mult_digit_nat res2 0 (succ n)
+ res 0 n power_base (pred rem));
res2)
else res
end
-let power_int_positive_int i n =
+let power_int_positive_int i n =
match sign_int n with
0 -> unit_big_int
| -1 -> invalid_arg "power_int_positive_int"
| _ -> let nat = power_base_int (abs i) n in
{ sign = if i >= 0
- then sign_int i
+ then sign_int i
else if n land 1 = 0
- then 1
+ then 1
else -1;
- abs_value = nat}
+ abs_value = nat}
-let power_big_int_positive_int bi n =
+let power_big_int_positive_int bi n =
match sign_int n with
0 -> unit_big_int
| -1 -> invalid_arg "power_big_int_positive_int"
| _ -> let bi_len = num_digits_big_int bi in
let res_len = bi_len * n in
- let res = make_nat res_len
- and res2 = make_nat res_len
+ let res = make_nat res_len
+ and res2 = make_nat res_len
and l = num_bits_int n - 2 in
let p = ref (1 lsl l) in
blit_nat res 0 bi.abs_value 0 bi_len;
let len = num_digits_nat res 0 res_len in
let len2 = min res_len (2 * len) in
set_to_zero_nat res2 0 len2;
- square_nat res2 0 len2 res 0 len;
+ ignore (square_nat res2 0 len2 res 0 len);
if n land !p > 0 then begin
let lenp = min res_len (len2 + bi_len) in
set_to_zero_nat res 0 lenp;
end;
p := !p lsr 1
done;
- {sign = if bi.sign >= 0 then bi.sign
+ {sign = if bi.sign >= 0 then bi.sign
else if n land 1 = 0 then 1 else -1;
- abs_value = res}
+ abs_value = res}
-let power_int_positive_big_int i bi =
+let power_int_positive_big_int i bi =
match sign_big_int bi with
0 -> unit_big_int
| -1 -> invalid_arg "power_int_positive_big_int"
- | _ -> let nat = power_base_nat
+ | _ -> let nat = power_base_nat
(abs i) (bi.abs_value) 0 (num_digits_big_int bi) in
{ sign = if i >= 0
- then sign_int i
+ then sign_int i
else if is_digit_odd (bi.abs_value) 0
- then -1
+ then -1
else 1;
- abs_value = nat }
+ abs_value = nat }
-let power_big_int_positive_big_int bi1 bi2 =
+let power_big_int_positive_big_int bi1 bi2 =
match sign_big_int bi2 with
0 -> unit_big_int
| -1 -> invalid_arg "power_big_int_positive_big_int"
match sign_int n with
0 -> bi
| -1 -> let nat = power_base_int base (-n) in
- let len_nat = num_digits_nat nat 0 (length_nat nat)
+ let len_nat = num_digits_nat nat 0 (length_nat nat)
and len_bi = num_digits_big_int bi in
if len_bi < len_nat then
invalid_arg "base_power_big_int"
let copy = create_nat (succ len_bi) in
blit_nat copy 0 (bi.abs_value) 0 len_bi;
set_digit_nat copy len_bi 0;
- div_nat copy 0 (succ len_bi)
+ div_nat copy 0 (succ len_bi)
nat 0 len_nat;
- if not (is_zero_nat copy 0 len_nat)
+ if not (is_zero_nat copy 0 len_nat)
then invalid_arg "base_power_big_int"
else { sign = bi.sign;
abs_value = copy_nat copy len_nat 1 }
| _ -> let nat = power_base_int base n in
- let len_nat = num_digits_nat nat 0 (length_nat nat)
+ let len_nat = num_digits_nat nat 0 (length_nat nat)
and len_bi = num_digits_big_int bi in
let new_len = len_bi + len_nat in
let res = make_nat new_len in
+ ignore
(if len_bi > len_nat
- then mult_nat res 0 new_len
- (bi.abs_value) 0 len_bi
+ then mult_nat res 0 new_len
+ (bi.abs_value) 0 len_bi
+ nat 0 len_nat
+ else mult_nat res 0 new_len
nat 0 len_nat
- else mult_nat res 0 new_len
- nat 0 len_nat
(bi.abs_value) 0 len_bi)
; if is_zero_nat res 0 new_len
then zero_big_int
(* Coercion with float type *)
-let float_of_big_int bi =
+let float_of_big_int bi =
float_of_string (string_of_big_int bi)
(* XL: suppression de big_int_of_float et nat_of_float. *)
(* Integer part of the square root of a big_int *)
let sqrt_big_int bi =
- match bi.sign with
+ match bi.sign with
| 0 -> zero_big_int
| -1 -> invalid_arg "sqrt_big_int"
| _ -> {sign = 1;
let len_bi = num_digits_big_int bi in
let len_res = 2 * len_bi in
let res = make_nat len_res in
- square_nat res 0 len_res (bi.abs_value) 0 len_bi;
+ ignore (square_nat res 0 len_res (bi.abs_value) 0 len_bi);
{sign = 1; abs_value = res}
(* round off of the futur last digit (of the integer represented by the string
argument of the function) that is now the previous one.
- if s contains an integer of the form (10^n)-1
+ if s contains an integer of the form (10^n)-1
then s <- only 0 digits and the result_int is true
else s <- the round number and the result_int is false *)
let round_futur_last_digit s off_set length =
- let l = pred (length + off_set) in
+ let l = pred (length + off_set) in
if Char.code(String.get s l) >= Char.code '5'
then
- let rec round_rec l =
- let current_char = String.get s l in
+ let rec round_rec l =
+ let current_char = String.get s l in
if current_char = '9'
then
(String.set s l '0';
if l = off_set then true else round_rec (pred l))
- else
+ else
(String.set s l (Char.chr (succ (Char.code current_char)));
false)
in round_rec (pred l)
else false
-
+
(* Approximation with floating decimal point a` la approx_ratio_exp *)
let approx_big_int prec bi =
let len_bi = num_digits_big_int bi in
- let n =
+ let n =
max 0
(int_of_big_int (
- add_int_big_int
- (-prec)
- (div_big_int (mult_big_int (big_int_of_int (pred len_bi))
- (big_int_of_string "963295986"))
+ add_int_big_int
+ (-prec)
+ (div_big_int (mult_big_int (big_int_of_int (pred len_bi))
+ (big_int_of_string "963295986"))
(big_int_of_string "100000000")))) in
let s =
string_of_big_int (div_big_int bi (power_int_positive_int 10 n)) in
- let (sign, off, len) =
+ let (sign, off, len) =
if String.get s 0 = '-'
then ("-", 1, succ prec)
else ("", 0, prec) in
/* */
/***********************************************************************/
-/* $Id: bng.c,v 1.2.6.1 2004/12/22 16:17:44 doligez Exp $ */
+/* $Id: bng.c,v 1.4 2005/09/22 14:21:50 xleroy Exp $ */
#include "bng.h"
#include "config.h"
(bng a/*[len-1]*/, bng b/*[len]*/, bngsize len, bngdigit d)
{
bngdigit topdigit, quo, rem;
- long i;
+ intnat i;
topdigit = b[len - 1];
for (i = len - 2; i >= 0; i--) {
/* */
/***********************************************************************/
-/* $Id: bng.h,v 1.2 2003/11/07 07:59:09 xleroy Exp $ */
+/* $Id: bng.h,v 1.3 2005/09/22 14:21:50 xleroy Exp $ */
#include <string.h>
+#include "config.h"
-typedef unsigned long bngdigit;
+typedef uintnat bngdigit;
typedef bngdigit * bng;
typedef unsigned int bngcarry;
-typedef unsigned long bngsize;
+typedef uintnat bngsize;
#define BNG_BITS_PER_DIGIT (sizeof(bngdigit) * 8)
#define BNG_BITS_PER_HALF_DIGIT (sizeof(bngdigit) * 4)
/* */
/***********************************************************************/
-/* $Id: bng_ia32.c,v 1.3.6.1 2005/07/20 08:18:59 xleroy Exp $ */
+/* $Id: bng_ia32.c,v 1.4 2005/08/13 20:59:37 doligez Exp $ */
/* Code specific to the Intel IA32 (x86) architecture. */
(* *)
(***********************************************************************)
-(* $Id: nat.ml,v 1.14 2003/11/21 15:59:38 xleroy Exp $ *)
+(* $Id: nat.ml,v 1.15 2005/01/21 14:15:44 maranget Exp $ *)
open Int_misc
div_nat next_cand 0 rad_len cand 0 cand_len;
(* next_cand (poids fort) <- next_cand (poids fort) + cand,
i.e. next_cand <- cand + rad / cand *)
- add_nat next_cand cand_len cand_rest cand 0 cand_len 0;
+ ignore (add_nat next_cand cand_len cand_rest cand 0 cand_len 0);
(* next_cand <- next_cand / 2 *)
shift_right_nat next_cand cand_len cand_rest a_1 0 1;
if lt_nat next_cand cand_len cand_rest cand 0 cand_len then
match length_of_digit with
| 64 ->
set_digit_nat power_base_max 0 (Int64.to_int 1000000000000000000L);
- mult_digit_nat power_base_max 0 2
- power_base_max 0 1 (nat_of_int 9) 0;
- ()
+ ignore
+ (mult_digit_nat power_base_max 0 2
+ power_base_max 0 1 (nat_of_int 9) 0)
| 32 -> set_digit_nat power_base_max 0 1000000000
| _ -> assert false
;;
and j = ref 0 in
set_digit_nat power_base 0 base;
while incr i; is_digit_zero power_base !i do
- mult_digit_nat power_base !i 2
- power_base (pred !i) 1
- power_base 0
+ ignore
+ (mult_digit_nat power_base !i 2
+ power_base (pred !i) 1
+ power_base 0)
done;
while !j <= !i && is_digit_int power_base !j do incr j done;
(!i - 2, !j)
let len = num_digits_nat res 0 newn in
let len2 = min n (2 * len) in
let succ_len2 = succ len2 in
- square_nat res2 0 len2 res 0 len;
+ ignore (square_nat res2 0 len2 res 0 len);
if n land !p > 0 then begin
set_to_zero_nat res 0 len;
- mult_digit_nat res 0 succ_len2
- res2 0 len2
- power_base pmax;
- ()
+ ignore
+ (mult_digit_nat res 0 succ_len2
+ res2 0 len2 power_base pmax)
end else
blit_nat res 0 res2 0 len2;
set_to_zero_nat res2 0 len2;
p := !p lsr 1
done;
if rem > 0 then begin
- mult_digit_nat res2 0 newn
- res 0 n power_base (pred rem);
+ ignore
+ (mult_digit_nat res2 0 newn
+ res 0 n power_base (pred rem));
res2
end else res
end else
for j = 1 to erase_len do
set_digit_nat nat1 j 0
done;
- mult_digit_nat nat1 0 !possible_len
- nat2 0 !current_len
- power_base (pred !digits_read);
+ ignore
+ (mult_digit_nat nat1 0 !possible_len
+ nat2 0 !current_len power_base (pred !digits_read));
blit_nat nat2 0 nat1 0 !possible_len;
current_len := num_digits_nat nat1 0 !possible_len;
possible_len := min !new_len (succ !current_len);
/* */
/***********************************************************************/
-/* $Id: nat_stubs.c,v 1.14.4.1 2004/12/22 16:17:44 doligez Exp $ */
+/* $Id: nat_stubs.c,v 1.16 2005/09/22 14:21:50 xleroy Exp $ */
#include "alloc.h"
#include "config.h"
/* Stub code for the Nat module. */
-static void serialize_nat(value, unsigned long *, unsigned long *);
-static unsigned long deserialize_nat(void * dst);
+static void serialize_nat(value, uintnat *, uintnat *);
+static uintnat deserialize_nat(void * dst);
static struct custom_operations nat_operations = {
"_nat",
of 64-bit words to obtain the correct behavior. */
static void serialize_nat(value nat,
- unsigned long * wsize_32,
- unsigned long * wsize_64)
+ uintnat * wsize_32,
+ uintnat * wsize_64)
{
mlsize_t len = Wosize_val(nat) - 1;
*wsize_64 = len * 4;
}
-static unsigned long deserialize_nat(void * dst)
+static uintnat deserialize_nat(void * dst)
{
mlsize_t len;
(* *)
(***********************************************************************)
-(* $Id: num.ml,v 1.6 2001/12/07 13:40:16 xleroy Exp $ *)
+(* $Id: num.ml,v 1.7 2005/01/21 14:15:44 maranget Exp $ *)
open Int_misc
open Nat
else Big_int bi
let numerator_num = function
- Ratio r -> normalize_ratio r; num_of_big_int (numerator_ratio r)
+ Ratio r -> ignore (normalize_ratio r); num_of_big_int (numerator_ratio r)
| n -> n
let denominator_num = function
- Ratio r -> normalize_ratio r; num_of_big_int (denominator_ratio r)
+ Ratio r -> ignore (normalize_ratio r); num_of_big_int (denominator_ratio r)
| n -> Int 1
let normalize_num = function
if (!normalize_ratio_when_printing_flag) then (normalize_num n) else n
let num_of_ratio r =
- normalize_ratio r;
+ ignore (normalize_ratio r);
if not (is_integer_ratio r) then Ratio r
else if is_int_big_int (numerator_ratio r) then
Int (int_of_big_int (numerator_ratio r))
(***********************************************************************)
open Int_misc
-open String_misc
open Nat
open Big_int
open Arith_flags
normalized = r.normalized }
let add_int_ratio i r =
- cautious_normalize_ratio r;
+ ignore (cautious_normalize_ratio r);
{ numerator = add_big_int (mult_int_big_int i r.denominator) r.numerator;
denominator = r.denominator;
normalized = r.normalized }
let add_big_int_ratio bi r =
- cautious_normalize_ratio r;
+ ignore (cautious_normalize_ratio r);
{ numerator = add_big_int (mult_big_int bi r.denominator) r.numerator ;
denominator = r.denominator;
normalized = r.normalized }
normalized = false }
let square_ratio r =
- cautious_normalize_ratio r;
+ ignore (cautious_normalize_ratio r);
{ numerator = square_big_int r.numerator;
denominator = square_big_int r.denominator;
normalized = r.normalized }
(* Floor of a rational number *)
(* Always less or equal to r *)
let floor_ratio r =
- verify_null_denominator r;
+ ignore (verify_null_denominator r);
div_big_int (r.numerator) r.denominator
(* Round of a rational number *)
(* Odd function, 1/2 -> 1 *)
let round_ratio r =
- verify_null_denominator r;
+ ignore (verify_null_denominator r);
let abs_num = abs_big_int r.numerator in
let bi = div_big_int abs_num r.denominator in
report_sign_ratio r
(* Comparison operators on rational numbers *)
let eq_ratio r1 r2 =
- normalize_ratio r1;
- normalize_ratio r2;
+ ignore (normalize_ratio r1);
+ ignore (normalize_ratio r2);
eq_big_int (r1.numerator) r2.numerator &&
eq_big_int (r1.denominator) r2.denominator
(is_integer_ratio r) && eq_big_int bi r.numerator
let compare_big_int_ratio bi r =
- normalize_ratio r;
+ ignore (normalize_ratio r);
if (verify_null_denominator r)
then -(sign_big_int r.numerator)
else compare_big_int (mult_big_int bi r.denominator) r.numerator
normalized = true }
and nat_of_ratio r =
- normalize_ratio r;
+ ignore (normalize_ratio r);
if not (is_integer_ratio r) then
failwith "nat_of_ratio"
else if sign_big_int r.numerator > -1 then
{ numerator = bi; denominator = unit_big_int; normalized = true }
and big_int_of_ratio r =
- normalize_ratio r;
+ ignore (normalize_ratio r);
if is_integer_ratio r
then r.numerator
else failwith "big_int_of_ratio"
let div_int_ratio i r =
- verify_null_denominator r;
+ ignore (verify_null_denominator r);
mult_int_ratio i (inverse_ratio r)
let div_ratio_int r i =
div_ratio r (ratio_of_int i)
let div_big_int_ratio bi r =
- verify_null_denominator r;
+ ignore (verify_null_denominator r);
mult_big_int_ratio bi (inverse_ratio r)
let div_ratio_big_int r bi =
(* Nota : for a big_int we have msd_ratio = nums_digits_big_int -1 *)
let msd_ratio r =
- cautious_normalize_ratio r;
+ ignore (cautious_normalize_ratio r);
if null_denominator r then failwith_zero "msd_ratio"
else if sign_big_int r.numerator == 0 then 0
else begin
(* Coercions with type string *)
let string_of_ratio r =
- cautious_normalize_ratio_when_printing r;
+ ignore (cautious_normalize_ratio_when_printing r);
if !approx_printing_flag
then float_of_rational_string r
else string_of_big_int r.numerator ^ "/" ^ string_of_big_int r.denominator
scientifique. *)
let ratio_of_string s =
- let n = index_char s '/' 0 in
- if n = -1 then
+ try
+ let n = String.index s '/' in
+ create_ratio (sys_big_int_of_string s 0 n)
+ (sys_big_int_of_string s (n+1) (String.length s - n - 1))
+ with Not_found ->
{ numerator = big_int_of_string s;
denominator = unit_big_int;
normalized = true }
- else
- create_ratio (sys_big_int_of_string s 0 n)
- (sys_big_int_of_string s (n+1) (String.length s - n - 1))
(* Coercion with type float *)
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id: string_misc.ml,v 1.4 2001/12/07 13:40:16 xleroy Exp $ *)
-
-let rec index_char str chr pos =
- if pos >= String.length str then -1
- else if String.get str pos = chr then pos
- else index_char str chr (pos + 1)
-;;
+++ /dev/null
-(***********************************************************************)
-(* *)
-(* Objective Caml *)
-(* *)
-(* Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 1996 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU Library General Public License, with *)
-(* the special exception on linking described in file ../../LICENSE. *)
-(* *)
-(***********************************************************************)
-
-(* $Id: string_misc.mli,v 1.4 2001/12/07 13:40:17 xleroy Exp $ *)
-
-val index_char: string -> char -> int -> int
# #
#########################################################################
-# $Id: Makefile,v 1.9 2003/10/24 09:17:46 xleroy Exp $
+# $Id: Makefile,v 1.10 2005/09/22 14:21:50 xleroy Exp $
include ../../../config/Makefile
CAMLC=../../../boot/ocamlrun ../../../ocamlc -I ../../../stdlib
CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I ../../../stdlib
CC=$(BYTECC)
-CFLAGS=-I.. $(BYTECCCOMPOPTS)
+CFLAGS=-I.. -I../../../byterun $(BYTECCCOMPOPTS)
test: test.byt test.opt
if $(SUPPORTS_SHARED_LIBRARIES); then ../../../byterun/ocamlrun -I .. ./test.byt; else ./test.byt; fi
# #
#########################################################################
-# $Id: Makefile,v 1.31 2002/12/09 14:05:18 xleroy Exp $
+# $Id: Makefile,v 1.33 2004/11/29 14:53:32 doligez Exp $
# Makefile for the str library
(* *)
(***********************************************************************)
-(* $Id: str.mli,v 1.23.2.1 2005/03/10 16:03:11 doligez Exp $ *)
+(* $Id: str.mli,v 1.24 2005/03/24 17:20:53 doligez Exp $ *)
(** Regular expressions and high-level string processing *)
/* */
/***********************************************************************/
-/* $Id: strstubs.c,v 1.26 2004/05/17 17:10:00 doligez Exp $ */
+/* $Id: strstubs.c,v 1.27 2005/09/22 14:21:50 xleroy Exp $ */
#include <string.h>
#include <ctype.h>
} undo;
};
-#define Set_tag(p) ((value *) ((long)(p) | 1))
-#define Clear_tag(p) ((value *) ((long)(p) & ~1))
-#define Tag_is_set(p) ((long)(p) & 1)
+#define Set_tag(p) ((value *) ((intnat)(p) | 1))
+#define Clear_tag(p) ((value *) ((intnat)(p) & ~1))
+#define Tag_is_set(p) ((intnat)(p) & 1)
#define BACKTRACK_STACK_BLOCK_SIZE 500
};
#define Opcode(x) ((x) & 0xFF)
-#define Arg(x) ((unsigned long)(x) >> 8)
-#define SignedArg(x) ((long)(x) >> 8)
+#define Arg(x) ((uintnat)(x) >> 8)
+#define SignedArg(x) ((intnat)(x) >> 8)
enum {
CHAR, /* match a single character */
int accept_partial_match)
{
register value * pc;
- long instr;
+ intnat instr;
struct backtrack_stack * stack;
union backtrack_point * sp;
value cpool;
# #
#########################################################################
-# $Id: Makefile,v 1.35 2003/08/21 13:52:07 xleroy Exp $
+# $Id: Makefile,v 1.37 2004/11/29 14:53:32 doligez Exp $
include ../../config/Makefile
/* */
/***********************************************************************/
-/* $Id: posix.c,v 1.49.2.1 2004/07/01 09:32:38 xleroy Exp $ */
+/* $Id: posix.c,v 1.53 2005/09/22 14:21:50 xleroy Exp $ */
/* Thread interface for POSIX 1003.1c threads */
struct caml_thread_struct * prev;
#ifdef NATIVE_CODE
char * bottom_of_stack; /* Saved value of caml_bottom_of_stack */
- unsigned long last_retaddr; /* Saved value of caml_last_return_address */
+ uintnat last_retaddr; /* Saved value of caml_last_return_address */
value * gc_regs; /* Saved value of caml_gc_regs */
char * exception_pointer; /* Saved value of caml_exception_pointer */
struct caml__roots_block * local_roots; /* Saved value of local_roots */
static pthread_key_t last_channel_locked_key;
/* Identifier for next thread creation */
-static long thread_next_ident = 0;
+static intnat thread_next_ident = 0;
/* Whether to use sched_yield() or not */
static int broken_sched_yield = 0;
/* Hooks for enter_blocking_section and leave_blocking_section */
-static void (*prev_enter_blocking_section_hook) () = NULL;
-static void (*prev_leave_blocking_section_hook) () = NULL;
-
static void caml_thread_enter_blocking_section(void)
{
- if (prev_enter_blocking_section_hook != NULL)
- (*prev_enter_blocking_section_hook)();
/* Save the stack-related global variables in the thread descriptor
of the current thread */
#ifdef NATIVE_CODE
backtrace_buffer = curr_thread->backtrace_buffer;
backtrace_last_exn = curr_thread->backtrace_last_exn;
#endif
- if (prev_leave_blocking_section_hook != NULL)
- (*prev_leave_blocking_section_hook)();
+}
+
+static int caml_thread_try_leave_blocking_section(void)
+{
+ /* Disable immediate processing of signals (PR#3659).
+ try_leave_blocking_section always fails, forcing the signal to be
+ recorded and processed at the next leave_blocking_section or
+ polling. */
+ return 0;
}
/* Hooks for I/O locking */
select(0, NULL, NULL, NULL, &timeout);
/* This signal should never cause a callback, so don't go through
handle_signal(), tweak the global variable directly. */
- if (pending_signal == 0) pending_signal = SIGVTALRM;
+ pending_signals[SIGVTALRM] = 1;
#ifdef NATIVE_CODE
young_limit = young_end;
#else
/* Set up the hooks */
prev_scan_roots_hook = scan_roots_hook;
scan_roots_hook = caml_thread_scan_roots;
- prev_enter_blocking_section_hook = enter_blocking_section_hook;
enter_blocking_section_hook = caml_thread_enter_blocking_section;
- prev_leave_blocking_section_hook = leave_blocking_section_hook;
leave_blocking_section_hook = caml_thread_leave_blocking_section;
+ try_leave_blocking_section_hook = caml_thread_try_leave_blocking_section;
#ifdef NATIVE_CODE
caml_termination_hook = pthread_exit;
#endif
th->next->prev = th->prev;
th->prev->next = th->next;
/* Release the runtime system */
- async_signal_mode = 1;
pthread_mutex_lock(&caml_runtime_mutex);
caml_runtime_busy = 0;
pthread_mutex_unlock(&caml_runtime_mutex);
return retcode;
}
+/* Signal mask */
+
+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)));
+ sigaddset(set, sig);
+ vset = Field(vset, 1);
+ }
+}
+
+#ifndef NSIG
+#define NSIG 64
+#endif
+
+static value encode_sigset(sigset_t * set)
+{
+ value res = Val_int(0);
+ int i;
+
+ Begin_root(res)
+ for (i = 1; i < NSIG; i++)
+ if (sigismember(set, i)) {
+ value newcons = alloc_small(2, 0);
+ Field(newcons, 0) = Val_int(i);
+ Field(newcons, 1) = res;
+ res = newcons;
+ }
+ End_roots();
+ return res;
+}
+
+static int sigmask_cmd[3] = { SIG_SETMASK, SIG_BLOCK, SIG_UNBLOCK };
+
+value caml_thread_sigmask(value cmd, value sigs) /* ML */
+{
+ int how;
+ sigset_t set, oldset;
+ int retcode;
+
+ how = sigmask_cmd[Int_val(cmd)];
+ decode_sigset(sigs, &set);
+ enter_blocking_section();
+ retcode = pthread_sigmask(how, &set, &oldset);
+ leave_blocking_section();
+ caml_pthread_check(retcode, "Thread.sigmask");
+ return encode_sigset(&oldset);
+}
+
/* Synchronous signal wait */
value caml_wait_signal(value sigs) /* ML */
sigset_t set;
int retcode, signo;
- sigemptyset(&set);
- while (sigs != Val_int(0)) {
- int sig = convert_signal_number(Int_val(Field(sigs, 0)));
- sigaddset(&set, sig);
- sigs = Field(sigs, 1);
- }
+ decode_sigset(sigs, &set);
enter_blocking_section();
retcode = sigwait(&set, &signo);
leave_blocking_section();
(* *)
(***********************************************************************)
-(* $Id: thread.mli,v 1.19 2001/12/28 23:14:48 guesdon Exp $ *)
+(* $Id: thread.mli,v 1.20 2005/07/31 12:32:41 xleroy Exp $ *)
(** Lightweight threads for Posix [1003.1c] and Win32. *)
its termination status, as per [Unix.wait].
This function is not implemented under MacOS. *)
+val yield : unit -> unit
+(** Re-schedule the calling thread without suspending it.
+ This function can be used to give scheduling hints,
+ telling the scheduler that now is a good time to
+ switch to other threads. *)
+
+(** {6 Management of signals} *)
+
+(** Signal handling follows the POSIX thread model: signals generated
+ by a thread are delivered to that thread; signals generated externally
+ are delivered to one of the threads that does not block it.
+ Each thread possesses a set of blocked signals, which can be modified
+ using {!Thread.sigmask}. This set is inherited at thread creation time.
+ Per-thread signal masks are supported only by the system thread library
+ under Unix, but not under Win32, nor by the VM thread library. *)
+
+val sigmask : Unix.sigprocmask_command -> int list -> int list
+(** [sigmask cmd sigs] changes the set of blocked signals for the
+ calling thread.
+ If [cmd] is [SIG_SETMASK], blocked signals are set to those in
+ the list [sigs].
+ If [cmd] is [SIG_BLOCK], the signals in [sigs] are added to
+ the set of blocked signals.
+ If [cmd] is [SIG_UNBLOCK], the signals in [sigs] are removed
+ from the set of blocked signals.
+ [sigmask] returns the set of previously blocked signals for the thread. *)
+
+
val wait_signal : int list -> int
(** [wait_signal sigs] suspends the execution of the calling thread
until the process receives one of the signals specified in the
list [sigs]. It then returns the number of the signal received.
Signal handlers attached to the signals in [sigs] will not
- be invoked. Do not call [wait_signal] concurrently
- from several threads on the same signals. *)
+ be invoked. The signals [sigs] are expected to be blocked before
+ calling [wait_signal]. *)
-val yield : unit -> unit
-(** Re-schedule the calling thread without suspending it.
- This function can be used to give scheduling hints,
- telling the scheduler that now is a good time to
- switch to other threads. *)
(* *)
(***********************************************************************)
-(* $Id: thread_posix.ml,v 1.9 2003/06/16 12:31:13 xleroy Exp $ *)
+(* $Id: thread_posix.ml,v 1.10 2005/07/31 12:32:41 xleroy Exp $ *)
(* User-level threads *)
let wait_pid p = Unix.waitpid [] p
+external sigmask : Unix.sigprocmask_command -> int list -> int list = "caml_thread_sigmask"
external wait_signal : int list -> int = "caml_wait_signal"
(* *)
(***********************************************************************)
-(* $Id: thread_win32.ml,v 1.8 2001/12/07 13:40:20 xleroy Exp $ *)
+(* $Id: thread_win32.ml,v 1.9 2005/07/31 12:32:41 xleroy Exp $ *)
(* User-level threads *)
let wait_pid p = Unix.waitpid [] p
-external wait_signal : int list -> int = "caml_wait_signal"
+let sigmask cmd set = invalid_arg "Thread.sigmask: not implemented"
+let wait_signal set = invalid_arg "Thread.wait_signal: not implemented"
+
/* */
/***********************************************************************/
-/* $Id: win32.c,v 1.38 2003/12/29 22:15:02 doligez Exp $ */
+/* $Id: win32.c,v 1.42 2005/09/22 14:21:50 xleroy Exp $ */
/* Thread interface for Win32 threads */
struct caml_thread_struct * prev;
#ifdef NATIVE_CODE
char * bottom_of_stack; /* Saved value of caml_bottom_of_stack */
- unsigned long last_retaddr; /* Saved value of caml_last_return_address */
+ uintnat last_retaddr; /* Saved value of caml_last_return_address */
value * gc_regs; /* Saved value of caml_gc_regs */
char * exception_pointer; /* Saved value of caml_exception_pointer */
struct caml__roots_block * local_roots; /* Saved value of local_roots */
static DWORD last_channel_locked_key;
/* Identifier for next thread creation */
-static long thread_next_ident = 0;
+static intnat thread_next_ident = 0;
/* Forward declarations */
/* Hooks for enter_blocking_section and leave_blocking_section */
-static void (*prev_enter_blocking_section_hook) () = NULL;
-static void (*prev_leave_blocking_section_hook) () = NULL;
-
static void caml_thread_enter_blocking_section(void)
{
- if (prev_enter_blocking_section_hook != NULL)
- (*prev_enter_blocking_section_hook)();
/* Save the stack-related global variables in the thread descriptor
of the current thread */
#ifdef NATIVE_CODE
static void caml_thread_leave_blocking_section(void)
{
- /* Re-acquire the global mutex */
WaitForSingleObject(caml_mutex, INFINITE);
/* Update curr_thread to point to the thread descriptor corresponding
to the thread currently executing */
backtrace_buffer = curr_thread->backtrace_buffer;
backtrace_last_exn = curr_thread->backtrace_last_exn;
#endif
- if (prev_leave_blocking_section_hook != NULL)
- (*prev_leave_blocking_section_hook)();
+}
+
+static int caml_thread_try_leave_blocking_section(void)
+{
+ /* Disable immediate processing of signals (PR#3659).
+ try_leave_blocking_section always fails, forcing the signal to be
+ recorded and processed at the next leave_blocking_section or
+ polling. */
+ return 0;
}
/* Hooks for I/O locking */
{
while(1) {
Sleep(Thread_timeout);
- pending_signal = SIGTIMER;
+ pending_signals[SIGTIMER] = 1;
#ifdef NATIVE_CODE
young_limit = young_end;
#else
value vthread = Val_unit;
value descr;
HANDLE tick_thread;
- unsigned long tick_id;
+ uintnat tick_id;
/* Protect against repeated initialization (PR#1325) */
if (curr_thread != NULL) return Val_unit;
/* Set up the hooks */
prev_scan_roots_hook = scan_roots_hook;
scan_roots_hook = caml_thread_scan_roots;
- prev_enter_blocking_section_hook = enter_blocking_section_hook;
enter_blocking_section_hook = caml_thread_enter_blocking_section;
- prev_leave_blocking_section_hook = leave_blocking_section_hook;
leave_blocking_section_hook = caml_thread_leave_blocking_section;
+ try_leave_blocking_section_hook = caml_thread_try_leave_blocking_section;
caml_channel_mutex_free = caml_io_mutex_free;
caml_channel_mutex_lock = caml_io_mutex_lock;
caml_channel_mutex_unlock = caml_io_mutex_unlock;
th->next->prev = th->prev;
th->prev->next = th->next;
/* Release the main mutex (forever) */
- async_signal_mode = 1;
ReleaseMutex(caml_mutex);
#ifndef NATIVE_CODE
/* Free the memory resources */
caml_thread_t th;
value vthread = Val_unit;
value descr;
- unsigned long th_id;
+ uintnat th_id;
Begin_roots2 (clos, vthread)
/* Create a finalized value to hold thread handle */
/* Conditions operations */
struct caml_condvar {
- unsigned long count; /* Number of waiting threads */
+ uintnat count; /* Number of waiting threads */
HANDLE sem; /* Semaphore on which threads are waiting */
};
CAMLprim value caml_condition_broadcast(value cond)
{
HANDLE s = Condition_val(cond)->sem;
- unsigned long c = Condition_val(cond)->count;
+ uintnat c = Condition_val(cond)->count;
if (c > 0) {
Condition_val(cond)->count = 0;
return Val_unit;
}
-/* Synchronous signal wait */
-
-static HANDLE wait_signal_event[NSIG];
-static int * wait_signal_received[NSIG];
-
-static void caml_wait_signal_handler(int signo)
-{
- *(wait_signal_received[signo]) = signo;
- SetEvent(wait_signal_event[signo]);
-}
-
-typedef void (*sighandler_type)(int);
-
-CAMLprim value caml_wait_signal(value sigs)
-{
- HANDLE event;
- int res, s, retcode;
- value l;
- sighandler_type oldsignals[NSIG];
-
- Begin_root(sigs);
- event = CreateEvent(NULL, FALSE, FALSE, NULL);
- if (event == NULL)
- caml_wthread_error("Thread.wait_signal (CreateEvent)");
- res = 0;
- for (l = sigs; l != Val_int(0); l = Field(l, 1)) {
- s = convert_signal_number(Int_val(Field(l, 0)));
- oldsignals[s] = signal(s, caml_wait_signal_handler);
- if (oldsignals[s] == SIG_ERR) {
- CloseHandle(event);
- caml_wthread_error("Thread.wait_signal (signal)");
- }
- wait_signal_event[s] = event;
- wait_signal_received[s] = &res;
- }
- enter_blocking_section();
- retcode = WaitForSingleObject(event, INFINITE);
- leave_blocking_section();
- for (l = sigs; l != Val_int(0); l = Field(l, 1)) {
- s = convert_signal_number(Int_val(Field(l, 0)));
- signal(s, oldsignals[s]);
- }
- CloseHandle(event);
- End_roots();
- if (retcode == WAIT_FAILED)
- caml_wthread_error("Thread.wait_signal (WaitForSingleObject)");
- return Val_int(res);
-}
-
/* Error report */
static void caml_wthread_error(char * msg)
# #
#########################################################################
-# $Id: Makefile,v 1.53 2003/07/17 08:38:28 xleroy Exp $
+# $Id: Makefile,v 1.57 2004/11/29 14:53:32 doligez Exp $
include ../../config/Makefile
$(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)/genlex.cmo $(LIB)/callback.cmo $(LIB)/weak.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)/arrayLabels.cmo $(LIB)/listLabels.cmo $(LIB)/stringLabels.cmo \
$(LIB)/stdLabels.cmo $(LIB)/moreLabels.cmo
(* *)
(***********************************************************************)
-(* $Id: pervasives.ml,v 1.48.4.1 2004/06/22 12:13:46 xleroy Exp $ *)
+(* $Id: pervasives.ml,v 1.49 2004/07/13 12:25:13 xleroy Exp $ *)
(* Same as ../../stdlib/pervasives.ml, except that I/O functions have
been redefined to not block the whole process, but only the calling
/* */
/***********************************************************************/
-/* $Id: scheduler.c,v 1.58.4.1 2005/06/21 12:27:36 doligez Exp $ */
+/* $Id: scheduler.c,v 1.60 2005/09/22 14:21:50 xleroy Exp $ */
/* The thread scheduler */
value thread_outchan_ready(value vchan, value vsize) /* ML */
{
struct channel * chan = Channel(vchan);
- long size = Long_val(vsize);
+ intnat size = Long_val(vsize);
/* Negative size means we want to flush the buffer entirely */
if (size < 0) {
return Val_bool(chan->curr == chan->buff);
(* *)
(***********************************************************************)
-(* $Id: thread.mli,v 1.27.6.1 2004/06/30 09:32:40 doligez Exp $ *)
+(* $Id: thread.mli,v 1.28 2004/07/13 12:25:13 xleroy Exp $ *)
(** Lightweight threads. *)
(* *)
(***********************************************************************)
-(* $Id: threadUnix.ml,v 1.18.6.1 2004/06/22 17:18:49 remy Exp $ *)
+(* $Id: threadUnix.ml,v 1.19 2004/07/13 12:25:13 xleroy Exp $ *)
(* Module [ThreadUnix]: thread-compatible system calls *)
(* *)
(***********************************************************************)
-(* $Id: threadUnix.mli,v 1.21.6.1 2004/06/22 17:18:49 remy Exp $ *)
+(* $Id: threadUnix.mli,v 1.22 2004/07/13 12:25:14 xleroy Exp $ *)
(** Thread-compatible system calls.
(* *)
(***********************************************************************)
-(* $Id: unix.ml,v 1.16.2.2 2004/11/06 10:14:58 xleroy Exp $ *)
+(* $Id: unix.ml,v 1.19 2005/03/24 17:20:53 doligez Exp $ *)
(* An alternate implementation of the Unix module from ../unix
which is safe in conjunction with bytecode threads. *)
0 -> if input <> stdin then begin dup2 input stdin; close input end;
if output <> stdout then begin dup2 output stdout; close output end;
List.iter close toclose;
- execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |];
- exit 127
+ begin try execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
+ with _ -> exit 127
+ end
| id -> Hashtbl.add popen_processes proc id
let open_process_in cmd =
dup2 output stdout; close output;
dup2 error stderr; close error;
List.iter close toclose;
- execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env;
- exit 127
+ begin try execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env
+ with _ -> exit 127
+ end
| id -> Hashtbl.add popen_processes proc id
let open_process_full cmd env =
# #
#########################################################################
-# $Id: Makefile,v 1.38 2004/04/09 13:25:20 xleroy Exp $
+# $Id: Makefile,v 1.41 2004/11/29 14:53:32 doligez Exp $
# Makefile for the Unix interface library
/* */
/***********************************************************************/
-/* $Id: accept.c,v 1.12.6.2 2005/01/12 15:08:56 doligez Exp $ */
+/* $Id: accept.c,v 1.13 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: access.c,v 1.10.6.1 2004/11/02 16:21:25 doligez Exp $ */
+/* $Id: access.c,v 1.11 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: alarm.c,v 1.7.6.1 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: alarm.c,v 1.8 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: bind.c,v 1.9.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: bind.c,v 1.10 2005/03/24 17:20:53 doligez Exp $ */
#include <fail.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: connect.c,v 1.11.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: connect.c,v 1.12 2005/03/24 17:20:53 doligez Exp $ */
#include <fail.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: envir.c,v 1.9.6.1 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: envir.c,v 1.10 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: fchmod.c,v 1.9.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: fchmod.c,v 1.10 2005/03/24 17:20:53 doligez Exp $ */
#include <sys/types.h>
#include <sys/stat.h>
/* */
/***********************************************************************/
-/* $Id: fchown.c,v 1.8.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: fchown.c,v 1.9 2005/03/24 17:20:53 doligez Exp $ */
#include <fail.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: fcntl.c,v 1.11.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: fcntl.c,v 1.12 2005/03/24 17:20:53 doligez Exp $ */
#include <fail.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: ftruncate.c,v 1.9.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: ftruncate.c,v 1.10 2005/03/24 17:20:53 doligez Exp $ */
#include <sys/types.h>
#include <fail.h>
/* */
/***********************************************************************/
-/* $Id: getaddrinfo.c,v 1.1.4.3 2005/04/17 08:53:02 xleroy Exp $ */
+/* $Id: getaddrinfo.c,v 1.3 2005/08/13 20:59:37 doligez Exp $ */
#include <string.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: getcwd.c,v 1.14.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: getcwd.c,v 1.15 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: getegid.c,v 1.8.6.1 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: getegid.c,v 1.9 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: geteuid.c,v 1.8.6.1 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: geteuid.c,v 1.9 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: getgid.c,v 1.8.6.1 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: getgid.c,v 1.9 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: getgroups.c,v 1.10.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: getgroups.c,v 1.11 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: gethost.c,v 1.24.2.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: gethost.c,v 1.26 2005/10/13 14:50:37 xleroy Exp $ */
#include <string.h>
#include <mlvalues.h>
res = alloc_small(4, 0);
Field(res, 0) = name;
Field(res, 1) = aliases;
- Field(res, 2) = entry->h_addrtype == PF_UNIX ? Val_int(0) : Val_int(1);
+ switch (entry->h_addrtype) {
+ case PF_UNIX: Field(res, 2) = Val_int(0); break;
+ case PF_INET: Field(res, 2) = Val_int(1); break;
+ default: /*PF_INET6 */ Field(res, 2) = Val_int(2); break;
+ }
Field(res, 3) = addr_list;
End_roots();
return res;
/* */
/***********************************************************************/
-/* $Id: gethostname.c,v 1.10.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: gethostname.c,v 1.11 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: getlogin.c,v 1.8.6.1 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: getlogin.c,v 1.9 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: getnameinfo.c,v 1.1.4.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: getnameinfo.c,v 1.2 2005/03/24 17:20:53 doligez Exp $ */
#include <string.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: getpeername.c,v 1.10.2.2 2005/01/12 15:08:56 doligez Exp $ */
+/* $Id: getpeername.c,v 1.11 2005/03/24 17:20:53 doligez Exp $ */
#include <fail.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: getpid.c,v 1.8.6.1 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: getpid.c,v 1.9 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: getppid.c,v 1.8.6.1 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: getppid.c,v 1.9 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: getproto.c,v 1.12.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: getproto.c,v 1.13 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: getserv.c,v 1.13.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: getserv.c,v 1.14 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: getsockname.c,v 1.9.6.2 2005/01/12 15:08:56 doligez Exp $ */
+/* $Id: getsockname.c,v 1.10 2005/03/24 17:20:53 doligez Exp $ */
#include <fail.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: gettimeofday.c,v 1.7.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: gettimeofday.c,v 1.8 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: getuid.c,v 1.8.6.1 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: getuid.c,v 1.9 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: gmtime.c,v 1.16.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: gmtime.c,v 1.17 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: itimer.c,v 1.13.4.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: itimer.c,v 1.14 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: listen.c,v 1.10.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: listen.c,v 1.11 2005/03/24 17:20:53 doligez Exp $ */
#include <fail.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: lockf.c,v 1.13.2.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: lockf.c,v 1.14 2005/03/24 17:20:53 doligez Exp $ */
#include <errno.h>
#include <fcntl.h>
/* */
/***********************************************************************/
-/* $Id: mkfifo.c,v 1.10.6.2 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: mkfifo.c,v 1.11 2005/03/24 17:20:53 doligez Exp $ */
#include <sys/types.h>
#include <sys/stat.h>
/* */
/***********************************************************************/
-/* $Id: open.c,v 1.11.6.1 2004/11/02 16:21:25 doligez Exp $ */
+/* $Id: open.c,v 1.12 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: pipe.c,v 1.9.6.1 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: pipe.c,v 1.10 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: putenv.c,v 1.8.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: putenv.c,v 1.9 2005/03/24 17:20:53 doligez Exp $ */
#include <stdlib.h>
#include <string.h>
/* */
/***********************************************************************/
-/* $Id: readlink.c,v 1.10.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: readlink.c,v 1.11 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: rewinddir.c,v 1.11.2.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: rewinddir.c,v 1.12 2005/03/24 17:20:53 doligez Exp $ */
#include <fail.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: select.c,v 1.21.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: select.c,v 1.22 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: sendrecv.c,v 1.18.6.4 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: sendrecv.c,v 1.19 2005/03/24 17:20:53 doligez Exp $ */
#include <string.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: setsid.c,v 1.5.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: setsid.c,v 1.6 2005/03/24 17:20:53 doligez Exp $ */
#include <fail.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: shutdown.c,v 1.10.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: shutdown.c,v 1.11 2005/03/24 17:20:53 doligez Exp $ */
#include <fail.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: signals.c,v 1.9.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: signals.c,v 1.10 2005/03/24 17:20:53 doligez Exp $ */
#include <errno.h>
#include <signal.h>
/* */
/***********************************************************************/
-/* $Id: socket.c,v 1.10.2.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: socket.c,v 1.11 2005/03/24 17:20:53 doligez Exp $ */
#include <fail.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: socketaddr.c,v 1.22.2.2 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: socketaddr.c,v 1.23 2005/03/24 17:20:53 doligez Exp $ */
#include <string.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: socketaddr.h,v 1.15.2.2 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: socketaddr.h,v 1.16 2005/03/24 17:20:53 doligez Exp $ */
#include <misc.h>
#include <sys/types.h>
/* */
/***********************************************************************/
-/* $Id: socketpair.c,v 1.11.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: socketpair.c,v 1.12 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: sockopt.c,v 1.18.6.2 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: sockopt.c,v 1.19 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: strofaddr.c,v 1.9.2.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: strofaddr.c,v 1.10 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: symlink.c,v 1.8.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: symlink.c,v 1.9 2005/03/24 17:20:53 doligez Exp $ */
#include <fail.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: termios.c,v 1.14.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: termios.c,v 1.15 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: time.c,v 1.9.6.1 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: time.c,v 1.10 2005/03/24 17:20:53 doligez Exp $ */
#include <time.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: times.c,v 1.14.6.1 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: times.c,v 1.15 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: truncate.c,v 1.9.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: truncate.c,v 1.10 2005/03/24 17:20:53 doligez Exp $ */
#include <sys/types.h>
#include <mlvalues.h>
(* *)
(***********************************************************************)
-(* $Id: unix.ml,v 1.60.2.3 2004/11/06 10:14:58 xleroy Exp $ *)
+(* $Id: unix.ml,v 1.65 2005/10/12 14:55:40 xleroy Exp $ *)
type error =
E2BIG
0 -> if input <> stdin then begin dup2 input stdin; close input end;
if output <> stdout then begin dup2 output stdout; close output end;
if not cloexec then List.iter close toclose;
- execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |];
- exit 127
+ begin try execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
+ with _ -> exit 127
+ end
| id -> Hashtbl.add popen_processes proc id
let open_process_in cmd =
dup2 output stdout; close output;
dup2 error stderr; close error;
if not cloexec then List.iter close toclose;
- execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env;
- exit 127
+ begin try execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env
+ with _ -> exit 127
+ end
| id -> Hashtbl.add popen_processes proc id
let open_process_full cmd env =
let shutdown_connection inchan =
shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND
+let rec accept_non_intr s =
+ try accept s
+ with Unix_error (EINTR, _, _) -> accept_non_intr s
+
let establish_server server_fun sockaddr =
let sock =
socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
bind sock sockaddr;
listen sock 5;
while true do
- let (s, caller) = accept sock in
+ let (s, caller) = accept_non_intr sock in
(* The "double fork" trick, the process which calls server_fun will not
leave a zombie process *)
match fork() with
0 -> if fork() <> 0 then exit 0; (* The son exits, the grandson works *)
+ close sock;
ignore(try_set_close_on_exec s);
let inchan = in_channel_of_descr s in
let outchan = out_channel_of_descr s in
server_fun inchan outchan;
- close_out outchan;
- (* The file descriptor was already closed by close_out.
- close_in inchan;
- *)
+ (* Do not close inchan nor outchan, as the server_fun could
+ have done it already, and we are about to exit anyway
+ (PR#3794) *)
exit 0
- | id -> close s; ignore(waitpid [] id) (* Reclaim the son *)
+ | id -> close s; ignore(waitpid_non_intr id) (* Reclaim the son *)
done
(* *)
(***********************************************************************)
-(* $Id: unix.mli,v 1.79.2.4 2004/12/22 16:11:13 doligez Exp $ *)
+(* $Id: unix.mli,v 1.81 2005/03/24 17:20:53 doligez Exp $ *)
(** Interface to the Unix system *)
(* *)
(***********************************************************************)
-(* $Id: unixLabels.mli,v 1.12.2.2 2004/07/02 09:37:17 doligez Exp $ *)
+(* $Id: unixLabels.mli,v 1.13 2004/07/13 12:25:14 xleroy Exp $ *)
(** Interface to the Unix system.
To use as replacement to default {!Unix} module,
/* */
/***********************************************************************/
-/* $Id: unixsupport.c,v 1.17 2002/03/02 09:16:38 xleroy Exp $ */
+/* $Id: unixsupport.c,v 1.18 2005/09/06 12:38:32 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
static value * unix_error_exn = NULL;
+value unix_error_of_code (int errcode)
+{
+ int errconstr;
+ value err;
+
+ errconstr =
+ cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1);
+ if (errconstr == Val_int(-1)) {
+ err = alloc_small(1, 0);
+ Field(err, 0) = Val_int(errcode);
+ } else {
+ err = errconstr;
+ }
+ return err;
+}
+
void unix_error(int errcode, char *cmdname, value cmdarg)
{
value res;
value name = Val_unit, err = Val_unit, arg = Val_unit;
- int errconstr;
Begin_roots3 (name, err, arg);
arg = cmdarg == Nothing ? copy_string("") : cmdarg;
name = copy_string(cmdname);
- errconstr =
- cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1);
- if (errconstr == Val_int(-1)) {
- err = alloc_small(1, 0);
- Field(err, 0) = Val_int(errcode);
- } else {
- err = errconstr;
- }
+ err = unix_error_of_code (errcode);
if (unix_error_exn == NULL) {
unix_error_exn = caml_named_value("Unix.Unix_error");
if (unix_error_exn == NULL)
/* */
/***********************************************************************/
-/* $Id: unixsupport.h,v 1.7 2004/02/14 10:21:23 xleroy Exp $ */
+/* $Id: unixsupport.h,v 1.8 2005/09/06 12:38:32 doligez Exp $ */
#ifdef HAS_UNISTD
#include <unistd.h>
#define Nothing ((value) 0)
+extern value unix_error_of_code (int errcode);
extern void unix_error (int errcode, char * cmdname, value arg) Noreturn;
extern void uerror (char * cmdname, value arg) Noreturn;
/* */
/***********************************************************************/
-/* $Id: utimes.c,v 1.9.6.1 2004/08/23 11:31:44 doligez Exp $ */
+/* $Id: utimes.c,v 1.10 2005/03/24 17:20:53 doligez Exp $ */
#include <fail.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: wait.c,v 1.17.6.3 2005/01/17 18:10:36 doligez Exp $ */
+/* $Id: wait.c,v 1.19 2005/04/17 08:23:51 xleroy Exp $ */
#include <mlvalues.h>
#include <alloc.h>
}
else if (WIFSTOPPED(status)) {
st = alloc_small(1, TAG_WSTOPPED);
- Field(st, 0) = Val_int(WSTOPSIG(status));
+ Field(st, 0) = Val_int(caml_rev_convert_signal_number(WSTOPSIG(status)));
}
else {
st = alloc_small(1, TAG_WSIGNALED);
- Field(st, 0) = Val_int(WTERMSIG(status));
+ Field(st, 0) = Val_int(caml_rev_convert_signal_number(WTERMSIG(status)));
}
Begin_root (st);
res = alloc_small(2, 0);
/* */
/***********************************************************************/
-/* $Id: write.c,v 1.13.6.3 2004/07/08 08:40:47 xleroy Exp $ */
+/* $Id: write.c,v 1.14 2004/07/13 12:25:15 xleroy Exp $ */
#include <errno.h>
#include <string.h>
# #
#########################################################################
-# $Id: Makefile.nt,v 1.5.6.1 2004/06/21 15:31:58 xleroy Exp $
+# $Id: Makefile.nt,v 1.6 2004/07/13 12:25:15 xleroy Exp $
include ../../config/Makefile
/* */
/***********************************************************************/
-/* $Id: draw.c,v 1.9.2.3 2005/02/03 16:40:12 xleroy Exp $ */
+/* $Id: draw.c,v 1.11 2005/03/24 17:20:53 doligez Exp $ */
#include <math.h>
#include "mlvalues.h"
/* */
/***********************************************************************/
-/* $Id: events.c,v 1.1.2.1 2004/06/21 15:31:58 xleroy Exp $ */
+/* $Id: events.c,v 1.2 2004/07/13 12:25:15 xleroy Exp $ */
#include "mlvalues.h"
#include "alloc.h"
/* */
/***********************************************************************/
-/* $Id: libgraph.h,v 1.8.2.1 2004/06/21 15:31:58 xleroy Exp $ */
+/* $Id: libgraph.h,v 1.9 2004/07/13 12:25:15 xleroy Exp $ */
#include <stdio.h>
#include <windows.h>
/* */
/***********************************************************************/
-/* $Id: open.c,v 1.8.2.3 2005/05/26 09:15:22 doligez Exp $ */
+/* $Id: open.c,v 1.10.2.1 2005/10/27 09:02:59 xleroy Exp $ */
#include <fcntl.h>
#include <signal.h>
CAMLprim value caml_gr_resize_window (value vx, value vy)
{
- caml_gr_check_open ();
+ gr_check_open ();
/* FIXME TODO implement this function... */
/* */
/***********************************************************************/
-/* $Id: accept.c,v 1.18.6.1 2005/02/02 15:40:14 xleroy Exp $ */
+/* $Id: accept.c,v 1.19 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $Id: getpeername.c,v 1.9.6.1 2005/02/02 15:40:14 xleroy Exp $ */
+/* $Id: getpeername.c,v 1.10 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: getsockname.c,v 1.7.6.1 2005/02/02 15:40:14 xleroy Exp $ */
+/* $Id: getsockname.c,v 1.8 2005/03/24 17:20:53 doligez Exp $ */
#include <mlvalues.h>
#include "unixsupport.h"
/* */
/***********************************************************************/
-/* $Id: lockf.c,v 1.3 2002/07/23 14:12:01 doligez Exp $ */
+/* $Id: lockf.c,v 1.4 2005/09/22 14:21:50 xleroy Exp $ */
#include <errno.h>
#include <fcntl.h>
LONG high = dest.HighPart;
DWORD ret = SetFilePointer(h, dest.LowPart, &high, method);
if (ret == INVALID_SET_FILE_POINTER) {
- long err = GetLastError();
+ DWORD err = GetLastError();
if (err != NO_ERROR) { win32_maperr(err); uerror("lockf", Nothing); }
}
if (cur != NULL) { cur->LowPart = ret; cur->HighPart = high; }
/* */
/***********************************************************************/
-/* $Id: lseek.c,v 1.6 2002/06/07 09:49:41 xleroy Exp $ */
+/* $Id: lseek.c,v 1.7 2005/02/02 15:52:26 xleroy Exp $ */
#include <mlvalues.h>
#include <alloc.h>
#define SEEK_END 2
#endif
-static int seek_command_table[] = {
+static DWORD seek_command_table[] = {
FILE_BEGIN, FILE_CURRENT, FILE_END
};
#define INVALID_SET_FILE_POINTER (-1)
#endif
-CAMLprim value unix_lseek(value fd, value ofs, value cmd)
+static __int64 caml_set_file_pointer(HANDLE h, __int64 dist, DWORD mode)
{
- long ret;
- long ofs_low = Long_val(ofs);
- long ofs_high = ofs_low >= 0 ? 0 : -1;
- long err;
+ LARGE_INTEGER i;
+ DWORD err;
- ret = SetFilePointer(Handle_val(fd), ofs_low, &ofs_high,
- seek_command_table[Int_val(cmd)]);
- if (ret == INVALID_SET_FILE_POINTER) {
+ i.QuadPart = dist;
+ i.LowPart = SetFilePointer(h, i.LowPart, &i.HighPart, mode);
+ if (i.LowPart == INVALID_SET_FILE_POINTER) {
err = GetLastError();
- if (err != NO_ERROR) {
- win32_maperr(err);
- uerror("lseek", Nothing);
- }
+ if (err != NO_ERROR) { win32_maperr(err); uerror("lseek", Nothing); }
}
- if (ofs_high != 0 || ret > Max_long) {
+ return i.QuadPart;
+}
+
+CAMLprim value unix_lseek(value fd, value ofs, value cmd)
+{
+ __int64 ret;
+
+ ret = caml_set_file_pointer(Handle_val(fd), Long_val(ofs),
+ seek_command_table[Int_val(cmd)]);
+ if (ret > Max_long) {
win32_maperr(ERROR_ARITHMETIC_OVERFLOW);
uerror("lseek", Nothing);
}
CAMLprim value unix_lseek_64(value fd, value ofs, value cmd)
{
- long ret;
- long ofs_low = (long) Int64_val(ofs);
- long ofs_high = (long) (Int64_val(ofs) >> 32);
- long err;
+ __int64 ret;
- ret = SetFilePointer(Handle_val(fd), ofs_low, &ofs_high,
- seek_command_table[Int_val(cmd)]);
- if (ret == INVALID_SET_FILE_POINTER) {
- err = GetLastError();
- if (err != NO_ERROR) {
- win32_maperr(err);
- uerror("lseek", Nothing);
- }
- }
- return copy_int64((int64) ofs_high << 32 | ret);
+ ret = caml_set_file_pointer(Handle_val(fd), Int64_val(ofs),
+ seek_command_table[Int_val(cmd)]);
+ return copy_int64(ret);
}
/* */
/***********************************************************************/
-/* $Id: rename.c,v 1.2.8.1 2004/06/21 16:18:32 xleroy Exp $ */
+/* $Id: rename.c,v 1.3 2004/07/13 12:25:15 xleroy Exp $ */
#include <stdio.h>
#include <mlvalues.h>
/* */
/***********************************************************************/
-/* $Id: sendrecv.c,v 1.16.6.1 2005/02/02 15:40:14 xleroy Exp $ */
+/* $Id: sendrecv.c,v 1.18 2005/09/22 14:21:50 xleroy Exp $ */
#include <mlvalues.h>
#include <alloc.h>
CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value flags)
{
int ret;
- long numbytes;
+ intnat numbytes;
char iobuf[UNIX_BUFFER_SIZE];
Begin_root (buff);
CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value flags)
{
int ret;
- long numbytes;
+ intnat numbytes;
char iobuf[UNIX_BUFFER_SIZE];
value res;
value adr = Val_unit;
CAMLprim value unix_send(value sock, value buff, value ofs, value len, value flags)
{
int ret;
- long numbytes;
+ intnat numbytes;
char iobuf[UNIX_BUFFER_SIZE];
numbytes = Long_val(len);
value unix_sendto_native(value sock, value buff, value ofs, value len, value flags, value dest)
{
int ret;
- long numbytes;
+ intnat numbytes;
char iobuf[UNIX_BUFFER_SIZE];
union sock_addr_union addr;
socklen_param_type addr_len;
/* */
/***********************************************************************/
-/* $Id: socketaddr.h,v 1.7.2.1 2005/02/02 15:40:14 xleroy Exp $ */
+/* $Id: socketaddr.h,v 1.8 2005/03/24 17:20:53 doligez Exp $ */
#include <misc.h>
(* *)
(***********************************************************************)
-(* $Id: unix.ml,v 1.41.2.1 2004/06/22 17:18:50 remy Exp $ *)
+(* $Id: unix.ml,v 1.43 2004/11/30 17:06:19 xleroy Exp $ *)
(* Initialization *)
shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND
let establish_server server_fun sockaddr =
- invalid_arg "Unix.establish_server not implmented"
+ invalid_arg "Unix.establish_server not implemented"
(* Terminal interface *)
/* */
/***********************************************************************/
-/* $Id: unixsupport.c,v 1.19 2004/04/01 13:12:36 xleroy Exp $ */
+/* $Id: unixsupport.c,v 1.20 2005/09/22 14:21:50 xleroy Exp $ */
#include <stddef.h>
#include <mlvalues.h>
return h1 == h2 ? 0 : h1 < h2 ? -1 : 1;
}
-static long win_handle_hash(value v)
+static intnat win_handle_hash(value v)
{
- return (long) Handle_val(v);
+ return (intnat) Handle_val(v);
}
static struct custom_operations win_handle_ops = {
/* Mapping of Windows error codes to POSIX error codes */
-struct error_entry { unsigned long win_code; int range; int posix_code; };
+struct error_entry { DWORD win_code; int range; int posix_code; };
static struct error_entry win_error_table[] = {
{ ERROR_INVALID_FUNCTION, 0, EINVAL},
{ 0, -1, 0 }
};
-void win32_maperr(unsigned long errcode)
+void win32_maperr(DWORD errcode)
{
int i;
/* */
/***********************************************************************/
-/* $Id: unixsupport.h,v 1.15 2003/01/06 14:52:57 xleroy Exp $ */
+/* $Id: unixsupport.h,v 1.16 2005/09/22 14:21:50 xleroy Exp $ */
#define WIN32_LEAN_AND_MEAN
#include <wtypes.h>
#define NO_CRT_FD (-1)
#define Nothing ((value) 0)
-extern void win32_maperr(unsigned long errcode);
+extern void win32_maperr(DWORD errcode);
extern void unix_error (int errcode, char * cmdname, value arg);
extern void uerror (char * cmdname, value arg);
extern value unix_freeze_buffer (value);
/* */
/***********************************************************************/
-/* $Id: winwait.c,v 1.14 2002/06/07 09:49:41 xleroy Exp $ */
+/* $Id: winwait.c,v 1.15 2005/09/22 14:21:50 xleroy Exp $ */
#include <windows.h>
#include <mlvalues.h>
Field(st, 0) = Val_int(status);
Begin_root (st);
res = alloc_small(2, 0);
- Field(res, 0) = Val_long((long) pid);
+ Field(res, 0) = Val_long((intnat) pid);
Field(res, 1) = st;
End_roots();
return res;
/* */
/***********************************************************************/
-/* $Id: write.c,v 1.7.6.2 2004/07/08 08:40:55 xleroy Exp $ */
+/* $Id: write.c,v 1.9 2005/09/22 14:21:50 xleroy Exp $ */
#include <errno.h>
#include <string.h>
CAMLprim value unix_write(value fd, value buf, value vofs, value vlen)
{
- long ofs, len, written;
+ intnat ofs, len, written;
DWORD numbytes, numwritten;
char iobuf[UNIX_BUFFER_SIZE];
CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen)
{
- long ofs, len, written;
+ intnat ofs, len, written;
DWORD numbytes, numwritten;
char iobuf[UNIX_BUFFER_SIZE];
(* *)
(***********************************************************************)
-(* $Id: lexer.mll,v 1.69 2004/01/16 15:24:02 doligez Exp $ *)
+(* $Id: lexer.mll,v 1.73 2005/04/11 16:44:26 doligez Exp $ *)
(* The lexer definition *)
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
if (c < 0 || c > 255) && not (in_comment ())
then raise (Error(Illegal_escape (Lexing.lexeme lexbuf),
Location.curr lexbuf))
let blank = [' ' '\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 =
['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
let int_literal =
decimal_literal | hex_literal | oct_literal | bin_literal
let float_literal =
- ['0'-'9'] ['0'-'9' '_']*
+ ['0'-'9'] ['0'-'9' '_']*
('.' ['0'-'9' '_']* )?
(['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)?
| int_literal "n"
{ let s = Lexing.lexeme lexbuf in
try
- NATIVEINT
+ NATIVEINT
(Nativeint.of_string(String.sub s 0 (String.length s - 1)))
with Failure _ ->
raise (Error(Literal_overflow "nativeint", Location.curr lexbuf)) }
CHAR (Lexing.lexeme_char lexbuf 1) }
| "'" [^ '\\' '\'' '\010' '\013'] "'"
{ CHAR(Lexing.lexeme_char lexbuf 1) }
- | "'\\" ['\\' '\'' '"' 'n' 't' 'b' 'r'] "'"
+ | "'\\" ['\\' '\'' '"' 'n' 't' 'b' 'r' ' '] "'"
{ CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) }
| "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
{ CHAR(char_for_decimal_code lexbuf 2) }
token lexbuf }
| "(*)"
{ let loc = Location.curr lexbuf in
- Location.prerr_warning loc (Warnings.Comment "the start of a comment");
+ Location.prerr_warning loc Warnings.Comment_start;
comment_start_loc := [Location.curr lexbuf];
comment lexbuf;
token lexbuf
}
| "*)"
{ let loc = Location.curr lexbuf in
- let warn = Warnings.Comment "not the end of a comment" in
- Location.prerr_warning loc warn;
+ Location.prerr_warning loc Warnings.Comment_not_end;
lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
let curpos = lexbuf.lex_curr_p in
lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 };
}
| "'" [^ '\\' '\'' '\010' '\013' ] "'"
{ comment lexbuf }
- | "'\\" ['\\' '"' '\'' 'n' 't' 'b' 'r'] "'"
+ | "'\\" ['\\' '"' '\'' 'n' 't' 'b' 'r' ' '] "'"
{ comment lexbuf }
| "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'"
{ comment lexbuf }
{ update_loc lexbuf None 1 false (String.length space);
string lexbuf
}
- | '\\' ['\\' '\'' '"' 'n' 't' 'b' 'r']
+ | '\\' ['\\' '\'' '"' 'n' 't' 'b' 'r' ' ']
{ store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1));
string lexbuf }
| '\\' ['0'-'9'] ['0'-'9'] ['0'-'9']
Location.curr lexbuf))
*)
let loc = Location.curr lexbuf in
- let warn = Warnings.Other "Illegal backslash escape in string" in
- Location.prerr_warning loc warn;
+ Location.prerr_warning loc Warnings.Illegal_backslash;
store_string_char (Lexing.lexeme_char lexbuf 0);
store_string_char (Lexing.lexeme_char lexbuf 1);
string lexbuf
(* *)
(***********************************************************************)
-(* $Id: location.ml,v 1.44.6.1 2005/01/12 17:01:58 doligez Exp $ *)
+(* $Id: location.ml,v 1.48 2005/03/24 17:20:54 doligez Exp $ *)
open Lexing
num_loc_lines := !num_loc_lines + n
in
fprintf ppf "%a" print loc;
- fprintf ppf "Warning: %a@." printw w;
+ fprintf ppf "Warning %a@." printw w;
pp_print_flush ppf ();
incr num_loc_lines;
end
(* *)
(***********************************************************************)
-(* $Id: location.mli,v 1.15.10.1 2005/01/12 17:01:58 doligez Exp $ *)
+(* $Id: location.mli,v 1.16 2005/03/24 17:20:54 doligez Exp $ *)
(* Source code locations (ranges of positions), used in parsetree. *)
/* */
/***********************************************************************/
-/* $Id: parser.mly,v 1.120 2004/05/19 12:15:19 doligez Exp $ */
+/* $Id: parser.mly,v 1.123 2005/03/23 03:08:37 garrigue Exp $ */
/* The parser definition */
{ mkexp(Pexp_construct(Lident "::",
Some(ghexp(Pexp_tuple[$1;$3])),
false)) }
+ | LPAREN COLONCOLON RPAREN LPAREN expr COMMA expr RPAREN
+ { mkexp(Pexp_construct(Lident "::",
+ Some(ghexp(Pexp_tuple[$5;$7])),
+ false)) }
| expr INFIXOP0 expr
{ mkinfix $1 $2 $3 }
| expr INFIXOP1 expr
| pattern COLONCOLON pattern
{ mkpat(Ppat_construct(Lident "::", Some(ghpat(Ppat_tuple[$1;$3])),
false)) }
+ | LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern RPAREN
+ { mkpat(Ppat_construct(Lident "::", Some(ghpat(Ppat_tuple[$5;$7])),
+ false)) }
| pattern BAR pattern
{ mkpat(Ppat_or($1, $3)) }
;
{ (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) }
+ | EQUAL PRIVATE core_type
+ { (Ptype_private, Some $3) }
;
type_parameters:
/*empty*/ { [] }
| constructor_declarations BAR constructor_declaration { $3 :: $1 }
;
constructor_declaration:
- constr_ident constructor_arguments { ($1, $2) }
+ constr_ident constructor_arguments { ($1, $2, symbol_rloc()) }
;
constructor_arguments:
/*empty*/ { [] }
| label_declarations SEMI label_declaration { $3 :: $1 }
;
label_declaration:
- mutable_flag label COLON poly_type { ($2, $1, $4) }
+ mutable_flag label COLON poly_type { ($2, $1, $4, symbol_rloc()) }
;
/* "with" constraints (additional type equations over signature components) */
| with_constraints AND with_constraint { $3 :: $1 }
;
with_constraint:
- TYPE type_parameters label_longident EQUAL core_type constraints
+ TYPE type_parameters label_longident with_type_binder core_type constraints
{ let params, variance = List.split $2 in
($3, Pwith_type {ptype_params = params;
ptype_cstrs = List.rev $6;
- ptype_kind = Ptype_abstract;
+ ptype_kind = $4;
ptype_manifest = Some $5;
ptype_variance = variance;
ptype_loc = symbol_rloc()}) }
| MODULE mod_longident EQUAL mod_ext_longident
{ ($2, Pwith_module $4) }
;
+with_type_binder:
+ EQUAL { Ptype_abstract }
+ | EQUAL PRIVATE { Ptype_private }
+;
/* Polymorphic types */
/* | LBRACKET RBRACKET { "[]" } */
| LPAREN RPAREN { "()" }
| COLONCOLON { "::" }
+/* | LPAREN COLONCOLON RPAREN { "::" } */
| FALSE { "false" }
| TRUE { "true" }
;
(* *)
(***********************************************************************)
-(* $Id: parsetree.mli,v 1.40 2003/11/25 08:46:45 garrigue Exp $ *)
+(* $Id: parsetree.mli,v 1.42 2005/03/23 03:08:37 garrigue Exp $ *)
(* Abstract syntax tree produced by parsing *)
and type_kind =
Ptype_abstract
- | Ptype_variant of (string * core_type list) list * private_flag
- | Ptype_record of (string * mutable_flag * core_type) list * private_flag
+ | Ptype_variant of (string * core_type list * Location.t) list * private_flag
+ | Ptype_record of
+ (string * mutable_flag * core_type * Location.t) list * private_flag
+ | Ptype_private
and exception_declaration = core_type list
(* *)
(***********************************************************************)
-(* $Id: printast.ml,v 1.26 2003/11/25 08:46:45 garrigue Exp $ *)
+(* $Id: printast.ml,v 1.28 2005/03/23 03:08:37 garrigue Exp $ *)
open Asttypes;;
open Format;;
line i ppf "Ptype_abstract\n"
| Ptype_variant (l, priv) ->
line i ppf "Ptype_variant %a\n" fmt_private_flag priv;
- list (i+1) string_x_core_type_list ppf l;
+ 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;
- list (i+1) string_x_mutable_flag_x_core_type ppf l;
+ 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
core_type (i+1) ppf ct1;
core_type (i+1) ppf ct2;
-and string_x_core_type_list i ppf (s, l) =
+and string_x_core_type_list_x_location i ppf (s, l, loc) =
string i ppf s;
list (i+1) core_type ppf l;
-and string_x_mutable_flag_x_core_type i ppf (s, mf, ct) =
+and string_x_mutable_flag_x_core_type_x_location i ppf (s, mf, ct, loc) =
line i ppf "\"%s\" %a\n" s fmt_mutable_flag mf;
core_type (i+1) ppf ct;
+camlinternalMod.cmi: obj.cmi
camlinternalOO.cmi: obj.cmi
format.cmi: buffer.cmi
genlex.cmi: stream.cmi
buffer.cmx: sys.cmx string.cmx buffer.cmi
callback.cmo: obj.cmi callback.cmi
callback.cmx: obj.cmx callback.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 \
array.cmi camlinternalOO.cmi
camlinternalOO.cmx: sys.cmx string.cmx obj.cmx map.cmx list.cmx char.cmx \
# #
#########################################################################
-# $Id: Compflags,v 1.1.4.1 2004/07/08 07:43:13 xleroy Exp $
+# $Id: Compflags,v 1.5 2004/11/25 00:04:15 doligez Exp $
case $1 in
pervasives.cm[iox]|pervasives.p.cmx) echo ' -nopervasives';;
camlinternalOO.cmi) echo ' -nopervasives';;
camlinternalOO.cmx|camlinternalOO.p.cmx) echo ' -inline 0';;
+ scanf.cmx|scanf.p.cmx) echo ' -inline 9';;
arrayLabels.cm[ox]|arrayLabels.p.cmx) echo ' -nolabels';;
listLabels.cm[ox]|listLabels.p.cmx) echo ' -nolabels';;
stringLabels.cm[ox]|stringLabels.p.cmx) echo ' -nolabels';;
# #
#########################################################################
-# $Id: Makefile,v 1.81 2004/06/14 12:23:21 xleroy Exp $
+# $Id: Makefile,v 1.85 2004/11/29 14:53:30 doligez Exp $
include ../config/Makefile
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 \
+ 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
# #
#########################################################################
-# $Id: Makefile.nt,v 1.35.2.1 2005/02/02 15:41:59 xleroy Exp $
+# $Id: Makefile.nt,v 1.37 2005/02/03 10:03:03 xleroy Exp $
include ../config/Makefile
# This file lists all standard library modules. -*- Makefile -*-
# It is used in particular to know what to expunge in toplevels.
-# $Id: StdlibModules,v 1.2 2003/11/26 10:57:14 starynke Exp $
+# $Id: StdlibModules,v 1.3 2004/08/12 12:57:00 xleroy Exp $
STDLIB_MODULES=\
arg \
arrayLabels \
buffer \
callback \
+ camlinternalMod \
camlinternalOO \
char \
complex \
(* *)
(***********************************************************************)
-(* $Id: arg.ml,v 1.33.2.1 2004/07/02 09:01:16 doligez Exp $ *)
+(* $Id: arg.ml,v 1.35 2004/11/25 00:04:15 doligez Exp $ *)
type key = string
type doc = string
(* *)
(***********************************************************************)
-(* $Id: arg.mli,v 1.35 2004/06/11 23:45:46 doligez Exp $ *)
+(* $Id: arg.mli,v 1.36 2005/10/25 18:34:07 doligez Exp $ *)
(** Parsing of command line arguments.
| Symbol of string list * (string -> unit)
(** Take one of the symbols as argument and
call the function with the symbol *)
- | Rest of (string -> unit) (** Stop interpreting keywords and call the
+ | Rest of (string -> unit) (** Stop interpreting keywords and call the
function with each remaining argument *)
(** The concrete type describing the behavior associated
with a keyword. *)
(* *)
(***********************************************************************)
-(* $Id: array.ml,v 1.23 2003/12/31 14:20:39 doligez Exp $ *)
+(* $Id: array.ml,v 1.24 2005/04/11 16:43:19 doligez Exp $ *)
(* Array operations *)
for i = 1 to pred l do
unsafe_set res i (f i)
done;
- res
+ res
let make_matrix sx sy init =
let res = create sx [||] in
let l1 = length a1 and l2 = length a2 in
if l1 = 0 && l2 = 0 then [||] else begin
let r = create (l1 + l2) (unsafe_get (if l1 > 0 then a1 else a2) 0) in
- for i = 0 to l1 - 1 do unsafe_set r i (unsafe_get a1 i) done;
- for i = 0 to l2 - 1 do unsafe_set r (i + l1) (unsafe_get a2 i) done;
+ for i = 0 to l1 - 1 do unsafe_set r i (unsafe_get a1 i) done;
+ for i = 0 to l2 - 1 do unsafe_set r (i + l1) (unsafe_get a2 i) done;
r
end
let res = create (size 0 al) init in
let rec fill pos = function
| [] -> ()
- | h::t ->
+ | h::t ->
for i = 0 to length h - 1 do
unsafe_set res (pos + i) (unsafe_get h i);
done;
(* *)
(***********************************************************************)
-(* $Id: array.mli,v 1.38.6.1 2005/07/08 15:17:39 doligez Exp $ *)
+(* $Id: array.mli,v 1.40 2005/10/25 18:34:07 doligez Exp $ *)
(** Array operations. *)
(** [Array.get a n] returns the element number [n] of array [a].
The first element has number 0.
The last element has number [Array.length a - 1].
- You can also write [a.(n)] instead of [Array.get a n].
+ You can also write [a.(n)] instead of [Array.get a n].
Raise [Invalid_argument "index out of bounds"]
if [n] is outside the range 0 to [(Array.length a - 1)]. *)
(* *)
(***********************************************************************)
-(* $Id: arrayLabels.mli,v 1.10 2003/12/31 14:20:39 doligez Exp $ *)
+(* $Id: arrayLabels.mli,v 1.11 2005/10/25 18:34:07 doligez Exp $ *)
(** Array operations. *)
size is only [Sys.max_array_length / 2]. *)
val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array
-(** @deprecated [Array.create_matrix] is an alias for {!ArrayLabels.make_matrix}. *)
+(** @deprecated [Array.create_matrix] is an alias for
+ {!ArrayLabels.make_matrix}. *)
val append : 'a array -> 'a array -> 'a array
(** [Array.append v1 v2] returns a fresh array containing the
[Array.sort] is guaranteed to run in constant heap space
and logarithmic stack space.
-
+
The current implementation uses Heap Sort. It runs in constant
stack space.
*)
(* *)
(***********************************************************************)
-(* $Id: buffer.ml,v 1.17 2004/06/14 20:20:16 weis Exp $ *)
+(* $Id: buffer.ml,v 1.18 2005/10/25 18:34:07 doligez Exp $ *)
(* Extensible buffers *)
let contents b = String.sub b.buffer 0 b.position
let sub b ofs len =
- if ofs < 0 || len < 0 || ofs > b.position - len
+ if ofs < 0 || len < 0 || ofs > b.position - len
then invalid_arg "Buffer.sub"
else begin
let r = String.create len in
end
;;
-let nth b ofs =
- if ofs < 0 || ofs >= b.position then
+let nth b ofs =
+ if ofs < 0 || ofs >= b.position then
invalid_arg "Buffer.nth"
else String.get b.buffer ofs
;;
if new_position > b.length then resize b len;
String.blit s 0 b.buffer b.position len;
b.position <- new_position
-
+
let add_buffer b bs =
add_substring b bs.buffer 0 bs.position
if i >= lim then lim else
match s.[i] with
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' |
- 'é'|'à'|'á'|'è'|'ù'|'â'|'ê'|'î'|'ô'|'û'|'ë'|'ï'|'ü'|'ç'|
- 'É'|'À'|'Á'|'È'|'Ù'|'Â'|'Ê'|'Î'|'Ô'|'Û'|'Ë'|'Ï'|'Ü'|'Ç' ->
+ 'é'|'à'|'á'|'è'|'ù'|'â'|'ê'|
+ 'î'|'ô'|'û'|'ë'|'ï'|'ü'|'ç'|
+ 'É'|'À'|'Á'|'È'|'Ù'|'Â'|'Ê'|
+ 'Î'|'Ô'|'Û'|'Ë'|'Ï'|'Ü'|'Ç' ->
advance (i + 1) lim
| _ -> i in
advance start (String.length s);;
(* *)
(***********************************************************************)
-(* $Id: buffer.mli,v 1.20 2004/04/17 13:36:03 guesdon Exp $ *)
+(* $Id: buffer.mli,v 1.21 2005/10/25 18:34:07 doligez Exp $ *)
(** Extensible string buffers.
This module implements string buffers that automatically expand
as necessary. It provides accumulative concatenation of strings
in quasi-linear time (instead of quadratic time when strings are
- concatenated pairwise).
+ concatenated pairwise).
*)
type t
val output_buffer : out_channel -> t -> unit
(** [output_buffer oc b] writes the current contents of buffer [b]
on the output channel [oc]. *)
-
(* *)
(***********************************************************************)
-(* $Id: callback.mli,v 1.5 2001/12/07 13:40:50 xleroy Exp $ *)
+(* $Id: callback.mli,v 1.6 2005/10/25 18:34:07 doligez Exp $ *)
(** Registering Caml values with the C runtime.
This module allows Caml values to be registered with the C runtime
under a symbolic name, so that C code can later call back registered
- Caml functions, or raise registered Caml exceptions.
+ Caml functions, or raise registered Caml exceptions.
*)
val register : string -> 'a -> unit
--- /dev/null
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2004 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU Library General Public License, with *)
+(* the special exception on linking described in file ../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+(* $Id: camlinternalMod.ml,v 1.4 2005/10/25 18:34:07 doligez Exp $ *)
+
+type shape =
+ | Function
+ | Lazy
+ | Class
+ | Module of shape array
+
+let rec init_mod loc shape =
+ match shape with
+ | Function ->
+ let pad1 = 1 and pad2 = 2 and pad3 = 3 and pad4 = 4
+ and pad5 = 5 and pad6 = 6 and pad7 = 7 and pad8 = 8 in
+ Obj.repr(fun _ ->
+ ignore pad1; ignore pad2; ignore pad3; ignore pad4;
+ ignore pad5; ignore pad6; ignore pad7; ignore pad8;
+ raise (Undefined_recursive_module loc))
+ | Lazy ->
+ Obj.repr (lazy (raise (Undefined_recursive_module loc)))
+ | Class ->
+ Obj.repr (CamlinternalOO.dummy_class loc)
+ | Module comps ->
+ Obj.repr (Array.map (init_mod loc) comps)
+
+let overwrite o n =
+ assert (Obj.size o >= Obj.size n);
+ for i = 0 to Obj.size n - 1 do
+ Obj.set_field o i (Obj.field n i)
+ done
+
+let rec update_mod shape o n =
+ match shape with
+ | Function ->
+ if Obj.tag n = Obj.closure_tag && Obj.size n <= Obj.size o
+ then overwrite o n
+ else overwrite o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x))
+ | Lazy ->
+ assert (Obj.tag n = Obj.lazy_tag);
+ overwrite o n
+ | Class ->
+ assert (Obj.tag n = 0 && Obj.size n = 4);
+ overwrite o n
+ | Module comps ->
+ assert (Obj.tag n = 0 && Obj.size n >= Array.length comps);
+ for i = 0 to Array.length comps - 1 do
+ update_mod comps.(i) (Obj.field o i) (Obj.field n i)
+ done
--- /dev/null
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2004 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU Library General Public License, with *)
+(* the special exception on linking described in file ../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+(* $Id: camlinternalMod.mli,v 1.1 2004/08/12 12:57:00 xleroy Exp $ *)
+
+type shape =
+ | Function
+ | Lazy
+ | Class
+ | Module of shape array
+
+val init_mod: string * int * int -> shape -> Obj.t
+val update_mod: shape -> Obj.t -> Obj.t -> unit
(* *)
(***********************************************************************)
-(* $Id: camlinternalOO.ml,v 1.9 2004/05/26 11:10:51 garrigue Exp $ *)
+(* $Id: camlinternalOO.ml,v 1.14 2005/10/25 18:34:07 doligez Exp $ *)
open Obj
mutable clean_when_copying : bool;
mutable retry_count : int;
mutable bucket_small_size : int
- }
+ }
let params = {
compact_table = true;
clean_when_copying = true;
retry_count = 3;
bucket_small_size = 16
-}
+}
(**** Parameters ****)
let table_count = ref 0
-let null_item : item = Obj.obj (Obj.field (Obj.repr 0n) 1)
+(* dummy_met should be a pointer, so use an atom *)
+let dummy_met : item = obj (Obj.new_block 0 0)
+(* if debugging is needed, this could be a good idea: *)
+(* let dummy_met () = failwith "Undefined method" *)
let rec fit_size n =
if n <= 2 then n else
let new_table pub_labels =
incr table_count;
let len = Array.length pub_labels in
- let methods = Array.create (len*2+2) null_item in
+ let methods = Array.create (len*2+2) dummy_met in
methods.(0) <- magic len;
methods.(1) <- magic (fit_size len * Sys.word_size / 8 - 1);
for i = 0 to len - 1 do methods.(i*2+3) <- magic pub_labels.(i) done;
let resize array new_size =
let old_size = Array.length array.methods in
if new_size > old_size then begin
- let new_buck = Array.create new_size null_item in
+ let new_buck = Array.create new_size dummy_met in
Array.blit array.methods 0 new_buck 0 old_size;
array.methods <- new_buck
end
table.vars <- Vars.add name index table.vars;
index
-let new_variables table names =
- let index = new_variable table names.(0) in
- for i = 1 to Array.length names - 1 do
- ignore (new_variable table names.(i))
+let to_array arr =
+ if arr = Obj.magic 0 then [||] else arr
+
+let new_methods_variables table meths vals =
+ let meths = to_array meths in
+ let nmeths = Array.length meths and nvals = Array.length vals in
+ let index = new_variable table vals.(0) in
+ let res = Array.create (nmeths + 1) index in
+ for i = 1 to nvals - 1 do ignore (new_variable table vals.(i)) done;
+ for i = 0 to nmeths - 1 do
+ res.(i+1) <- get_method_label table meths.(i)
done;
- index
+ res
let get_variable table name =
Vars.find name table.vars
let init =
if top then super cla env else Obj.repr (super cla) in
widen cla;
- init
+ (init, Array.map (get_variable cla) (to_array vals),
+ Array.map (fun nm -> get_method cla (get_method_label cla nm))
+ (to_array concr_meths))
let make_class pub_meths class_init =
let table = create_table pub_meths in
init_table.class_init <- class_init;
init_table.env_init <- env_init
+let dummy_class loc =
+ let undef = fun _ -> raise (Undefined_recursive_module loc) in
+ (Obj.magic undef, undef, undef, Obj.repr 0)
+
(**** Objects ****)
let create_object table =
let app_env_const f e n x =
ret (fun obj ->
f (Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) n) x)
-let meth_app_const n x = ret (fun obj -> (sendself obj n) x)
+let meth_app_const n x = ret (fun obj -> (sendself obj n : _ -> _) x)
let meth_app_var n m =
- ret (fun obj -> (sendself obj n) (Array.unsafe_get obj m))
+ ret (fun obj -> (sendself obj n : _ -> _) (Array.unsafe_get obj m))
let meth_app_env n e m =
- ret (fun obj -> (sendself obj n)
+ ret (fun obj -> (sendself obj n : _ -> _)
(Array.unsafe_get (Obj.magic (Array.unsafe_get obj e) : obj) m))
let meth_app_meth n m =
- ret (fun obj -> (sendself obj n) (sendself obj m))
+ ret (fun obj -> (sendself obj n : _ -> _) (sendself obj m))
let send_const m x c =
ret (fun obj -> sendcache x m (Array.unsafe_get obj 0) c)
let send_var m n c =
(* *)
(***********************************************************************)
-(* $Id: camlinternalOO.mli,v 1.6 2004/05/26 11:10:51 garrigue Exp $ *)
+(* $Id: camlinternalOO.mli,v 1.9 2005/10/25 18:34:07 doligez Exp $ *)
(** Run-time support for objects and classes.
All functions in this module are for system use only, not for the
val public_method_label : string -> tag
val new_method : table -> label
val new_variable : table -> string -> int
-val new_variables : table -> string array -> int
+val new_methods_variables :
+ table -> string array -> string array -> label array
val get_variable : table -> string -> int
val get_variables : table -> string array -> int array
val get_method_label : table -> string -> label
val init_class : table -> unit
val inherits :
table -> string array -> string array -> string array ->
- (t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t
+ (t * (table -> obj -> Obj.t) * t * obj) -> bool ->
+ (Obj.t * int array * closure array)
val make_class :
string array -> (table -> Obj.t -> t) ->
(t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
type init_table
val make_class_store :
string array -> (table -> t) -> init_table -> unit
+val dummy_class :
+ string * int * int ->
+ (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
(** {6 Objects} *)
(** {6 Statistics} *)
type stats =
- { classes : int;
- methods : int;
+ { classes : int;
+ methods : int;
inst_vars : int }
val stats : unit -> stats
(* *)
(***********************************************************************)
-(* $Id: char.ml,v 1.12 2003/12/16 18:09:43 doligez Exp $ *)
+(* $Id: char.ml,v 1.13 2005/05/19 15:30:35 habouzit Exp $ *)
(* Character operations *)
external unsafe_chr: int -> char = "%identity"
let chr n =
- if n < 0 or n > 255 then invalid_arg "Char.chr" else unsafe_chr n
+ if n < 0 || n > 255 then invalid_arg "Char.chr" else unsafe_chr n
external is_printable: char -> bool = "caml_is_printable"
(* *)
(***********************************************************************)
-(* $Id: char.mli,v 1.16 2002/06/26 09:13:58 xleroy Exp $ *)
+(* $Id: char.mli,v 1.17 2005/10/25 18:34:07 doligez Exp $ *)
(** Character operations. *)
external code : char -> int = "%identity"
(** Return the ASCII code of the argument. *)
-
+
val chr : int -> char
(** Return the character with the given ASCII code.
Raise [Invalid_argument "Char.chr"] if the argument is
(* *)
(***********************************************************************)
-(* $Id: complex.ml,v 1.5 2002/04/18 07:27:42 garrigue Exp $ *)
+(* $Id: complex.ml,v 1.6 2005/10/25 18:34:07 doligez Exp $ *)
(* Complex numbers *)
let polar n a = { re = cos a *. n; im = sin a *. n }
-let sqrt x =
+let sqrt x =
if x.re = 0.0 && x.im = 0.0 then { re = 0.0; im = 0.0 }
else begin
let r = abs_float x.re and i = abs_float x.im in
let w =
if r >= i then begin
- let q = i /. r in
- sqrt(r) *. sqrt(0.5 *. (1.0 +. sqrt(1.0 +. q *. q)))
+ let q = i /. r in
+ sqrt(r) *. sqrt(0.5 *. (1.0 +. sqrt(1.0 +. q *. q)))
end else begin
let q = r /. i in
sqrt(i) *. sqrt(0.5 *. (q +. sqrt(1.0 +. q *. q)))
- end in
+ end in
if x.re >= 0.0
- then { re = w; im = 0.5 *. x.im /. w }
+ then { re = w; im = 0.5 *. x.im /. w }
else { re = 0.5 *. i /. w; im = if x.im >= 0.0 then w else -. w }
end
(* *)
(***********************************************************************)
-(* $Id: complex.mli,v 1.3 2002/04/18 07:27:42 garrigue Exp $ *)
+(* $Id: complex.mli,v 1.4 2005/10/25 18:34:07 doligez Exp $ *)
(** Complex numbers.
negative real axis. *)
val polar: float -> float -> t
-(** [polar norm arg] returns the complex having norm [norm]
+(** [polar norm arg] returns the complex having norm [norm]
and argument [arg]. *)
val exp: t -> t
(* *)
(***********************************************************************)
-(* $Id: digest.mli,v 1.16 2003/12/31 14:20:39 doligez Exp $ *)
+(* $Id: digest.mli,v 1.17 2005/10/25 18:34:07 doligez Exp $ *)
(** MD5 message digest.
This module provides functions to compute 128-bit ``digests'' of
arbitrary-length strings or files. The digests are of cryptographic
quality: it is very hard, given a digest, to forge a string having
- that digest. The algorithm used is MD5.
+ that digest. The algorithm used is MD5.
*)
type t = string
(* *)
(***********************************************************************)
-(* $Id: filename.ml,v 1.34.2.1 2005/01/31 17:01:02 doligez Exp $ *)
+(* $Id: filename.ml,v 1.37 2005/10/25 18:34:07 doligez Exp $ *)
let generic_quote quotequote s =
let l = String.length s in
(String.length suff) = suff
let temporary_directory =
try Sys.getenv "TMPDIR" with Not_found -> "/tmp"
- let quote = generic_quote "'\\''"
+ let quote = generic_quote "'\\''"
end
module Win32 = struct
is_relative, is_implicit, check_suffix, temporary_directory, quote) =
match Sys.os_type with
"Unix" ->
- (Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep,
+ (Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep,
Unix.is_dir_sep, Unix.rindex_dir_sep,
Unix.is_relative, Unix.is_implicit, Unix.check_suffix,
Unix.temporary_directory, Unix.quote)
| "Win32" ->
- (Win32.current_dir_name, Win32.parent_dir_name, Win32.dir_sep,
+ (Win32.current_dir_name, Win32.parent_dir_name, Win32.dir_sep,
Win32.is_dir_sep, Win32.rindex_dir_sep,
Win32.is_relative, Win32.is_implicit, Win32.check_suffix,
Win32.temporary_directory, Win32.quote)
| "Cygwin" ->
- (Cygwin.current_dir_name, Cygwin.parent_dir_name, Cygwin.dir_sep,
+ (Cygwin.current_dir_name, Cygwin.parent_dir_name, Cygwin.dir_sep,
Cygwin.is_dir_sep, Cygwin.rindex_dir_sep,
Cygwin.is_relative, Cygwin.is_implicit, Cygwin.check_suffix,
Cygwin.temporary_directory, Cygwin.quote)
let temp_file prefix suffix =
let rec try_name counter =
- if counter >= 1000 then
- invalid_arg "Filename.temp_file: temp dir nonexistent or full";
let name = temp_file_name prefix suffix in
try
close_desc(open_desc name [Open_wronly; Open_creat; Open_excl] 0o600);
name
- with Sys_error _ ->
- try_name (counter + 1)
+ with Sys_error _ as e ->
+ if counter >= 1000 then raise e else try_name (counter + 1)
in try_name 0
let open_temp_file ?(mode = [Open_text]) prefix suffix =
let rec try_name counter =
- if counter >= 1000 then
- invalid_arg "Filename.open_temp_file: temp dir nonexistent or full";
let name = temp_file_name prefix suffix in
try
(name,
open_out_gen (Open_wronly::Open_creat::Open_excl::mode) 0o600 name)
- with Sys_error _ ->
- try_name (counter + 1)
+ with Sys_error _ as e ->
+ if counter >= 1000 then raise e else try_name (counter + 1)
in try_name 0
(* *)
(***********************************************************************)
-(* $Id: filename.mli,v 1.31.2.1 2005/01/31 17:01:02 doligez Exp $ *)
+(* $Id: filename.mli,v 1.33 2005/10/25 18:34:07 doligez Exp $ *)
(** Operations on file names. *)
(** Return a quoted version of a file name, suitable for use as
one argument in a shell command line, escaping all shell
meta-characters. *)
-
(* *)
(***********************************************************************)
-(* $Id: format.ml,v 1.55.4.2 2004/07/12 23:03:16 weis Exp $ *)
+(* $Id: format.ml,v 1.65 2005/09/26 10:13:08 weis Exp $ *)
(**************************************************************
**************************************************************)
+type size;;
+
+external size_of_int : int -> size = "%identity";;
+external int_of_size : size -> int = "%identity";;
+
(* Tokens are one of the following : *)
type pp_token =
elements are tuples (size, token, length), where
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 : int; token : pp_token; length : int};;
+type pp_queue_elem = {
+ mutable elem_size : size; token : pp_token; length : int
+};;
(* Scan stack:
each element is (left_total, queue element) where left_total
(* Pp_infinity: large value for default tokens size.
Pp_infinity is documented as being greater than 1e10; to avoid
- confusion about the word ``greater'' we shoose pp_infinity greater
- than 1e10 + 1; for correct handling of tests in the algorithm
- pp_infinity must be even one more than that; let's stand on the
+ confusion about the word ``greater'', we choose pp_infinity greater
+ than 1e10 + 1; for correct handling of tests in the algorithm,
+ pp_infinity must be even one more than 1e10 + 1; let's stand on the
safe side by choosing 1.e10+10.
Pp_infinity could probably be 1073741823 that is 2^30 - 1, that is
- the minimal upper bound of integers; now that max_int is defined,
- could also be defined as max_int - 1.
-
- We must carefully double-check all the integer arithmetic
- operations that involve pp_infinity before setting pp_infinity to
- something around max_int: otherwise any overflow would wreck havoc
- the pretty-printing algorithm's invariants.
- Is it worth the burden ? *)
+ the minimal upper bound for integers; now that max_int is defined,
+ this limit could also be defined as max_int - 1.
+
+ However, before setting pp_infinity to something around max_int, we
+ must carefully double-check all the integer arithmetic operations
+ that involve pp_infinity, since any overflow would wreck havoc the
+ 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
+ burden ! *)
let pp_infinity = 1000000010;;
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 + size;;
+ state.pp_space_left <- state.pp_space_left + int_of_size size;;
(**************************************************************
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))
let enqueue_advance state tok = pp_enqueue state tok; advance_left state;;
(* To enqueue a string : try to advance. *)
-let enqueue_string_as state n s =
- enqueue_advance state {elem_size = n; token = Pp_text s; length = n};;
+let make_queue_elem size tok 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);;
-let enqueue_string state s = enqueue_string_as state (String.length s) s;;
+let enqueue_string state s =
+ let len = String.length s in
+ enqueue_string_as state (size_of_int len) s;;
(* Routines for scan stack
determine sizes of blocks. *)
(* The scan_stack is never empty. *)
let scan_stack_bottom =
- [Scan_elem (-1, {elem_size = (-1); token = Pp_text ""; length = 0})];;
+ let q_elem = make_queue_elem (size_of_int (-1)) (Pp_text "") 0 in
+ [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;
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 ->
+ | 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 <- state.pp_right_total + size;
+ 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 <- state.pp_right_total + size;
+ 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. *)
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
- (scan_push state false
- {elem_size = (- state.pp_right_total);
- token = Pp_begin (indent, br_ty); length = 0}) else
+ 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;;
begin
if state.pp_curr_depth < state.pp_max_boxes then
begin
- pp_enqueue state {elem_size = 0; token = Pp_end; length = 0};
+ 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;
state.pp_print_open_tag tag_name end;
if state.pp_mark_tags then
pp_enqueue state
- {elem_size = 0; token = Pp_open_tag tag_name; length = 0};;
+ {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 = 0; token = Pp_close_tag; length = 0};
+ 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 ->
**************************************************************)
(* To format a string. *)
-let pp_print_as state n s =
+let pp_print_as_size state size s =
if state.pp_curr_depth < state.pp_max_boxes
- then enqueue_string_as state n s;;
+ then enqueue_string_as state size s;;
-let pp_print_string state s = pp_print_as state (String.length s) s;;
+let pp_print_as state 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;;
(* To format an integer. *)
let pp_print_int state i = pp_print_string state (string_of_int i);;
(* To format a char. *)
let pp_print_char state c =
- let s = String.create 1 in s.[0] <- c; pp_print_as state 1 s;;
+ let s = String.create 1 in
+ s.[0] <- c;
+ pp_print_as state 1 s;;
(* Opening boxes. *)
let pp_open_hbox state () = pp_open_box_gen state 0 Pp_hbox
(* To get a newline when one does not want to close the current block. *)
let pp_force_newline state () =
if state.pp_curr_depth < state.pp_max_boxes then
- enqueue_advance state {elem_size = 0; token = Pp_newline; length = 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 {elem_size = 0; token = Pp_if_newline; length = 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
To do (?) : add a maximum width and offset value. *)
let pp_print_break state width offset =
if state.pp_curr_depth < state.pp_max_boxes then
- scan_push state true
- {elem_size = (- state.pp_right_total); token = Pp_break (width, offset);
- length = width};;
+ let elem =
+ make_queue_elem
+ (size_of_int (- state.pp_right_total))
+ (Pp_break (width, offset))
+ width in
+ 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;;
let pp_open_tbox state () =
state.pp_curr_depth <- state.pp_curr_depth + 1;
if state.pp_curr_depth < state.pp_max_boxes then
- enqueue_advance state
- {elem_size = 0;
- token = Pp_tbegin (Pp_tbox (ref [])); length = 0};;
+ let elem =
+ make_queue_elem (size_of_int 0) (Pp_tbegin (Pp_tbox (ref []))) 0 in
+ 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 < state.pp_max_boxes then
- enqueue_advance state {elem_size = 0; token = Pp_tend; length = 0};
- state.pp_curr_depth <- state.pp_curr_depth - 1 end;;
+ 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;;
(* Print a tabulation break. *)
let pp_print_tbreak state width offset =
if state.pp_curr_depth < state.pp_max_boxes then
- scan_push state true
- {elem_size = (- state.pp_right_total); token = Pp_tbreak (width, offset);
- length = width};;
+ let elem =
+ make_queue_elem
+ (size_of_int (- state.pp_right_total))
+ (Pp_tbreak (width, offset))
+ width in
+ scan_push state true elem;;
let pp_print_tab state () = pp_print_tbreak state 0 0;;
let pp_set_tab state () =
- if state.pp_curr_depth < state.pp_max_boxes
- then enqueue_advance state {elem_size = 0; token = Pp_stab; length=0};;
+ if state.pp_curr_depth < state.pp_max_boxes then
+ let elem =
+ make_queue_elem (size_of_int 0) Pp_stab 0 in
+ enqueue_advance state elem;;
(**************************************************************
(* The initial state of the formatter contains a dummy box. *)
let pp_q = make_queue () in
let sys_tok =
- {elem_size = (- 1); token = Pp_begin (0, Pp_hovbox); length = 0} in
+ 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
let formatter_of_out_channel oc =
make_formatter (output oc) (fun () -> flush oc);;
-let unit_out ppf = ();;
-
let formatter_of_buffer b =
- make_formatter (Buffer.add_substring b) unit_out;;
+ make_formatter (Buffer.add_substring b) ignore;;
let stdbuf = Buffer.create 512;;
then " (" ^ String.make 1 fmt.[i] ^ ")."
else String.make 1 '.');;
-(* When an invalid format deserve a special error explanation. *)
+(* When an invalid format deserves a special error explanation. *)
let format_invalid_arg mess fmt i = invalid_arg (giving_up mess fmt i);;
(* Standard invalid format. *)
(* Finding an integer out of a sub-string of the format. *)
let format_int_of_string fmt i s =
- try int_of_string s with
- | Failure s -> invalid_integer fmt i;;
+ let sz =
+ try int_of_string s with
+ | Failure s -> invalid_integer fmt i in
+ size_of_int sz;;
(* Getting strings out of buffers. *)
let get_buffer_out b =
| [] -> s0
| l -> String.concat "" (List.rev (s0 :: l));;
+external format_to_string : ('a, 'b, 'c, 'd) format4 -> string = "%identity";;
+
(* [fprintf_out] is the printf-like function generator: given the
- [str] flag that tells if we are printing into a string,
- the [out] function that has to be called at the end of formatting,
according to the format.
Regular [fprintf]-like functions of this module are obtained via partial
applications of [fprintf_out]. *)
-let fprintf_out str out ppf format =
- let format = string_of_format format in
- let limit = String.length format 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 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 ppf size s;
- print_as := None in
-
- let rec doprn i =
- if i >= limit then
- Obj.magic (out ppf)
- else
- match format.[i] with
- | '%' ->
- Printf.scan_format format i cont_s cont_a cont_t cont_f
- | '@' ->
+let mkprintf str get_out =
+ let rec kprintf k fmt =
+ let fmt = format_to_string fmt in
+ let len = String.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
+ 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
+
+ let rec doprn n i =
+ if i >= len then Obj.magic (k ppf) else
+ match fmt.[i] with
+ | '%' ->
+ Printf.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
+ | '@' ->
+ let i = succ i in
+ if i >= len then invalid_format fmt i else
+ begin match fmt.[i] with
+ | '[' ->
+ 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)
+
+ and cont_s n s i =
+ pp_print_as_string s; doprn n i
+ and cont_a n printer arg i =
+ if str then
+ pp_print_as_string ((Obj.magic printer : unit -> _ -> string) () arg)
+ else
+ printer ppf arg;
+ doprn n i
+ and cont_t n printer i =
+ if str then
+ pp_print_as_string ((Obj.magic printer : unit -> string) ())
+ else
+ printer ppf;
+ doprn n i
+ and cont_f n i =
+ pp_print_flush ppf (); doprn n i
+
+ and cont_m n sfmt i =
+ kprintf (Obj.magic (fun _ -> doprn n i)) sfmt
+
+ and get_int n i c =
+ if i >= len then invalid_integer fmt i else
+ match fmt.[i] with
+ | ' ' -> 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
+ Printf.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
+ | _ ->
+ let rec get j =
+ if j >= len then invalid_integer fmt j else
+ match fmt.[j] with
+ | '0' .. '9' | '-' -> get (succ j)
+ | _ ->
+ let size =
+ if j = i then size_of_int 0 else
+ format_int_of_string fmt j (String.sub fmt i (j - i)) in
+ c size n j in
+ get i
+
+ and skip_gt i =
+ if i >= len then invalid_format fmt i else
+ match fmt.[i] with
+ | ' ' -> skip_gt (succ i)
+ | '>' -> succ i
+ | _ -> invalid_format fmt i
+
+ and get_box_kind i =
+ if i >= len then Pp_box, i else
+ match fmt.[i] with
+ | 'h' ->
let i = succ i in
- if i >= limit then invalid_format format i else
- begin match format.[i] with
- | '[' ->
- do_pp_open_box ppf (succ i)
- | ']' ->
- pp_close_box ppf ();
- doprn (succ i)
- | '{' ->
- do_pp_open_tag ppf (succ i)
- | '}' ->
- pp_close_tag ppf ();
- doprn (succ i)
- | ' ' ->
- pp_print_space ppf ();
- doprn (succ i)
- | ',' ->
- pp_print_cut ppf ();
- doprn (succ i)
- | '?' ->
- pp_print_flush ppf ();
- doprn (succ i)
- | '.' ->
- pp_print_newline ppf ();
- doprn (succ i)
- | '\n' ->
- pp_force_newline ppf ();
- doprn (succ i)
- | ';' ->
- do_pp_break ppf (succ i)
- | '<' ->
- let got_size size i =
- print_as := Some size;
- doprn (skip_gt i) in
- get_int (succ i) got_size
- | '@' as c ->
- pp_print_as_char c;
- doprn (succ i)
- | c -> invalid_format format i
+ if i >= len then Pp_hbox, i else
+ begin match fmt.[i] with
+ | 'o' ->
+ let i = succ i in
+ if i >= len then format_invalid_arg "bad box format" fmt i else
+ begin match fmt.[i] with
+ | '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
- | c ->
- pp_print_as_char c;
- doprn (succ i)
-
- and cont_s s i =
- pp_print_as_string s; doprn i
- and cont_a printer arg i =
- if str then
- pp_print_as_string ((Obj.magic printer) () arg)
- else
- printer ppf arg;
- doprn i
- and cont_t printer i =
- if str then
- pp_print_as_string ((Obj.magic printer) ())
- else
- printer ppf;
- doprn i
- and cont_f i =
- pp_print_flush ppf (); doprn i
-
- and get_int i c =
- if i >= limit then invalid_integer format i else
- match format.[i] with
- | ' ' -> get_int (succ i) c
- | '%' ->
- let cont_s s i = c (format_int_of_string format i s) i
- and cont_a printer arg i = invalid_integer format i
- and cont_t printer i = invalid_integer format i
- and cont_f i = invalid_integer format i in
- Printf.scan_format format i cont_s cont_a cont_t cont_f
- | _ ->
- let rec get j =
- if j >= limit then invalid_integer format j else
- match format.[j] with
- | '0' .. '9' | '-' -> get (succ j)
- | _ ->
- if j = i then c 0 j else
- c (format_int_of_string format j (String.sub format i (j - i))) j in
- get i
-
- and skip_gt i =
- if i >= limit then invalid_format format i else
- match format.[i] with
- | ' ' -> skip_gt (succ i)
- | '>' -> succ i
- | _ -> invalid_format format i
-
- and get_box_kind i =
- if i >= limit then Pp_box, i else
- match format.[i] with
- | 'h' ->
- let i = succ i in
- if i >= limit then Pp_hbox, i else
- begin match format.[i] with
- | 'o' ->
- let i = succ i in
- if i >= limit then format_invalid_arg "bad box format" format i else
- begin match format.[i] with
- | 'v' -> Pp_hovbox, succ i
- | c ->
- format_invalid_arg
- ("bad box name ho" ^ String.make 1 c) format 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 i c =
- let rec get accu i j =
- if j >= limit
- then c (implode_rev (String.sub format i (j - i)) accu) j else
- match format.[j] with
- | '>' -> c (implode_rev (String.sub format i (j - i)) accu) j
- | '%' ->
- let s0 = String.sub format i (j - i) in
- let cont_s s i = get (s :: s0 :: accu) i i
- and cont_a printer arg i =
- let s =
- if str then (Obj.magic printer) () arg else exstring printer arg in
- get (s :: s0 :: accu) i i
- and cont_t printer i =
- let s =
- if str then (Obj.magic printer) ()
- else exstring (fun ppf () -> printer ppf) () in
- get (s :: s0 :: accu) i i
- and cont_f i =
- format_invalid_arg "bad tag name specification" format i in
- Printf.scan_format format j cont_s cont_a cont_t cont_f
- | c -> get accu i (succ j) in
- get [] i i
-
- and do_pp_break ppf i =
- if i >= limit then begin pp_print_space ppf (); doprn i end else
- match format.[i] with
- | '<' ->
- let rec got_nspaces nspaces i =
- get_int i (got_offset nspaces)
- and got_offset nspaces offset i =
- pp_print_break ppf nspaces offset;
- doprn (skip_gt i) in
- get_int (succ i) got_nspaces
- | c -> pp_print_space ppf (); doprn i
-
- and do_pp_open_box ppf i =
- if i >= limit then begin pp_open_box_gen ppf 0 Pp_box; doprn i end else
- match format.[i] with
- | '<' ->
- let kind, i = get_box_kind (succ i) in
- let got_size size i =
- pp_open_box_gen ppf size kind;
- doprn (skip_gt i) in
- get_int i got_size
- | c -> pp_open_box_gen ppf 0 Pp_box; doprn i
-
- and do_pp_open_tag ppf i =
- if i >= limit then begin pp_open_tag ppf ""; doprn i end else
- match format.[i] with
- | '<' ->
- let got_name tag_name i =
- pp_open_tag ppf tag_name;
- doprn (skip_gt i) in
- get_tag_name (succ i) got_name
- | c -> pp_open_tag ppf ""; doprn i in
-
- doprn 0;;
+ | '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 (String.sub fmt i (j - i)) accu) n j else
+ match fmt.[j] with
+ | '>' -> c (implode_rev (String.sub fmt i (j - i)) accu) n j
+ | '%' ->
+ let s0 = String.sub fmt i (j - i) in
+ let cont_s n s i = get (s :: s0 :: accu) n i i
+ and cont_a n printer arg i =
+ let s =
+ if str
+ then (Obj.magic printer : unit -> _ -> string) () arg
+ else exstring printer arg in
+ get (s :: s0 :: accu) n i i
+ and cont_t n printer i =
+ let s =
+ if str
+ 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
+ Printf.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m
+ | c -> get accu n i (succ j) in
+ get [] n i i
+
+ and do_pp_break ppf n i =
+ if i >= len then begin pp_print_space ppf (); doprn n i end else
+ match fmt.[i] with
+ | '<' ->
+ 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
+
+ and do_pp_open_box ppf n i =
+ if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else
+ match fmt.[i] with
+ | '<' ->
+ 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
+
+ and do_pp_open_tag ppf n i =
+ if i >= len then begin pp_open_tag ppf ""; doprn n i end else
+ match fmt.[i] with
+ | '<' ->
+ 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
+
+ doprn (Printf.index_of_int 0) 0 in
+
+ Printf.kapr kpr fmt in
+
+ kprintf;;
(**************************************************************
**************************************************************)
-let kfprintf k = fprintf_out false k;;
-let fprintf ppf = kfprintf unit_out ppf;;
-let printf f = fprintf std_formatter f;;
-let eprintf f = fprintf err_formatter f;;
+let kfprintf k ppf = mkprintf false (fun _ -> ppf) k;;
-let bprintf b =
- let ppf = formatter_of_buffer b in
- kfprintf (fun ppf -> pp_flush_queue ppf false) ppf;;
+let fprintf ppf = kfprintf ignore ppf;;
+let printf fmt = fprintf std_formatter fmt;;
+let eprintf fmt = fprintf err_formatter fmt;;
-let ksprintf k =
- let b = Buffer.create 512 in
- let ppf = formatter_of_buffer b in
- fprintf_out true (fun ppf -> k (string_out b ppf)) ppf;;
+let kbprintf k b =
+ mkprintf false (fun _ -> formatter_of_buffer b) k;;
-let sprintf f = ksprintf (fun s -> s) f;;
+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;;
let kprintf = ksprintf;;
+let sprintf fmt = ksprintf (fun s -> s) fmt;;
+
at_exit print_flush;;
(* *)
(***********************************************************************)
-(* $Id: format.mli,v 1.66.2.3 2005/07/01 08:48:05 guesdon Exp $ *)
+(* $Id: format.mli,v 1.71 2005/10/25 18:34:07 doligez Exp $ *)
(** Pretty printing.
unit -> formatter_tag_functions;;
(** Return the current tag functions of the pretty-printer. *)
-(** {6 Changing the meaning of pretty printing (indentation, line breaking, and printing material)} *)
+(** {6 Changing the meaning of pretty printing (indentation, line breaking,
+ and printing material)} *)
val set_all_formatter_output_functions :
out:(string -> int -> int -> unit) ->
passes it to the first argument. *)
val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;;
-(** A deprecated synonym for ksprintf. *)
+(** A deprecated synonym for [ksprintf]. *)
(* *)
(***********************************************************************)
-(* $Id: gc.mli,v 1.40 2004/06/14 13:27:36 doligez Exp $ *)
+(* $Id: gc.mli,v 1.42 2005/10/25 18:34:07 doligez Exp $ *)
(** Memory management control and statistics; finalised values. *)
type stat =
- { minor_words : float;
+ { minor_words : float;
(** Number of words allocated in the minor heap since
the program was started. This number is accurate in
byte-code programs, but only an approximation in programs
relevant to the byte-code runtime, as the native code runtime
uses the operating system's stack. Default: 256k. *)
}
-(** The GC parameters are given as a [control] record. *)
+(** The GC parameters are given as a [control] record. Note that
+ these parameters can also be initialised by setting the
+ OCAMLRUNPARAM environment variable. See the documentation of
+ ocamlrun. *)
external stat : unit -> stat = "caml_gc_stat"
(** Return the current values of the memory management counters in a
Instead you should write:
- [ let f = fun x -> ... ;; let v = ... in Gc.finalise f v ]
-
+
The [f] function can use all features of O'Caml, including
assignments that make the value reachable again. It can also
the exception will interrupt whatever the program was doing when
the function was called.
-
+
[finalise] will raise [Invalid_argument] if [v] is not
heap-allocated. Some examples of values that are not
heap-allocated are integers, constant constructors, booleans,
stored into arrays, so they can be finalised and collected while
another copy is still in use by the program.
-
+
The results of calling {!String.make}, {!String.create},
{!Array.make}, and {!Pervasives.ref} are guaranteed to be
heap-allocated and non-constant except when the length argument is [0].
(* *)
(***********************************************************************)
-(* $Id: genlex.mli,v 1.8 2001/12/07 13:40:51 xleroy Exp $ *)
+(* $Id: genlex.mli,v 1.9 2005/10/25 18:34:07 doligez Exp $ *)
(** A generic lexical analyzer.
This module implements a simple ``standard'' lexical analyzer, presented
as a function from character streams to token streams. It implements
roughly the lexical conventions of Caml, but is parameterized by the
- set of keywords of your language.
+ set of keywords of your language.
Example: a lexer suitable for a desk calculator is obtained by
| Float of float
| String of string
| Char of char
-
+
val make_lexer : string list -> char Stream.t -> token Stream.t
(** Construct the lexer function. The first argument is the list of
keywords. An identifier [s] is returned as [Kwd s] if [s]
[Parse_error]) otherwise. Blanks and newlines are skipped.
Comments delimited by [(*] and [*)] are skipped as well,
and can be nested. *)
-
-
(* *)
(***********************************************************************)
-(* $Id: hashtbl.ml,v 1.26 2004/03/23 12:37:19 starynke Exp $ *)
+(* $Id: hashtbl.ml,v 1.27 2005/10/25 18:34:07 doligez Exp $ *)
(* Hash tables *)
let fold = fold
let length = length
end
-
-(* eof $Id: hashtbl.ml,v 1.26 2004/03/23 12:37:19 starynke Exp $ *)
(* *)
(***********************************************************************)
-(* $Id: hashtbl.mli,v 1.35.4.2 2004/11/25 13:30:34 doligez Exp $ *)
+(* $Id: hashtbl.mli,v 1.39 2005/05/04 13:36:47 doligez Exp $ *)
(** Hash tables and hash functions.
- Hash tables are hashed association tables, with in-place modification.
+ Hash tables are hashed association tables, with in-place modification.
*)
val length : ('a, 'b) t -> int
-(** [Hashtbl.length tbl] returns the number of bindings in [tbl].
- Multiple bindings are counted multiply, so [Hashtbl.length]
- gives the number of times [Hashtbl.iter] calls it first argument. *)
+(** [Hashtbl.length tbl] returns the number of bindings in [tbl].
+ Multiple bindings are counted multiply, so [Hashtbl.length]
+ gives the number of times [Hashtbl.iter] calls its first argument. *)
(** {6 Functorial interface} *)
val hash : 'a -> int
(** [Hashtbl.hash x] associates a positive integer to any value of
any type. It is guaranteed that
- if [x = y] or [Pervasives.compare x y = 0], then [hash x = hash y].
+ if [x = y] or [Pervasives.compare x y = 0], then [hash x = hash y].
Moreover, [hash] always terminates, even on cyclic
structures. *)
value, and therefore collisions are less likely to happen.
However, hashing takes longer. The parameters [m] and [n]
govern the tradeoff between accuracy and speed. *)
-
(* *)
(***********************************************************************)
-(* $Id: int32.mli,v 1.16.6.1 2005/04/11 16:51:42 doligez Exp $ *)
+(* $Id: int32.mli,v 1.18 2005/10/25 18:34:07 doligez Exp $ *)
(** 32-bit integers.
one [%d], [%i], [%u], [%x], [%X] or [%o] conversion specification.
This function is deprecated; use {!Printf.sprintf} with a [%lx] format
instead. *)
-
(* *)
(***********************************************************************)
-(* $Id: int64.mli,v 1.17.6.1 2005/04/11 16:51:42 doligez Exp $ *)
+(* $Id: int64.mli,v 1.19 2005/10/25 18:34:07 doligez Exp $ *)
(** 64-bit integers.
[%d], [%i], [%u], [%x], [%X] or [%o] conversion specification.
This function is deprecated; use {!Printf.sprintf} with a [%Lx] format
instead. *)
-
(* *)
(***********************************************************************)
-(* $Id: lexing.ml,v 1.23 2003/12/31 14:20:39 doligez Exp $ *)
+(* $Id: lexing.ml,v 1.24 2005/10/25 18:34:07 doligez Exp $ *)
(* The run-time library for lexers generated by camllex *)
lex_base_code : string;
lex_backtrk_code : string;
lex_default_code : string;
- lex_trans_code : string;
+ lex_trans_code : string;
lex_check_code : string;
lex_code: string;}
*)
if lexbuf.lex_buffer_len + n > String.length lexbuf.lex_buffer then begin
(* There is not enough space at the end of the buffer *)
- if lexbuf.lex_buffer_len - lexbuf.lex_start_pos + n
+ if lexbuf.lex_buffer_len - lexbuf.lex_start_pos + n
<= String.length lexbuf.lex_buffer
then begin
(* But there is enough space if we reclaim the junk at the beginning
(* *)
(***********************************************************************)
-(* $Id: lexing.mli,v 1.30 2003/08/13 15:31:36 doligez Exp $ *)
+(* $Id: lexing.mli,v 1.31 2005/10/25 18:34:07 doligez Exp $ *)
(** The run-time library for lexers generated by [ocamllex]. *)
lex_base_code : string;
lex_backtrk_code : string;
lex_default_code : string;
- lex_trans_code : string;
+ lex_trans_code : string;
lex_check_code : string;
lex_code: string;}
(* *)
(***********************************************************************)
-(* $Id: list.ml,v 1.31 2004/01/01 16:42:40 doligez Exp $ *)
+(* $Id: list.ml,v 1.32 2005/10/25 18:34:07 doligez Exp $ *)
(* List operations *)
let rec remove_assoc x = function
| [] -> []
- | (a, b as pair) :: l -> if compare a x = 0 then l else pair :: remove_assoc x l
+ | (a, b as pair) :: l ->
+ if compare a x = 0 then l else pair :: remove_assoc x l
let rec remove_assq x = function
| [] -> []
(* *)
(***********************************************************************)
-(* $Id: list.mli,v 1.44.10.1 2005/06/22 13:20:30 doligez Exp $ *)
+(* $Id: list.mli,v 1.46 2005/10/25 18:34:07 doligez Exp $ *)
(** List operations.
[List.sort] is guaranteed to run in constant heap space
(in addition to the size of the result list) and logarithmic
stack space.
-
+
The current implementation uses Merge Sort. It runs in constant
heap space and logarithmic stack space.
*)
(** Same as {!List.sort}, but the sorting algorithm is guaranteed to
be stable (i.e. elements that compare equal are kept in their
original order) .
-
+
The current implementation uses Merge Sort. It runs in constant
heap space and logarithmic stack space.
*)
(* *)
(***********************************************************************)
-(* $Id: listLabels.mli,v 1.10 2003/07/25 21:40:06 doligez Exp $ *)
+(* $Id: listLabels.mli,v 1.11 2005/10/25 18:34:07 doligez Exp $ *)
(** List operations.
[List.sort] is guaranteed to run in constant heap space
(in addition to the size of the result list) and logarithmic
stack space.
-
+
The current implementation uses Merge Sort and is the same as
{!ListLabels.stable_sort}.
*)
val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list
(** Same as {!ListLabels.sort}, but the sorting algorithm is stable.
-
+
The current implementation is Merge Sort. It runs in constant
heap space and logarithmic stack space.
*)
(* *)
(***********************************************************************)
-(* $Id: map.ml,v 1.15.4.1 2005/04/27 12:35:07 doligez Exp $ *)
+(* $Id: map.ml,v 1.17 2005/08/13 20:59:37 doligez Exp $ *)
module type OrderedType =
sig
let rec add x data = function
Empty ->
Node(Empty, x, data, Empty, 1)
- | Node(l, v, d, r, h) as t ->
+ | Node(l, v, d, r, h) ->
let c = Ord.compare x v in
if c = 0 then
Node(l, x, data, r, h)
let rec remove x = function
Empty ->
Empty
- | Node(l, v, d, r, h) as t ->
+ | Node(l, v, d, r, h) ->
let c = Ord.compare x v in
if c = 0 then
merge l r
(* *)
(***********************************************************************)
-(* $Id: map.mli,v 1.32 2004/04/23 10:01:33 xleroy Exp $ *)
+(* $Id: map.mli,v 1.33 2005/10/25 18:34:07 doligez Exp $ *)
(** Association tables over ordered types.
over the keys.
All operations over maps are purely applicative (no side-effects).
The implementation uses balanced binary trees, and therefore searching
- and insertion take time logarithmic in the size of the map.
+ and insertion take time logarithmic in the size of the map.
*)
-module type OrderedType =
+module type OrderedType =
sig
type t
(** The type of the map keys. *)
module Make (Ord : OrderedType) : S with type key = Ord.t
(** Functor building an implementation of the map structure
given a totally ordered type. *)
-
(* *)
(***********************************************************************)
-(* $Id: marshal.ml,v 1.8 2004/01/01 16:42:40 doligez Exp $ *)
+(* $Id: marshal.ml,v 1.9 2005/10/25 18:34:07 doligez Exp $ *)
type extern_flags =
No_sharing
if ofs > String.length buff - (header_size + len)
then invalid_arg "Marshal.from_string"
else from_string_unsafe buff ofs
- end
+ end
(* *)
(***********************************************************************)
-(* $Id: marshal.mli,v 1.13 2004/01/01 16:42:40 doligez Exp $ *)
+(* $Id: marshal.mli,v 1.14 2005/10/25 18:34:07 doligez Exp $ *)
(** Marshaling of data structures.
and [Marshal.from_channel] must be opened in binary mode, using e.g.
[open_out_bin] or [open_in_bin]; channels opened in text mode will
cause unmarshaling errors on platforms where text channels behave
- differently than binary channels, e.g. Windows.
+ differently than binary channels, e.g. Windows.
*)
type extern_flags =
of [v] on channel [chan]. The [flags] argument is a
possibly empty list of flags that governs the marshaling
behavior with respect to sharing and functional values.
-
- If [flags] does not contain [Marshal.No_sharing], circularities
+
+ If [flags] does not contain [Marshal.No_sharing], circularities
and sharing inside the value [v] are detected and preserved
in the sequence of bytes produced. In particular, this
guarantees that marshaling always terminates. Sharing
substructures, but may cause slower marshaling and larger
byte representations if [v] actually contains sharing,
or even non-termination if [v] contains cycles.
-
+
If [flags] does not contain [Marshal.Closures],
marshaling fails when it encounters a functional value
inside [v]: only ``pure'' data structures, containing neither
in characters, of the marshaled value.
Both {!Marshal.data_size} and {!Marshal.total_size} raise [Failure]
if [buff], [ofs] does not contain a valid header.
-
+
To read the byte representation of a marshaled value into
a string buffer, the program needs to read first
{!Marshal.header_size} characters into the buffer,
val total_size : string -> int -> int
(** See {!Marshal.header_size}.*)
-
-
(* *)
(***********************************************************************)
-(* $Id: nativeint.mli,v 1.17 2004/01/01 16:42:40 doligez Exp $ *)
+(* $Id: nativeint.mli,v 1.18 2005/10/25 18:34:07 doligez Exp $ *)
(** Processor-native integers.
space than values of type [int], and arithmetic operations on
[nativeint] are generally slower than those on [int]. Use [nativeint]
only when the application requires the extra bit of precision
- over the [int] type.
+ over the [int] type.
*)
val zero : nativeint
(** Multiplication. *)
external div : nativeint -> nativeint -> nativeint = "%nativeint_div"
-(** Integer division. Raise [Division_by_zero] if the second
+(** Integer division. Raise [Division_by_zero] if the second
argument is zero. This division rounds the real quotient of
its arguments towards zero, as specified for {!Pervasives.(/)}. *)
The result of the conversion is undefined if, after truncation,
the number is outside the range
\[{!Nativeint.min_int}, {!Nativeint.max_int}\]. *)
-
+
external to_float : nativeint -> float = "caml_nativeint_to_float"
(** Convert the given native integer to a floating-point number. *)
one [%d], [%i], [%u], [%x], [%X] or [%o] conversion specification.
This function is deprecated; use {!Printf.sprintf} with a [%nx] format
instead. *)
-
(* *)
(***********************************************************************)
-(* $Id: obj.mli,v 1.27.6.1 2005/04/13 12:34:44 doligez Exp $ *)
+(* $Id: obj.mli,v 1.29 2005/10/25 18:34:07 doligez Exp $ *)
(** Operations on internal representations of values.
val marshal : t -> string
val unmarshal : string -> int -> t * int
-
(* *)
(***********************************************************************)
-(* $Id: pervasives.ml,v 1.75.6.1 2004/06/22 12:13:46 xleroy Exp $ *)
+(* $Id: pervasives.ml,v 1.79 2005/10/25 18:34:07 doligez Exp $ *)
(* type 'a option = None | Some of 'a *)
float_of_bits 0x00_10_00_00_00_00_00_00L
let epsilon_float =
float_of_bits 0x3C_B0_00_00_00_00_00_00L
-
+
type fpclass =
FP_normal
| FP_subnormal
external flush : out_channel -> unit = "caml_ml_flush"
-external out_channels_list : unit -> out_channel list
+external out_channels_list : unit -> out_channel list
= "caml_ml_out_channels_list"
-let flush_all () =
+let flush_all () =
let rec iter = function
[] -> ()
| a::l -> (try flush a with _ -> ()); iter l
external input_char : in_channel -> char = "caml_ml_input_char"
-external unsafe_input : in_channel -> string -> int -> int -> int
+external unsafe_input : in_channel -> string -> int -> int -> int
= "caml_ml_input"
let input ic s ofs len =
ignore (input_char chan); (* skip the newline *)
match accu with
[] -> res
- | _ -> let len = len + n - 1 in
+ | _ -> let len = len + n - 1 in
build_result (string_create len) len (res :: accu)
end else begin (* n < 0: newline not found *)
let beg = string_create (-n) in
type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
external format_of_string :
('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 = "%identity"
-external string_of_format_sys :
+external format_to_string :
('a, 'b, 'c, 'd) format4 -> string = "%identity"
external string_to_format : string -> ('a, 'b, 'c, 'd) format4 = "%identity"
let (( ^^ ) : ('a, 'b, 'c, 'd) format4 -> ('d, 'b, 'c, 'e) format4 ->
('a, 'b, 'c, 'e) format4) = fun fmt1 fmt2 ->
- string_to_format (string_of_format_sys fmt1 ^ string_of_format_sys fmt2);;
+ string_to_format (format_to_string fmt1 ^ format_to_string fmt2);;
-let string_of_format f =
- let s = string_of_format_sys f in
+let string_of_format fmt =
+ let s = format_to_string fmt in
let l = string_length s in
let r = string_create l in
string_blit s 0 r 0 l;
(* *)
(***********************************************************************)
-(* $Id: pervasives.mli,v 1.99.2.3 2005/01/31 12:47:53 doligez Exp $ *)
+(* $Id: pervasives.mli,v 1.104 2005/10/25 18:34:07 doligez Exp $ *)
(** The initially opened module.
external raise : exn -> 'a = "%raise"
(** Raise the given exception value *)
-
+
val invalid_arg : string -> 'a
(** Raise exception [Invalid_argument] with the given string. *)
(** [n asr m] shifts [n] to the right by [m] bits.
This is an arithmetic shift: the sign bit of [n] is replicated.
The result is unspecified if [m < 0] or [m >= bitsize]. *)
-
+
(** {6 Floating-point arithmetic}
[neg_infinity] for [-1.0 /. 0.0], and [nan] (``not a number'')
for [0.0 /. 0.0]. These special numbers then propagate through
floating-point computations as expected: for instance,
- [1.0 /. infinity] is [0.0], and any operation with [nan] as
- argument returns [nan] as result.
+ [1.0 /. infinity] is [0.0], and any operation with [nan] as
+ argument returns [nan] as result.
*)
external ( ~-. ) : float -> float = "%negfloat"
(** {6 List operations}
- More list operations are provided in module {!List}.
+ More list operations are provided in module {!List}.
*)
val ( @ ) : 'a list -> 'a list -> 'a list
| Open_binary (** open in binary mode (no conversion). *)
| Open_text (** open in text mode (may perform conversions). *)
| Open_nonblock (** open in non-blocking mode. *)
-(** Opening modes for {!Pervasives.open_out_gen} and {!Pervasives.open_in_gen}. *)
-
+(** Opening modes for {!Pervasives.open_out_gen} and
+ {!Pervasives.open_in_gen}. *)
+
val open_out : string -> out_channel
(** Open the named file for writing, and return a new output channel
on that file, positionned at the beginning of the file. The
mode, this function behaves like {!Pervasives.open_out}. *)
val open_out_gen : open_flag list -> int -> string -> out_channel
-(** Open the named file for writing, as above. The extra argument [mode]
+(** [open_out_gen mode perm filename] opens the named file for writing,
+ as described above. The extra argument [mode]
specify the opening mode. The extra argument [perm] specifies
the file permissions, in case the file must be created.
{!Pervasives.open_out} and {!Pervasives.open_out_bin} are special
cases of this function. *)
val flush : out_channel -> unit
-(** Flush the buffer associated with the given output channel,
+(** Flush the buffer associated with the given output channel,
performing all pending writes on that channel.
Interactive programs must be careful about flushing standard
output and standard error at the right time. *)
mode, this function behaves like {!Pervasives.open_in}. *)
val open_in_gen : open_flag list -> int -> string -> in_channel
-(** Open the named file for reading, as above. The extra arguments
+(** [open_in 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
cases of this function. *)
if desired. (See also {!Pervasives.really_input} for reading
exactly [len] characters.)
Exception [Invalid_argument "input"] is raised if [pos] and [len]
- do not designate a valid substring of [buf]. *)
+ do not designate a valid substring of [buf]. *)
val really_input : in_channel -> string -> int -> int -> unit
(** [really_input ic buf pos len] reads [len] characters from channel [ic],
(** {6 Operations on format strings} *)
-(** See modules {!Printf} and {!Scanf} for more operations on
+(** See modules {!Printf} and {!Scanf} for more operations on
format strings. *)
type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
(* *)
(***********************************************************************)
-(* $Id: printexc.mli,v 1.11 2001/12/07 13:40:57 xleroy Exp $ *)
+(* $Id: printexc.mli,v 1.12 2005/10/25 18:34:07 doligez Exp $ *)
(** Facilities for printing exceptions. *)
makes it harder to track the location of the exception
using the debugger or the stack backtrace facility.
So, do not use [Printexc.catch] in new code. *)
-
(* *)
(* Objective Caml *)
(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* Xavier Leroy and Pierre Weis, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* *)
(***********************************************************************)
-(* $Id: printf.ml,v 1.30 2004/01/02 19:23:29 doligez Exp $ *)
+(* $Id: printf.ml,v 1.40 2005/10/25 18:34:07 doligez Exp $ *)
external format_int: string -> int -> string = "caml_format_int"
external format_int32: string -> int32 -> string = "caml_int32_format"
external format_int64: string -> int64 -> string = "caml_int64_format"
external format_float: string -> float -> string = "caml_format_float"
-let bad_format fmt pos =
+external format_to_string: ('a, 'b, 'c, 'd) format4 -> string = "%identity"
+
+type index;;
+
+external index_of_int : int -> index = "%identity";;
+external int_of_index : index -> int = "%identity";;
+
+let succ_index index = index_of_int (succ (int_of_index index));;
+(* Litteral position are One-based (hence pred p instead of p). *)
+let index_of_litteral_position p = index_of_int (pred p);;
+
+let bad_conversion fmt i c =
+ invalid_arg
+ ("printf: bad conversion %" ^ String.make 1 c ^ ", at char number " ^
+ string_of_int i ^ " in format string ``" ^ fmt ^ "''");;
+
+let incomplete_format fmt =
invalid_arg
- ("printf: bad format " ^ String.sub fmt pos (String.length fmt - pos))
+ ("printf: premature end of format string ``" ^ fmt ^ "''");;
(* Parses a format to return the specified length and the padding direction. *)
-let parse_format format =
+let parse_format fmt =
let rec parse neg i =
- if i >= String.length format then (0, neg) else
- match String.unsafe_get format i with
+ if i >= String.length fmt then (0, neg) else
+ match String.unsafe_get fmt i with
| '1'..'9' ->
- (int_of_string (String.sub format i (String.length format - i - 1)),
+ (int_of_string (String.sub fmt i (String.length fmt - i - 1)),
neg)
| '-' ->
parse true (succ i)
| _ ->
parse neg (succ i) in
- try parse false 1 with Failure _ -> bad_format format 0
+ try parse false 1 with Failure _ -> bad_conversion fmt 0 's'
(* Pad a (sub) string into a blank string of length [p],
on the right if [neg] is true, on the left otherwise. *)
(* Format a string given a %s format, e.g. %40s or %-20s.
To do: ignore other flags (#, +, etc)? *)
-let format_string format s =
- let (p, neg) = parse_format format in
+let format_string fmt s =
+ let (p, neg) = parse_format fmt in
pad_string ' ' p neg s 0 (String.length s)
(* Extract a %format from [fmt] between [start] and [stop] inclusive.
- '*' in the format are replaced by integers taken from the [widths] list.
- The function is somewhat optimized for the "no *" case. *)
-
+ '*' in the format are replaced by integers taken from the [widths] list. *)
let extract_format fmt start stop widths =
- match widths with
- | [] -> String.sub fmt start (stop - start + 1)
- | _ ->
- let b = Buffer.create (stop - start + 10) in
- let rec fill_format i w =
- if i > stop then Buffer.contents b else
- match (String.unsafe_get fmt i, w) with
- | ('*', h :: t) ->
- Buffer.add_string b (string_of_int h); fill_format (succ i) t
- | ('*', []) ->
- bad_format fmt start (* should not happen *)
- | (c, _) ->
- Buffer.add_char b c; fill_format (succ i) w
- in fill_format start (List.rev widths)
+ let skip_positional_spec start =
+ match String.unsafe_get fmt start with
+ | '0'..'9' ->
+ let rec skip_int_litteral i =
+ match String.unsafe_get fmt i with
+ | '0'..'9' -> skip_int_litteral (succ i)
+ | '$' -> succ i
+ | _ -> start in
+ skip_int_litteral (succ start)
+ | _ -> start in
+ let start = skip_positional_spec (succ start) in
+ let b = Buffer.create (stop - start + 10) in
+ Buffer.add_char b '%';
+ let rec fill_format i widths =
+ if i <= stop then
+ match (String.unsafe_get fmt i, widths) with
+ | ('*', h :: t) ->
+ Buffer.add_string b (string_of_int h);
+ let i = skip_positional_spec (succ i) in
+ fill_format i t
+ | ('*', []) ->
+ assert false (* should not happen *)
+ | (c, _) ->
+ Buffer.add_char b c; fill_format (succ i) widths in
+ fill_format start (List.rev widths);
+ Buffer.contents b;;
let format_int_with_conv conv fmt i =
match conv with
| 'n' | 'N' -> fmt.[String.length fmt - 1] <- 'u'; format_int fmt i
| _ -> format_int fmt i
+(* Returns the position of the last character of the meta format
+ string, starting from position [i], inside a given format [fmt].
+ According to the character [conv], the meta format string is
+ enclosed by the delimitors %{ and %} (when [conv = '{']) or %( and
+ %) (when [conv = '(']). Hence, [sub_format] returns the index of
+ the character ')' or '}' that ends the meta format, according to
+ the character [conv]. *)
+let sub_format incomplete_format bad_conversion conv fmt i =
+ let len = String.length fmt in
+ let rec sub_fmt c i =
+ let close = if c = '(' then ')' else '}' in
+ let rec sub j =
+ if j >= len then incomplete_format fmt else
+ match fmt.[j] with
+ | '%' -> sub_sub (succ j)
+ | _ -> sub (succ j)
+ and sub_sub j =
+ if j >= len then incomplete_format fmt else
+ match fmt.[j] with
+ | '(' | '{' as c ->
+ let j = sub_fmt c (succ j) in sub (succ j)
+ | ')' | '}' as c ->
+ if c = close then j else bad_conversion fmt i c
+ | _ -> sub (succ j) in
+ sub i in
+ sub_fmt conv i;;
+
+let sub_format_for_printf = sub_format incomplete_format bad_conversion;;
+
+let iter_format_args fmt add_conv add_char =
+ let len = String.length fmt in
+ let rec scan_flags skip i =
+ if i >= len then incomplete_format fmt else
+ match String.unsafe_get fmt i with
+ | '*' -> scan_flags skip (add_conv skip i 'i')
+ | '$' -> scan_flags skip (succ i)
+ | '#' | '-' | ' ' | '+' -> scan_flags skip (succ i)
+ | '_' -> scan_flags true (succ i)
+ | '0'..'9'
+ | '.' -> scan_flags skip (succ i)
+ | _ -> scan_conv skip i
+ and scan_conv skip i =
+ if i >= len then incomplete_format fmt else
+ match String.unsafe_get fmt i with
+ | '%' | '!' -> succ i
+ | 's' | 'S' | '[' -> add_conv skip i 's'
+ | 'c' | 'C' -> add_conv skip i 'c'
+ | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' -> add_conv skip i 'i'
+ | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> add_conv skip i 'f'
+ | 'B' | 'b' -> add_conv skip i 'B'
+ | 'a' | 't' as conv -> add_conv skip i conv
+ | 'l' | 'n' | 'L' as conv ->
+ let j = succ i in
+ if j >= len then add_conv skip i 'i' else begin
+ match fmt.[j] with
+ | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
+ add_char skip (add_conv skip i conv) 'i'
+ | c -> add_conv skip i 'i' end
+ | '{' | '(' as conv -> add_conv skip i conv
+ | '}' | ')' as conv -> add_conv skip i conv
+ | conv -> bad_conversion fmt i conv in
+ let lim = len - 1 in
+ let rec loop i =
+ if i < lim then
+ if fmt.[i] = '%' then loop (scan_flags false (succ i)) else
+ loop (succ i) in
+ loop 0;;
+
+(* Returns a string that summarizes the typing information that a given
+ format string contains.
+ It also checks the well-formedness of the format string.
+ For instance, [summarize_format_type "A number %d\n"] is "%i". *)
+let summarize_format_type fmt =
+ let len = String.length fmt in
+ let b = Buffer.create len in
+ let add i c = Buffer.add_char b c; succ i in
+ let add_char skip i c =
+ if skip then succ i else add i c
+ and add_conv skip i c =
+ if skip then Buffer.add_string b "%_" else Buffer.add_char b '%';
+ add i c in
+ iter_format_args fmt add_conv add_char;
+ Buffer.contents b;;
+
+(* Computes the number of arguments of a format (including flag
+ arguments if any). *)
+let nargs_of_format_type fmt =
+ let num_args = ref 0
+ and skip_args = ref 0 in
+ let add_conv skip i c =
+ let incr_args n = if c = 'a' then n := !n + 2 else n := !n + 1 in
+ if skip then incr_args skip_args else incr_args num_args;
+ succ i
+ and add_char skip i c = succ i in
+ iter_format_args fmt add_conv add_char;
+ !skip_args + !num_args;;
+
+let list_iter_i f l =
+ let rec loop i = function
+ | [] -> ()
+ | x :: xs -> f i x; loop (succ i) xs in
+ 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. *)
+let kapr kpr fmt =
+ match nargs_of_format_type fmt with
+ | 0 -> kpr fmt [||]
+ | 1 -> Obj.magic (fun x ->
+ let a = Array.make 1 (Obj.repr 0) in
+ a.(0) <- x;
+ kpr fmt a)
+ | 2 -> Obj.magic (fun x y ->
+ let a = Array.make 2 (Obj.repr 0) in
+ a.(0) <- x; a.(1) <- y;
+ kpr fmt a)
+ | 3 -> Obj.magic (fun x y z ->
+ let a = Array.make 3 (Obj.repr 0) in
+ a.(0) <- x; a.(1) <- y; a.(2) <- z;
+ kpr fmt a)
+ | 4 -> Obj.magic (fun x y z t ->
+ let a = Array.make 4 (Obj.repr 0) in
+ a.(0) <- x; a.(1) <- y; a.(2) <- z;
+ a.(3) <- t;
+ kpr fmt a)
+ | 5 -> Obj.magic (fun x y z t u ->
+ let a = Array.make 5 (Obj.repr 0) in
+ a.(0) <- x; a.(1) <- y; a.(2) <- z;
+ a.(3) <- t; a.(4) <- u;
+ kpr fmt a)
+ | 6 -> Obj.magic (fun x y z t u v ->
+ let a = Array.make 6 (Obj.repr 0) in
+ a.(0) <- x; a.(1) <- y; a.(2) <- z;
+ a.(3) <- t; a.(4) <- u; a.(5) <- v;
+ kpr fmt a)
+ | 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;
+ kpr fmt a
+ else Obj.magic (fun x -> loop (succ i) (x :: args)) in
+ loop 0 [];;
+
+(* To scan a positional parameter specification. *)
+let scan_positional_spec fmt k n i =
+ match String.unsafe_get fmt i with
+ | '0'..'9' as d ->
+ let rec get_int_litteral accu i =
+ match String.unsafe_get fmt i with
+ | '0'..'9' as d ->
+ get_int_litteral (10 * accu + (int_of_char d - 48)) (succ i)
+ | '$' ->
+ k (Some (index_of_litteral_position accu)) None (succ i)
+ | _ -> k None (Some accu) i in
+ get_int_litteral (int_of_char d - 48) (succ i)
+ | _ -> k None None i;;
+
+(* To scan a positional parameter. *)
+let scan_positional fmt scan_flags n i =
+ let got_positional p w i =
+ match p, w with
+ | None, None -> scan_flags n [] i
+ | Some p, None -> scan_flags p [] i
+ | None, Some w -> scan_flags n [w] i
+ | _, _ -> assert false in
+ scan_positional_spec fmt got_positional n i;;
+
(* Decode a %format and act on it.
[fmt] is the printf format style, and [pos] points to a [%] character.
After consuming the appropriate number of arguments and formatting
- them, one of the three continuations is called:
+ them, one of the five continuations is called:
[cont_s] for outputting a string (args: string, next pos)
[cont_a] for performing a %a action (args: fn, arg, next pos)
[cont_t] for performing a %t action (args: fn, next pos)
+ [cont_f] for performing a flush action
+ [cont_m] for performing a %( action (args: sfmt, next pos)
"next pos" is the position in [fmt] of the first character following
the %format in [fmt]. *)
to detect the end of the format, we use [String.unsafe_get] and
rely on the fact that we'll get a "nul" character if we access
one past the end of the string. These "nul" characters are then
- caught by the [_ -> bad_format] clauses below.
+ caught by the [_ -> bad_conversion] clauses below.
Don't do this at home, kids. *)
+let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
+
+ let get_arg args n = Obj.magic args.(int_of_index n) in
-let scan_format fmt pos cont_s cont_a cont_t cont_f =
- let rec scan_flags widths i =
+ let rec scan_flags n widths i =
match String.unsafe_get fmt i with
| '*' ->
- Obj.magic(fun w -> scan_flags (w :: widths) (succ i))
- | '0'..'9' | '.' | '#' | '-' | ' ' | '+' -> scan_flags widths (succ i)
- | _ -> scan_conv widths i
- and scan_conv widths i =
+ let got_positional p w i =
+ match p, w with
+ | None, None ->
+ let (width : int) = get_arg args n in
+ scan_flags (succ_index n) (width :: widths) i
+ | Some p, None ->
+ let (width : int) = get_arg args p in
+ scan_flags n (width :: widths) i
+ | _, _ -> assert false in
+ scan_positional_spec fmt got_positional n (succ i)
+ | '0'..'9'
+ | '.' | '#' | '-' | ' ' | '+' -> scan_flags n widths (succ i)
+ | _ -> scan_conv n widths i
+
+ and scan_conv n widths i =
match String.unsafe_get fmt i with
| '%' ->
- cont_s "%" (succ i)
+ cont_s n "%" (succ i)
| 's' | 'S' as conv ->
- Obj.magic (fun (s: string) ->
- let s = if conv = 's' then s else "\"" ^ String.escaped s ^ "\"" in
- if i = succ pos (* optimize for common case %s *)
- then cont_s s (succ i)
- else cont_s (format_string (extract_format fmt pos i widths) s)
- (succ i))
+ let (x : string) = get_arg args n in
+ let x = if conv = 's' then x else "\"" ^ String.escaped x ^ "\"" in
+ let s =
+ (* optimize for common case %s *)
+ if i = succ pos then x else
+ format_string (extract_format fmt pos i widths) x in
+ cont_s (succ_index n) s (succ i)
| 'c' | 'C' as conv ->
- Obj.magic (fun (c: char) ->
- if conv = 'c'
- then cont_s (String.make 1 c) (succ i)
- else cont_s ("'" ^ Char.escaped c ^ "'") (succ i))
+ let (x : char) = get_arg args n in
+ let s =
+ if conv = 'c' then String.make 1 x else "'" ^ Char.escaped x ^ "'" in
+ cont_s (succ_index n) s (succ i)
| 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' as conv ->
- Obj.magic(fun (n: int) ->
- cont_s (format_int_with_conv conv
- (extract_format fmt pos i widths) n)
- (succ i))
+ let (x : int) = get_arg args n in
+ let s = format_int_with_conv conv (extract_format fmt pos i widths) x in
+ cont_s (succ_index n) s (succ i)
| 'f' | 'e' | 'E' | 'g' | 'G' | 'F' as conv ->
- Obj.magic(fun (f: float) ->
- let s =
- if conv = 'F' then string_of_float f else
- format_float (extract_format fmt pos i widths) f in
- cont_s s (succ i))
+ let (x : float) = get_arg args n in
+ let s =
+ if conv = 'F' then string_of_float x else
+ format_float (extract_format fmt pos i widths) x in
+ cont_s (succ_index n) s (succ i)
| 'B' | 'b' ->
- Obj.magic(fun (b: bool) ->
- cont_s (string_of_bool b) (succ i))
+ let (x : bool) = get_arg args n in
+ cont_s (succ_index n) (string_of_bool x) (succ i)
| 'a' ->
- Obj.magic (fun printer arg ->
- cont_a printer arg (succ i))
+ let printer = get_arg args n in
+ let n = succ_index n in
+ let arg = get_arg args n in
+ cont_a (succ_index n) printer arg (succ i)
| 't' ->
- Obj.magic (fun printer ->
- cont_t printer (succ i))
- | 'l' ->
- begin match String.unsafe_get fmt (succ i) with
- | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
- Obj.magic(fun (n: int32) ->
- cont_s (format_int32 (extract_format fmt pos (succ i) widths) n)
- (i + 2))
- | _ ->
- bad_format fmt pos
- end
- | 'n' ->
- begin match String.unsafe_get fmt (succ i) with
- | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
- Obj.magic(fun (n: nativeint) ->
- cont_s (format_nativeint
- (extract_format fmt pos (succ i) widths)
- n)
- (i + 2))
- | _ ->
- Obj.magic(fun (n: int) ->
- cont_s (format_int_with_conv 'n'
- (extract_format fmt pos i widths)
- n)
- (succ i))
- end
- | 'L' ->
- begin match String.unsafe_get fmt (succ i) with
- | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
- Obj.magic(fun (n: int64) ->
- cont_s (format_int64 (extract_format fmt pos (succ i) widths) n)
- (i + 2))
- | _ ->
- bad_format fmt pos
- end
- | '!' ->
- Obj.magic (cont_f (succ i))
- | _ ->
- bad_format fmt pos
- in scan_flags [] (pos + 1)
+ let printer = get_arg args n in
+ cont_t (succ_index n) printer (succ i)
+ | 'l' | 'n' | 'L' as conv ->
+ begin match String.unsafe_get fmt (succ i) with
+ | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
+ let s =
+ match conv with
+ | 'l' ->
+ let (x : int32) = get_arg args n in
+ format_int32 (extract_format fmt pos (succ i) widths) x
+ | 'n' ->
+ let (x : nativeint) = get_arg args n in
+ format_nativeint (extract_format fmt pos (succ i) widths) x
+ | _ ->
+ let (x : int64) = get_arg args n in
+ format_int64 (extract_format fmt pos (succ i) widths) x in
+ cont_s (succ_index n) s (i + 2)
+ | _ ->
+ let (x : int) = get_arg args n in
+ cont_s
+ (succ_index n)
+ (format_int_with_conv 'n' (extract_format fmt pos i widths) x)
+ (succ i)
+ end
+ | '!' -> cont_f n (succ i)
+ | '{' | '(' as conv (* ')' '}' *)->
+ let (xf : ('a, 'b, 'c, 'd) format4) = get_arg args n in
+ let i = succ i in
+ let j = sub_format_for_printf conv fmt i + 1 in
+ if conv = '{' (* '}' *) then
+ (* Just print the format argument as a specification. *)
+ cont_s
+ (succ_index n)
+ (summarize_format_type (format_to_string xf)) j else
+ (* Use the format argument instead of the format specification. *)
+ cont_m (succ_index n) xf j
+ | ')' ->
+ cont_s n "" (succ i)
+ | conv ->
+ bad_conversion fmt i conv in
-(* Application to [fprintf], etc. See also [Format.*printf]. *)
+ scan_positional fmt scan_flags n (succ pos);;
-let fprintf chan fmt =
- let fmt = string_of_format fmt in
- let len = String.length fmt in
- let rec doprn i =
- if i >= len then Obj.magic () else
- match String.unsafe_get fmt i with
- | '%' -> scan_format fmt i cont_s cont_a cont_t cont_f
- | c -> output_char chan c; doprn (succ i)
- and cont_s s i =
- output_string chan s; doprn i
- and cont_a printer arg i =
- printer chan arg; doprn i
- and cont_t printer i =
- printer chan; doprn i
- and cont_f i =
- flush chan; doprn i
- in doprn 0
+let mkprintf str get_out outc outs flush =
+ let rec kprintf k fmt =
+ let fmt = format_to_string fmt in
+ let len = String.length fmt in
+
+ let kpr fmt v =
+ let out = get_out fmt in
+ let rec doprn n i =
+ if i >= len then Obj.magic (k out) else
+ match String.unsafe_get fmt i with
+ | '%' -> scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
+ | c -> outc out c; doprn n (succ i)
+ and cont_s n s i =
+ outs out s; doprn n i
+ and cont_a n printer arg i =
+ if str then
+ outs out ((Obj.magic printer : unit -> _ -> string) () arg)
+ else
+ printer out arg;
+ doprn n i
+ and cont_t n printer i =
+ if str 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 sfmt i =
+ kprintf (Obj.magic (fun _ -> doprn n i)) sfmt in
+
+ doprn (index_of_int 0) 0 in
+
+ kapr kpr fmt in
+
+ kprintf;;
+let kfprintf k oc =
+ mkprintf false (fun _ -> oc) output_char output_string flush k
+let fprintf oc = kfprintf ignore oc
let printf fmt = fprintf stdout fmt
let eprintf fmt = fprintf stderr fmt
-let kprintf kont fmt =
- let fmt = string_of_format fmt in
- let len = String.length fmt in
- let dest = Buffer.create (len + 16) in
- let rec doprn i =
- if i >= len then begin
- let res = Buffer.contents dest in
- Buffer.clear dest; (* just in case kprintf is partially applied *)
- Obj.magic (kont res)
- end else
- match String.unsafe_get fmt i with
- | '%' -> scan_format fmt i cont_s cont_a cont_t cont_f
- | c -> Buffer.add_char dest c; doprn (succ i)
- and cont_s s i =
- Buffer.add_string dest s; doprn i
- and cont_a printer arg i =
- Buffer.add_string dest (printer () arg); doprn i
- and cont_t printer i =
- Buffer.add_string dest (printer ()); doprn i
- and cont_f i = doprn i
- in doprn 0
-
-let sprintf fmt = kprintf (fun x -> x) fmt;;
-
-let bprintf dest fmt =
- let fmt = string_of_format fmt in
- let len = String.length fmt in
- let rec doprn i =
- if i >= len then Obj.magic () else
- match String.unsafe_get fmt i with
- | '%' -> scan_format fmt i cont_s cont_a cont_t cont_f
- | c -> Buffer.add_char dest c; doprn (succ i)
- and cont_s s i =
- Buffer.add_string dest s; doprn i
- and cont_a printer arg i =
- printer dest arg; doprn i
- and cont_t printer i =
- printer dest; doprn i
- and cont_f i = doprn i
- in doprn 0
+let kbprintf k b =
+ mkprintf false (fun _ -> b) Buffer.add_char Buffer.add_string ignore k
+let bprintf b = kbprintf ignore b
+
+let get_buff fmt =
+ let len = 2 * String.length fmt in
+ Buffer.create len;;
+
+let get_contents b =
+ let s = Buffer.contents b in
+ Buffer.clear b;
+ 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);;
+
+let kprintf = ksprintf;;
+
+let sprintf fmt = ksprintf (fun s -> s) fmt;;
(* *)
(* Objective Caml *)
(* *)
-(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* Xavier Leroy and Pierre Weis, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* *)
(***********************************************************************)
-(* $Id: printf.mli,v 1.37 2003/07/05 11:13:23 xleroy Exp $ *)
+(* $Id: printf.mli,v 1.46 2005/09/26 10:12:01 weis Exp $ *)
(** Formatted output functions. *)
val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a
(** [fprintf outchan format arg1 ... argN] formats the arguments
- [arg1] to [argN] according to the format string [format],
- and outputs the resulting string on the channel [outchan].
-
+ [arg1] to [argN] according to the format string [format], and
+ outputs the resulting string on the channel [outchan].
+
The format is a character string which contains two types of
- objects: plain characters, which are simply copied to the
- output channel, and conversion specifications, each of which
- causes conversion and printing of one argument.
-
- Conversion specifications consist in the [%] character, followed
- by optional flags and field widths, followed by one or two conversion
- character. The conversion characters and their meanings are:
- - [d], [i], [n], or [N]: convert an integer argument to signed decimal.
+ objects: plain characters, which are simply copied to the output
+ channel, and conversion specifications, each of which causes
+ conversion and printing of arguments.
+
+ Conversion specifications have the following form:
+
+ [% \[positional specifier\] \[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
+ two characters. The types and their meanings are:
+
+ - [d], [i], [n], [l], [L], or [N]: convert an integer argument to
+ signed decimal.
- [u]: convert an integer argument to unsigned decimal.
- [x]: convert an integer argument to unsigned hexadecimal,
using lowercase letters.
- [C]: insert a character argument in Caml syntax (single quotes, escapes).
- [f]: convert a floating-point argument to decimal notation,
in the style [dddd.ddd].
- - [F]: convert a floating-point argument in Caml syntax ([dddd.ddd]
- with a mandatory [.]).
+ - [F]: convert a floating-point argument to Caml syntax ([dddd.]
+ or [dddd.ddd] or [d.ddd e+-dd]).
- [e] or [E]: convert a floating-point argument to decimal notation,
in the style [d.ddd e+-dd] (mantissa and exponent).
- [g] or [G]: convert a floating-point argument to decimal notation,
the format specified by the second letter.
- [Ld], [Li], [Lu], [Lx], [LX], [Lo]: convert an [int64] argument to
the format specified by the second letter.
- - [a]: user-defined printer. Takes two arguments and apply the first
- one to [outchan] (the current output channel) and to the second
- argument. The first argument must therefore have type
+ - [a]: user-defined printer. Takes two arguments and apply the
+ first one to [outchan] (the current output channel) and to the
+ second argument. The first argument must therefore have type
[out_channel -> 'b -> unit] and the second ['b].
- The output produced by the function is therefore inserted
- in the output of [fprintf] at the current point.
+ The output produced by the function is inserted in the output of
+ [fprintf] at the current point.
- [t]: same as [%a], but takes only one argument (with type
[out_channel -> unit]) and apply it to [outchan].
+ - [\{ fmt %\}]: convert a format string argument. The argument must
+ have the same type as the internal format string [fmt].
+ - [\( fmt %\)]: format string substitution. Takes a format string
+ argument and substitutes it to the internal format string [fmt]
+ to print following arguments. The argument must have the same
+ type as [fmt].
- [!]: take no argument and flush the output.
- [%]: take no argument and output one [%] character.
- The optional flags include:
+ 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.
- [+]: for numerical conversions, prefix number with a [+] sign if positive.
- space: for numerical conversions, prefix number with a space if positive.
- [#]: request an alternate formatting style for numbers.
- The field widths are composed of an optional integer literal
- indicating the minimal width of the result, possibly followed by
- a dot [.] and another integer literal indicating how many digits
- follow the decimal point in the [%f], [%e], and [%E] conversions.
- For instance, [%6d] prints an integer, prefixing it with spaces to
- fill at least 6 characters; and [%.4f] prints a float with 4
- fractional digits. Each or both of the integer literals can also be
- specified as a [*], in which case an extra integer argument is taken
- to specify the corresponding width or precision.
-
- Warning: if too few arguments are provided,
- for instance because the [printf] function is partially
- applied, the format is immediately printed up to
- the conversion of the first missing argument; printing
- will then resume when the missing arguments are provided.
- For example, [List.iter (printf "x=%d y=%d " 1) [2;3]]
- prints [x=1 y=2 3] instead of the expected
- [x=1 y=2 x=1 y=3]. To get the expected behavior, do
- [List.iter (fun y -> printf "x=%d y=%d " 1 y) [2;3]]. *)
+ The optional [width] is an integer indicating the minimal
+ width of the result. For instance, [%6d] prints an integer,
+ prefixing it with spaces to fill at least 6 characters.
+
+ The optional [precision] is a dot [.] followed by an integer
+ indicating how many digits follow the decimal point in the [%f],
+ [%e], and [%E] conversions. For instance, [%.4f] prints a [float] with
+ 4 fractional digits.
+
+ 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. *)
val printf : ('a, out_channel, unit) format -> 'a
(** Same as {!Printf.fprintf}, but output on [stdout]. *)
append the formatted arguments to the given extensible buffer
(see module {!Buffer}). *)
-val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b
-(** [kprintf k format arguments] is the same as [sprintf format arguments],
- except that the resulting string is passed as argument to [k]; the
- result of [k] is then returned as the result of [kprintf]. *)
+val kfprintf : (out_channel -> 'a) -> out_channel ->
+ ('b, out_channel, unit, 'a) format4 -> 'b;;
+(** Same as [fprintf], but instead of returning immediately,
+ passes the out channel to its first argument at the end of printing. *)
+
+val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;;
+(** Same as [sprintf] above, but instead of returning the string,
+ passes it to the first argument. *)
+
+val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;;
+(** A deprecated synonym for [ksprintf]. *)
(**/**)
(* For system use only. Don't call directly. *)
+type index;;
+
+external index_of_int : int -> index = "%identity";;
+
+val scan_format : string -> 'a array -> index -> int ->
+ (index -> string -> int -> 'b) ->
+ (index -> 'c -> 'd -> int -> 'b) ->
+ (index -> 'e -> int -> 'b) ->
+ (index -> int -> 'b) ->
+ (index -> ('h, 'i, 'j, 'k) format4 -> int -> 'b) -> 'b
-val scan_format :
- string -> int -> (string -> int -> 'a) -> ('b -> 'c -> int -> 'a) ->
- ('e -> int -> 'a) -> (int -> 'a) -> 'a
+val sub_format :
+ (string -> int) -> (string -> int -> char -> int) ->
+ char -> string -> int -> int
+val summarize_format_type : string -> string
+val kapr : (string -> Obj.t array -> 'a) -> string -> 'a
(* *)
(***********************************************************************)
-(* $Id: queue.ml,v 1.9 2002/07/23 14:12:01 doligez Exp $ *)
+(* $Id: queue.ml,v 1.10 2005/08/26 12:10:47 doligez Exp $ *)
exception Empty
type 'a cell = {
content: 'a;
mutable next: 'a cell
- }
+ }
(* A queue is a reference to either nothing or some cell of a cyclic
list. By convention, that cell is to be viewed as the last cell in
type 'a t = {
mutable length: int;
mutable tail: 'a cell
- }
+ }
let create () = {
length = 0;
tail = Obj.magic None
-}
+}
let clear q =
q.length <- 0;
peek
let take q =
- if q.length = 0 then
- raise Empty
+ if q.length = 0 then raise Empty;
+ q.length <- q.length - 1;
+ let tail = q.tail in
+ let head = tail.next in
+ if head == tail then
+ q.tail <- Obj.magic None
else
- q.length <- q.length - 1;
- let tail = q.tail in
- let head = tail.next in
- if head == tail then
- q.tail <- Obj.magic None
- else
- tail.next <- head.next;
- head.content
+ tail.next <- head.next;
+ head.content
let pop =
take
{
length = q.length;
tail = tail'
- }
+ }
let is_empty q =
q.length = 0
end;
q2.length <- q2.length + length1;
q2.tail <- tail1
-
(* *)
(***********************************************************************)
-(* $Id: scanf.ml,v 1.49.2.2 2004/07/02 22:24:24 weis Exp $ *)
+(* $Id: scanf.ml,v 1.63 2005/09/20 21:42:44 weis Exp $ *)
(* The run-time library for scanners. *)
type scanbuf;;
val stdib : scanbuf;;
-(** The scanning buffer reading from [stdin].
+(* The scanning buffer reading from [stdin].
[stdib] is equivalent to [Scanning.from_channel stdin]. *)
-val next_char : scanbuf -> unit;;
-(** [Scanning.next_char scanbuf] advance the scanning buffer for
+val next_char : scanbuf -> char;;
+(* [Scanning.next_char ib] advance the scanning buffer for
one character.
If no more character can be read, sets a end of file condition and
returns '\000'. *)
+val invalidate_current_char : scanbuf -> unit;;
+(* [Scanning.invalidate_current_char ib] mark the current_char as already
+ scanned. *)
+
val peek_char : scanbuf -> char;;
-(** [Scanning.peek_char scanbuf] returns the current char available in
- the buffer. *)
-
-val cautious_peek_char : scanbuf -> char;;
-(** [Scanning.cautious_peek_char scanbuf] returns the current char
- available in the buffer or tries to read one if none has ever been
- read.
- If no character can be read, sets a end of file condition and
+(* [Scanning.peek_char ib] returns the current char available in
+ the buffer or read one if necessary (when the current character is
+ already scanned).
+ If no character can be read, sets an end of file condition and
returns '\000'. *)
val checked_peek_char : scanbuf -> char;;
-(** Same as above but always returns a valid char or fails:
+(* Same as above but always returns a valid char or fails:
instead of returning a null char when the reading method of the
input buffer has reached an end of file, the function raises exception
[End_of_file]. *)
val store_char : scanbuf -> char -> int -> int;;
-(** [Scanning.store_char scanbuf c lim] adds [c] to the token buffer
+(* [Scanning.store_char ib c lim] adds [c] to the token buffer
of the scanning buffer. It also advances the scanning buffer for one
character and returns [lim - 1], indicating the new limit
for the length of the current token. *)
-val skip_char : scanbuf -> char -> int -> int;;
-(** [Scanning.skip_char scanbuf c lim] is similar to [store_char] but
- it ignores (does not store in the token buffer) the character [c]. *)
+val skip_char : scanbuf -> int -> int;;
+(* [Scanning.skip_char ib lim] ignores the current character. *)
+
+val ignore_char : scanbuf -> int -> int;;
+(* [Scanning.ignore_char ib lim] ignores the current character and
+ decrements the limit. *)
val token : scanbuf -> string;;
-(** [Scanning.token scanbuf] returns the string stored into the token
+(* [Scanning.token ib] returns the string stored into the token
buffer of the scanning buffer: it returns the token matched by the
format. *)
val reset_token : scanbuf -> unit;;
-(** [Scanning.reset_token scanbuf] resets the token buffer of
+(* [Scanning.reset_token ib] resets the token buffer of
the given scanning buffer. *)
val char_count : scanbuf -> int;;
-(** [Scanning.char_count scanbuf] returns the number of characters
+(* [Scanning.char_count ib] returns the number of characters
read so far from the given buffer. *)
val line_count : scanbuf -> int;;
-(** [Scanning.line_count scanbuf] returns the number of new line
+(* [Scanning.line_count ib] returns the number of new line
characters read so far from the given buffer. *)
val token_count : scanbuf -> int;;
-(** [Scanning.token_count scanbuf] returns the number of tokens read
- so far from [scanbuf]. *)
+(* [Scanning.token_count ib] returns the number of tokens read
+ so far from [ib]. *)
val eof : scanbuf -> bool;;
-(** [Scanning.eof scanbuf] returns the current value of the end of input
- condition of the given buffer, no validity test is performed. *)
+(* [Scanning.eof ib] returns the end of input condition
+ of the given buffer. *)
val end_of_input : scanbuf -> bool;;
-(** [Scanning.end_of_input scanbuf] tests the end of input condition
- of the given buffer. *)
+(* [Scanning.end_of_input ib] tests the end of input condition
+ of the given buffer (if no char has ever been read, an attempt to
+ read one is performed). *)
val beginning_of_input : scanbuf -> bool;;
-(** [Scanning.beginning_of_input scanbuf] tests the beginning of input
+(* [Scanning.beginning_of_input ib] tests the beginning of input
condition of the given buffer. *)
+val name_of_input : scanbuf -> string;;
+(* [Scanning.name_of_input ib] returns the name of the character
+ source for input buffer [ib]. *)
+
val from_string : string -> scanbuf;;
val from_channel : in_channel -> scanbuf;;
val from_file : string -> scanbuf;;
type scanbuf = {
mutable eof : bool;
- mutable bof : bool;
- mutable cur_char : char;
+ mutable current_char : char;
+ mutable current_char_is_valid : bool;
mutable char_count : int;
mutable line_count : int;
mutable token_count : int;
file_name : file_name;
};;
+let null_char = '\000';;
+
(* Reads a new character from input buffer. Next_char never fails,
even in case of end of input: it then simply sets the end of file
condition. *)
let next_char ib =
try
- let c = ib.get_next_char () in
- ib.cur_char <- c;
- ib.char_count <- ib.char_count + 1;
- if c == '\n' then ib.line_count <- ib.line_count + 1
- with End_of_file ->
- ib.cur_char <- '\000';
- ib.eof <- true;;
-
-let cautious_peek_char ib =
- if ib.bof then begin
- next_char ib;
- if ib.char_count > 0 then ib.bof <- false end;
- ib.cur_char;;
-
-(* Returns a valid current char for the input buffer. In particular
+ let c = ib.get_next_char () in
+ ib.current_char <- c;
+ ib.current_char_is_valid <- true;
+ ib.char_count <- ib.char_count + 1;
+ if c == '\n' then ib.line_count <- ib.line_count + 1;
+ c with
+ | End_of_file ->
+ let c = null_char in
+ ib.current_char <- c;
+ ib.current_char_is_valid <- false;
+ ib.eof <- true;
+ c;;
+
+let peek_char ib =
+ if ib.current_char_is_valid then ib.current_char else next_char ib;;
+
+(* Returns a valid current char for the input buffer. In particular
no irrelevant null character (as set by [next_char] in case of end
of input) is returned, since [End_of_file] is raised when
[next_char] sets the end of file condition while trying to read a
new character. *)
let checked_peek_char ib =
- let c = cautious_peek_char ib in
+ let c = peek_char ib in
if ib.eof then raise End_of_file;
c;;
-let peek_char ib = ib.cur_char;;
-let eof ib = ib.eof;;
-let beginning_of_input ib = ib.bof;;
let end_of_input ib =
- let c = cautious_peek_char ib in
+ ignore (peek_char ib);
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 line_count ib = ib.line_count;;
let reset_token ib = Buffer.reset ib.tokbuf;;
+let invalidate_current_char ib = ib.current_char_is_valid <- false;;
let token ib =
let tokbuf = ib.tokbuf in
let token_count ib = ib.token_count;;
+let skip_char ib max =
+ invalidate_current_char ib;
+ max;;
+
+let ignore_char ib max = skip_char ib (max - 1);;
+
let store_char ib c max =
Buffer.add_char ib.tokbuf c;
- next_char ib;
- max - 1;;
-
-let skip_char ib c max =
- next_char ib;
- max - 1;;
+ ignore_char ib max;;
let default_token_buffer_size = 1024;;
let create fname next = {
eof = false;
- bof = true;
- cur_char = '\000';
+ current_char = '\000';
+ current_char_is_valid = false;
char_count = 0;
line_count = 0;
token_count = 0;
let c = s.[!i] in
incr i;
c in
- create "string" next;;
+ create "string input" next;;
-let from_function = create "function";;
+let from_function = create "function input";;
(* Perform bufferized input to improve efficiency. *)
let file_buffer_size = ref 1024;;
let next () = input_char ic in
create fname next;;
-let from_channel = from_input_channel "in_channel";;
+let from_channel = from_input_channel "input channel";;
+(* The scanning buffer reading from [stdin].*)
let stdib = from_input_channel "stdin" stdin;;
-(** The scanning buffer reading from [stdin].*)
end;;
-(** Formatted input functions. *)
+(* Formatted input functions. *)
(* Reporting errors. *)
exception Scan_failure of string;;
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)
+ bad_input (Printf.sprintf "scanf: bad input at char number %i: %s" i s)
| x -> raise x;;
-let bad_format fmt i fc =
+let bad_conversion fmt i c =
invalid_arg
(Printf.sprintf
- "scanf: bad conversion %%%c, at char number %i in format %S" fc i fmt);;
+ "scanf: bad conversion %%%c, at char number %i \
+ in format string ``%s''" c i fmt);;
+
+let incomplete_format fmt =
+ invalid_arg
+ (Printf.sprintf "scanf: premature end of format string ``%s''" fmt);;
let bad_float () = bad_input "no dot or exponent part found in float token";;
-(* Checking that the current char is indeed one of range, then skip it. *)
-let check_char_in range ib =
- if range <> [] && not (Scanning.end_of_input ib) then
- let ci = Scanning.checked_peek_char ib in
- if List.memq ci range then Scanning.next_char ib else
- let sr = String.concat "" (List.map (String.make 1) range) in
- bad_input
- (Printf.sprintf "looking for one of range %S, found %C" sr ci);;
+let format_mismatch_err fmt1 fmt2 =
+ Printf.sprintf "format read %S does not match specification %S" fmt1 fmt2;;
+
+let format_mismatch fmt1 fmt2 ib =
+ scanf_bad_input ib (Scan_failure (format_mismatch_err fmt1 fmt2));;
+
+(* Checking that 2 format string are type compatible. *)
+let compatible_format_type fmt1 fmt2 =
+ Printf.summarize_format_type fmt1 = Printf.summarize_format_type fmt2;;
-(* Checking that [c] is indeed in the input, then skip it. *)
+(* Checking that [c] is indeed in the input, then skips it.
+ In this case, the character c has been explicitely specified in the
+ format as being mandatory in the input; hence we should fail with
+ End_of_file in case of end_of_input.
+ 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.next_char ib;;
+ if ci != c then
+ bad_input (Printf.sprintf "looking for %C, found %C" c ci) else
+ Scanning.invalidate_current_char ib;;
+
+(* Checks that the current char is indeed one of the stopper characters,
+ then skips it.
+ Be careful that if ib has no more character this procedure should
+ just do nothing (since %s@c defaults to the entire rest of the
+ buffer, when no character c can be found in the input). *)
+let ignore_stoppers stps ib =
+ if stps <> [] && not (Scanning.eof ib) then
+ let ci = Scanning.peek_char ib in
+ 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);;
(* Extracting tokens from ouput token buffer. *)
scanning function). *)
(* The decimal case is treated especially for optimization purposes. *)
-let scan_decimal_digits max ib =
- let rec loop inside max =
- if max = 0 || Scanning.eof ib then max else
- match Scanning.cautious_peek_char ib with
- | '0' .. '9' as c ->
- let max = Scanning.store_char ib c max in
- loop true max
- | '_' as c when inside ->
- let max = Scanning.skip_char ib c max in
- loop true max
- | c -> max in
- loop false max;;
-
-(* To scan numbers from other bases, we use a predicate argument to
- scan_digits. *)
-let scan_digits digitp max ib =
- let rec loop inside max =
- if max = 0 || Scanning.eof ib then max else
- match Scanning.cautious_peek_char ib with
+let rec scan_decimal_digits max ib =
+ if max = 0 then max else
+ let c = Scanning.peek_char ib in
+ if Scanning.eof ib then max else
+ match c with
+ | '0' .. '9' as c ->
+ let max = Scanning.store_char ib c max in
+ scan_decimal_digits max ib
+ | '_' ->
+ let max = Scanning.ignore_char ib max in
+ scan_decimal_digits max ib
+ | _ -> max;;
+
+let scan_decimal_digits_plus max ib =
+ let c = Scanning.checked_peek_char ib in
+ match c with
+ | '0' .. '9' ->
+ let max = Scanning.store_char ib c max in
+ scan_decimal_digits max ib
+ | c -> bad_input_char c;;
+
+let scan_digits_plus digitp max ib =
+ (* To scan numbers from other bases, we use a predicate argument to
+ scan_digits. *)
+ let rec scan_digits max =
+ if max = 0 then max else
+ let c = Scanning.peek_char ib in
+ if Scanning.eof ib then max else
+ match c with
| c when digitp c ->
let max = Scanning.store_char ib c max in
- loop true max
- | '_' as c when inside ->
- let max = Scanning.skip_char ib c max in
- loop true max
+ scan_digits max
+ | '_' ->
+ let max = Scanning.ignore_char ib max in
+ scan_digits max
| _ -> max in
- loop false max;;
-let scan_digits_plus digitp max ib =
let c = Scanning.checked_peek_char ib in
if digitp c then
let max = Scanning.store_char ib c max in
- scan_digits digitp max ib
+ scan_digits max
else bad_input_char c;;
let is_binary_digit = function
| '0' .. '1' -> true
| _ -> false;;
-let scan_binary_digits = scan_digits is_binary_digit;;
let scan_binary_int = scan_digits_plus is_binary_digit;;
let is_octal_digit = function
| '0' .. '7' -> true
| _ -> false;;
-let scan_octal_digits = scan_digits is_octal_digit;;
let scan_octal_int = scan_digits_plus is_octal_digit;;
let is_hexa_digit = function
| '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true
| _ -> false;;
-let scan_hexadecimal_digits = scan_digits is_hexa_digit;;
let scan_hexadecimal_int = scan_digits_plus is_hexa_digit;;
(* Scan a decimal integer. *)
-let scan_unsigned_decimal_int max ib =
- match Scanning.checked_peek_char ib with
- | '0' .. '9' as c ->
- let max = Scanning.store_char ib c max in
- scan_decimal_digits max ib
- | c -> bad_input_char c;;
+let scan_unsigned_decimal_int = scan_decimal_digits_plus;;
let scan_sign max ib =
let c = Scanning.checked_peek_char ib in
match Scanning.checked_peek_char ib with
| '0' as c ->
let max = Scanning.store_char ib c max in
- if max = 0 || Scanning.eof ib then max else
+ if max = 0 then max else
let c = Scanning.peek_char ib in
+ if Scanning.eof ib then max else
begin match c with
- | 'x' | 'X' -> scan_hexadecimal_digits (Scanning.store_char ib c max) ib
- | 'o' -> scan_octal_digits (Scanning.store_char ib c max) ib
- | 'b' -> scan_binary_digits (Scanning.store_char ib c max) ib
+ | 'x' | 'X' -> scan_hexadecimal_int (Scanning.store_char ib c max) ib
+ | 'o' -> scan_octal_int (Scanning.store_char ib c max) ib
+ | 'b' -> scan_binary_int (Scanning.store_char ib c max) ib
| c -> scan_decimal_digits max ib end
| c -> scan_unsigned_decimal_int max ib;;
(* Scanning floating point numbers. *)
(* Fractional part is optional and can be reduced to 0 digits. *)
let scan_frac_part max ib =
- if max = 0 || Scanning.eof ib then max else
- scan_decimal_digits max ib;;
+ if max = 0 then max else
+ let c = Scanning.peek_char ib in
+ if Scanning.eof ib then max else
+ match c with
+ | '0' .. '9' as c ->
+ scan_decimal_digits (Scanning.store_char ib c max) ib
+ | _ -> max;;
(* Exp part is optional and can be reduced to 0 digits. *)
let scan_exp_part max ib =
- if max = 0 || Scanning.eof ib then max else
+ if max = 0 then max else
let c = Scanning.peek_char ib in
+ if Scanning.eof ib then max else
match c with
| 'e' | 'E' as c ->
scan_optionally_signed_decimal_int (Scanning.store_char ib c max) ib
| _ -> max;;
-(* An optional sign followed by a possibly empty sequence of decimal digits. *)
-let scan_optionally_signed_decimal_digits max ib =
+(* Scan the integer part of a floating point number, (not using the
+ Caml lexical convention since the integer part can be empty):
+ an optional sign, followed by a possibly empty sequence of decimal
+ digits (e.g. -.1). *)
+let scan_int_part max ib =
let max = scan_sign max ib in
scan_decimal_digits max ib;;
-(* Scan the integer part of a floating point number, (not using the
- Caml lexical convention since the integer part can be empty). *)
-let scan_int_part = scan_optionally_signed_decimal_digits;;
-
let scan_float max ib =
let max = scan_int_part max ib in
- if max = 0 || Scanning.eof ib then max else
+ if max = 0 then max else
let c = Scanning.peek_char ib in
+ if Scanning.eof ib then max else
match c with
| '.' ->
let max = Scanning.store_char ib c max in
let scan_Float max ib =
let max = scan_optionally_signed_decimal_int max ib in
- if max = 0 || Scanning.eof ib then bad_float () else
+ if max = 0 then bad_float () else
let c = Scanning.peek_char ib in
+ if Scanning.eof ib then bad_float () else
match c with
| '.' ->
let max = Scanning.store_char ib c max in
characters has been read.*)
let scan_string stp max ib =
let rec loop max =
- if max = 0 || Scanning.end_of_input ib then max else
- let c = Scanning.checked_peek_char ib in
+ if max = 0 then max else
+ let c = Scanning.peek_char ib in
+ if Scanning.eof ib then max else
if stp == [] then
match c with
| ' ' | '\t' | '\n' | '\r' -> max
| c -> loop (Scanning.store_char ib c max) else
- if List.mem c stp then max else
+ if List.memq c stp then Scanning.skip_char ib max else
loop (Scanning.store_char ib c max) in
- let max = loop max in
- check_char_in stp ib;
- max;;
+ loop max;;
(* Scan a char: peek strictly one character in the input, whatsoever. *)
let scan_char max ib =
(* Called when encountering '\\' as starter of a char.
Stops before the corresponding '\''. *)
let scan_backslash_char max ib =
- if max = 0 || Scanning.eof ib then bad_input "a char" else
+ if max = 0 then bad_input "a char" else
let c = Scanning.peek_char ib in
+ if Scanning.eof ib then bad_input "a char" else
match c with
| '\\' | '\'' | '"' | 'n' | 't' | 'b' | 'r' (* '"' helping Emacs *) ->
Scanning.store_char ib (char_for_backslash c) max
| '0' .. '9' as c ->
let get_digit () =
- Scanning.next_char ib;
- let c = Scanning.peek_char ib in
+ let c = Scanning.next_char ib in
match c with
| '0' .. '9' as c -> c
| c -> bad_input_escape c in
let scan_Char max ib =
let rec loop s max =
- if max = 0 || Scanning.eof ib then bad_input "a char" else
+ if max = 0 then bad_input "a char" else
let c = Scanning.checked_peek_char ib in
+ if Scanning.eof ib then bad_input "a char" else
match c, s with
- | '\'', 3 -> Scanning.next_char ib; loop 2 (max - 1)
- | '\'', 1 -> Scanning.next_char ib; max - 1
- | '\\', 2 -> Scanning.next_char ib;
- loop 1 (scan_backslash_char (max - 1) ib)
+ | '\'', 3 -> loop 2 (Scanning.ignore_char ib max)
+ | '\'', 1 -> Scanning.ignore_char ib max
+ | '\\', 2 -> loop 1 (scan_backslash_char (Scanning.ignore_char ib max) ib)
| c, 2 -> loop 1 (Scanning.store_char ib c max)
| c, _ -> bad_input_escape c in
loop 3 max;;
let scan_String max ib =
let rec loop s max =
- if max = 0 || Scanning.eof ib then bad_input "a string" else
+ if max = 0 then bad_input "a string" else
let c = Scanning.checked_peek_char ib in
+ if Scanning.eof ib then bad_input "a string" else
match c, s with
| '"', true (* '"' helping Emacs *) ->
- Scanning.next_char ib; loop false (max - 1)
+ loop false (Scanning.ignore_char ib max)
| '"', false (* '"' helping Emacs *) ->
- Scanning.next_char ib; max - 1
+ Scanning.ignore_char ib max
| '\\', false ->
- Scanning.next_char ib; skip_spaces true (max - 1)
+ skip_spaces true (Scanning.ignore_char ib max)
| c, false -> loop false (Scanning.store_char ib c max)
| c, _ -> bad_input_char c
and skip_spaces s max =
- if max = 0 || Scanning.eof ib then bad_input "a string" else
+ if max = 0 then bad_input "a string" else
let c = Scanning.checked_peek_char ib in
+ if Scanning.eof ib then bad_input "a string" else
match c, s with
| '\n', true
| ' ', false ->
- Scanning.next_char ib; skip_spaces false (max - 1)
+ skip_spaces false (Scanning.ignore_char ib max)
| '\\', false -> loop false max
| c, false -> loop false (Scanning.store_char ib c max)
| _, _ -> loop false (scan_backslash_char (max - 1) ib) in
loop true max;;
let scan_bool max ib =
- if max < 4 || Scanning.eof ib then bad_input "a boolean" else
+ if max < 4 then bad_input "a boolean" else
+ let c = Scanning.checked_peek_char ib in
+ if Scanning.eof ib then bad_input "a boolean" else
let m =
- match Scanning.checked_peek_char ib with
+ match c with
| 't' -> 4
| 'f' -> 5
- | _ -> 0 in
+ | _ -> bad_input "a boolean" in
scan_string [] (min max m) ib;;
(* Reading char sets in %[...] conversions. *)
let lim = String.length fmt - 1 in
let rec find_in_set j =
- if j > lim then bad_format fmt j fmt.[lim - 1] else
+ if j > lim then incomplete_format fmt else
match fmt.[j] with
| ']' -> j
| c -> find_in_set (j + 1)
and find_set i =
- if i > lim then bad_format fmt i fmt.[lim - 1] else
+ if i > lim then incomplete_format fmt else
match fmt.[i] with
| ']' -> find_in_set (i + 1)
| c -> find_in_set i in
- if i > lim then bad_format fmt i fmt.[lim - 1] else
+ if i > lim then incomplete_format fmt else
match fmt.[i] with
| '^' ->
let i = i + 1 in
let bit_not b = (lnot b) land 1;;
-(* Build the bit vector corresponding to a char set read in the format. *)
-let make_bv bit set =
+(* 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). *)
+let make_char_bit_vect bit set =
let r = make_range (bit_not bit) in
let lim = String.length set - 1 in
let rec loop bit rp i =
if i <= lim then
match set.[i] with
| '-' when rp ->
- (* if i = 0 then rp is false (since the initial call is loop bit false 0)
- hence i >= 1 and the following is safe. *)
+ (* if i = 0 then rp is false (since the initial call is
+ loop bit false 0). Hence i >= 1 and the following is safe. *)
let c1 = set.[i - 1] in
let i = i + 1 in
if i > lim then loop bit false (i - 1) else
(* Compute the predicate on chars corresponding to a char set. *)
let make_pred bit set stp =
- let r = make_bv bit set in
+ 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);;
let scan_chars_in_char_set stp char_set max ib =
let rec loop_pos1 cp1 max =
- let c = Scanning.cautious_peek_char ib in
- if max = 0 || Scanning.end_of_input ib then max else
+ if max = 0 then max else
+ let c = Scanning.peek_char ib in
+ if Scanning.eof ib then max else
if c == cp1
then loop_pos1 cp1 (Scanning.store_char ib c max)
else max
and loop_pos2 cp1 cp2 max =
- let c = Scanning.cautious_peek_char ib in
- if max = 0 || Scanning.end_of_input ib then max else
+ if max = 0 then max else
+ let c = Scanning.peek_char ib in
+ if Scanning.eof ib then max else
if c == cp1 || c == cp2
then loop_pos2 cp1 cp2 (Scanning.store_char ib c max)
else max
and loop_pos3 cp1 cp2 cp3 max =
- let c = Scanning.cautious_peek_char ib in
- if max = 0 || Scanning.end_of_input ib then max else
+ if max = 0 then max else
+ let c = Scanning.peek_char ib in
+ if Scanning.eof ib then max else
if c == cp1 || c == cp2 || c == cp3
then loop_pos3 cp1 cp2 cp3 (Scanning.store_char ib c max)
else max
and loop_neg1 cp1 max =
- let c = Scanning.cautious_peek_char ib in
- if max = 0 || Scanning.end_of_input ib then max else
+ if max = 0 then max else
+ let c = Scanning.peek_char ib in
+ if Scanning.eof ib then max else
if c != cp1
then loop_neg1 cp1 (Scanning.store_char ib c max)
else max
and loop_neg2 cp1 cp2 max =
- let c = Scanning.cautious_peek_char ib in
- if max = 0 || Scanning.end_of_input ib then max else
+ if max = 0 then max else
+ let c = Scanning.peek_char ib in
+ if Scanning.eof ib then max else
if c != cp1 && c != cp2
then loop_neg2 cp1 cp2 (Scanning.store_char ib c max)
else max
and loop_neg3 cp1 cp2 cp3 max =
- let c = Scanning.cautious_peek_char ib in
- if max = 0 || Scanning.end_of_input ib then max else
+ if max = 0 then max else
+ let c = Scanning.peek_char ib in
+ if Scanning.eof ib then max else
if c != cp1 && c != cp2 && c != cp3
then loop_neg3 cp1 cp2 cp3 (Scanning.store_char ib c max)
else max
and loop setp max =
- let c = Scanning.cautious_peek_char ib in
- if max = 0 || Scanning.end_of_input ib then max else
- if setp c == 1 then loop setp (Scanning.store_char ib c max) else
- max in
+ if max = 0 then max else
+ let c = Scanning.peek_char ib in
+ if Scanning.eof ib then max else
+ if setp c == 1
+ then loop setp (Scanning.store_char ib c max)
+ else max in
let max =
match char_set with
| 2 -> loop_neg2 set.[0] set.[1] max
| 3 when set.[1] != '-' -> loop_neg3 set.[0] set.[1] set.[2] max
| n -> loop (find_setp stp char_set) max end in
- check_char_in stp ib;
+ ignore_stoppers stp ib;
max;;
let get_count t ib =
| 'n' -> Scanning.char_count ib
| _ -> Scanning.token_count ib;;
-let skip_whites ib =
- let rec loop = function
- | ' ' | '\t' | '\n' | '\r' ->
- Scanning.next_char ib;
- if not (Scanning.eof ib) then loop (Scanning.peek_char ib)
- | _ -> () in
- if not (Scanning.eof ib) then
- loop (Scanning.cautious_peek_char ib);;
+let rec skip_whites ib =
+ let c = Scanning.peek_char ib in
+ if not (Scanning.eof ib) then begin
+ match c with
+ | ' ' | '\t' | '\n' | '\r' ->
+ Scanning.invalidate_current_char ib; skip_whites ib
+ | _ -> ()
+ end;;
+
+external format_to_string :
+ ('a, 'b, 'c, 'd) format4 -> string = "%identity";;
+external string_to_format :
+ string -> ('a, 'b, 'c, 'd) format4 = "%identity";;
(* The [kscanf] main scanning function.
It takes as arguments:
aborts and applies the scanning buffer and a string that explains
the error to the error handling function [ef] (the error continuation). *)
let kscanf ib ef fmt f =
- let fmt = string_of_format fmt in
+ let fmt = format_to_string fmt in
let lim = String.length fmt - 1 in
let return v = Obj.magic v () in
match fmt.[i] with
| ' ' -> skip_whites ib; scan_fmt f (i + 1)
| '%' ->
- if i > lim then bad_format fmt i '%' else
+ if i > lim then incomplete_format fmt else
scan_conversion false max_int f (i + 1)
- | '@' as t ->
+ | '@' ->
let i = i + 1 in
- if i > lim then bad_format fmt (i - 1) t else begin
+ if i > lim then incomplete_format fmt else begin
check_char ib fmt.[i];
scan_fmt f (i + 1) end
| c -> check_char ib c; scan_fmt f (i + 1)
and scan_conversion skip max f i =
let stack = if skip then no_stack else stack in
match fmt.[i] with
- | '%' as c ->
- check_char ib c; scan_fmt f (i + 1)
+ | '%' as conv ->
+ check_char ib conv; scan_fmt f (i + 1)
| 'c' when max = 0 ->
let c = Scanning.checked_peek_char ib in
scan_fmt (stack f c) (i + 1)
| 'c' | 'C' as conv ->
- if max <> 1 && max <> max_int then bad_format fmt i conv else
- let x =
+ if max <> 1 && max <> max_int then bad_conversion fmt i conv else
+ let _x =
if conv = 'c' then scan_char max ib else scan_Char max ib in
scan_fmt (stack f (token_char ib)) (i + 1)
| 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv ->
- let x = scan_int_conv conv max ib in
+ let _x = scan_int_conv conv max ib in
scan_fmt (stack f (token_int conv ib)) (i + 1)
| 'f' | 'g' | 'G' | 'e' | 'E' ->
- let x = scan_float max ib in
+ let _x = scan_float max ib in
scan_fmt (stack f (token_float ib)) (i + 1)
| 'F' ->
- let x = scan_Float max ib in
+ let _x = scan_Float max ib in
scan_fmt (stack f (token_float ib)) (i + 1)
| 's' ->
let i, stp = scan_fmt_stoppers (i + 1) in
- let x = scan_string stp max ib in
+ let _x = scan_string stp max ib in
scan_fmt (stack f (token_string ib)) (i + 1)
| '[' ->
let i, char_set = read_char_set fmt (i + 1) in
let i, stp = scan_fmt_stoppers (i + 1) in
- let x = scan_chars_in_char_set stp char_set max ib in
+ let _x = scan_chars_in_char_set stp char_set max ib in
scan_fmt (stack f (token_string ib)) (i + 1)
| 'S' ->
- let x = scan_String max ib in
+ let _x = scan_String max ib in
scan_fmt (stack f (token_string ib)) (i + 1)
| 'B' | 'b' ->
- let x = scan_bool max ib in
+ let _x = scan_bool max ib in
scan_fmt (stack f (token_bool ib)) (i + 1)
- | 'l' | 'n' | 'L' as t ->
+ | 'l' | 'n' | 'L' as conv ->
let i = i + 1 in
- if i > lim then scan_fmt (stack f (get_count t ib)) i else begin
+ if i > lim then scan_fmt (stack f (get_count conv ib)) i else begin
match fmt.[i] with
| 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv ->
- let x = scan_int_conv conv max ib in
- begin match t with
+ let _x = scan_int_conv conv max ib in
+ begin match conv with
| 'l' -> scan_fmt (stack f (token_int32 conv ib)) (i + 1)
- | 'L' -> scan_fmt (stack f (token_int64 conv ib)) (i + 1)
- | _ -> scan_fmt (stack f (token_nativeint conv ib)) (i + 1) end
- | c -> scan_fmt (stack f (get_count t ib)) i end
- | 'N' as t ->
- scan_fmt (stack f (get_count t ib)) (i + 1)
- | '!' as c ->
+ | 'n' -> scan_fmt (stack f (token_nativeint conv ib)) (i + 1)
+ | _ -> scan_fmt (stack f (token_int64 conv ib)) (i + 1) end
+ | c -> scan_fmt (stack f (get_count conv ib)) i end
+ | 'N' as conv ->
+ scan_fmt (stack f (get_count conv ib)) (i + 1)
+ | '!' ->
if Scanning.end_of_input ib then scan_fmt f (i + 1)
else bad_input "end of input not found"
| '_' ->
- if i > lim then bad_format fmt i fmt.[lim - 1] else
+ if i > lim then incomplete_format fmt else
scan_conversion true max f (i + 1)
- | '0' .. '9' as c ->
+ | '0' .. '9' as conv ->
let rec read_width accu i =
if i > lim then accu, i else
match fmt.[i] with
let accu = 10 * accu + int_value_of_char c in
read_width accu (i + 1)
| _ -> accu, i in
- let max, i = read_width (int_value_of_char c) (i + 1) in
- if i > lim then bad_format fmt i fmt.[lim - 1] else
- scan_conversion skip max f i
- | c -> bad_format fmt i c
+ let max, i = read_width (int_value_of_char conv) (i + 1) in
+ if i > lim then incomplete_format fmt else begin
+ match fmt.[i] with
+ | '.' ->
+ let p, i = read_width 0 (i + 1) in
+ scan_conversion skip (max + p + 1) f i
+ | _ -> scan_conversion skip max f i end
+ | '(' | '{' as conv ->
+ let i = succ i in
+ let j =
+ Printf.sub_format incomplete_format bad_conversion conv fmt i + 1 in
+ let mf = String.sub fmt i (j - i - 2) in
+ let _x = scan_String max ib in
+ let rf = token_string ib in
+ if not (compatible_format_type mf rf)
+ then format_mismatch rf mf ib else
+ if conv = '{' then scan_fmt (stack f rf) j else
+ let nf = scan_fmt (Obj.magic rf) 0 in
+ scan_fmt (stack f nf) j
+ | c -> bad_conversion fmt i c
and scan_fmt_stoppers i =
if i > lim then i - 1, [] else
match fmt.[i] with
| '@' when i < lim -> let i = i + 1 in i, [fmt.[i]]
- | '@' as c when i = lim -> bad_format fmt i c
+ | '@' when i = lim -> incomplete_format fmt
| _ -> i - 1, [] in
Scanning.reset_token ib;
let sscanf s = bscanf (Scanning.from_string s);;
let scanf fmt = bscanf Scanning.stdib fmt;;
+
+let bscanf_format ib fmt2 f =
+ let fmt1 = ignore (scan_String max_int ib); token_string ib in
+ let fmt2 = format_to_string fmt2 in
+ if compatible_format_type fmt1 fmt2
+ then let fresh_fmt = String.copy fmt1 in f (string_to_format fresh_fmt)
+ else format_mismatch fmt1 fmt2 ib;;
+
+let sscanf_format s fmt =
+ let fmt = format_to_string fmt in
+ if compatible_format_type s fmt
+ then let fresh_fmt = String.copy s in string_to_format fresh_fmt
+ else bad_input (format_mismatch_err s fmt);;
(* *)
(***********************************************************************)
-(* $Id: scanf.mli,v 1.45.6.3 2004/11/25 13:30:34 doligez Exp $ *)
+(* $Id: scanf.mli,v 1.58 2005/09/20 21:42:44 weis Exp $ *)
(** Formatted input functions. *)
an end-of-input condition by raising the exception [End_of_file]. *)
val from_channel : in_channel -> scanbuf;;
-(** [Scanning.from_channel inchan] returns a scanning buffer which reads
- one character at a time from the input channel [inchan], starting at the
+(** [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. *)
val end_of_input : scanbuf -> bool;;
-(** [Scanning.end_of_input scanbuf] tests the end of input condition
+(** [Scanning.end_of_input ib] tests the end-of-input condition
of the given buffer. *)
val beginning_of_input : scanbuf -> bool;;
-(** [Scanning.beginning_of_input scanbuf] tests the beginning of input
+(** [Scanning.beginning_of_input ib] tests the beginning of input
condition of the given buffer. *)
+val name_of_input : scanbuf -> string;;
+(** [Scanning.file_name_of_input ib] returns the name of the character
+ source for the input buffer [ib]. *)
+
end;;
exception Scan_failure of string;;
val bscanf :
Scanning.scanbuf -> ('a, Scanning.scanbuf, 'b) format -> 'a -> 'b;;
-(** [bscanf ib format f] reads tokens from the scanning buffer [ib] according
- to the format string [format], converts these tokens to values, and
+(** [bscanf ib fmt f] reads tokens from the scanning buffer [ib] according
+ to the format string [fmt], converts these tokens to values, and
applies the function [f] to these values.
The result of this application of [f] is the result of the whole construct.
For instance, if [p] is the function [fun s i -> i + 1], then
[Scanf.sscanf "x = 1" "%s = %i" p] returns [2].
- Raise [Scanf.Scan_failure] if the given 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 scanning
- and the input matches the given format so far.
-
The format is a character string which contains three types of
objects:
- plain characters, which are simply matched with the
- [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 (by default strings end with a space).
+ - [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
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 [^]). Returns a [string] that can be
- empty, if no character in the input matches the range. Hence,
- [\[0-9\]] returns a string representing a decimal number or an empty
- string if no decimal digit is found.
+ it, if the range starts with [^]). Reads a [string] that can be
+ empty, if no character in the input matches 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 [\]].
+ - [\{ 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]: applies [f] to the number of lines read so far.
- [n]: applies [f] to the number of characters read so far.
- - [N]: applies [f] to the number of tokens read so far.
+ - [N] or [L]: applies [f] to the number of tokens read so far.
- [!]: matches the end of input condition.
- [%]: matches one [%] character in the input.
The field widths are 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;
- and [%4f] reads a float with at most 4 characters.
+ [%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 less than 8 characters are available in the input).
- Scanning indications appear just after the string conversions [s] and
- [\[ range \]] to delimit the end of the token. A scanning
+ Scanning indications appear just after the string conversions [s]
+ and [\[ range \]] to delimit the end of the token. A scanning
indication is introduced by a [@] character, followed by some
constant character [c]. It means that the string token should end
just before the next matching [c] (which is skipped). If no [c]
character is encountered, the string token spreads as much as
possible. For instance, ["%s@\t"] reads a string up to the next
- tabulation character. If a scanning indication [\@c] does not
- follow a string conversion, it is ignored and treated as a plain
- [c] character.
+ tabulation 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 given input does not match the format.
+
+ Raise [Failure] if a conversion to a number is not possible.
+
+ Raise [End_of_file] if the end of input is encountered while some
+ more characters are needed to read the current conversion
+ specification (this means in particular that scanning a [%s]
+ conversion never raises exception [End_of_file]: if the end of
+ input is reached the conversion succeeds and simply returns [""]).
Notes:
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).
+ ['\@'] characters).
- in addition to relevant digits, ['_'] characters may appear
inside numbers (this is reminiscent to the usual Caml
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.
+ [ocamlyacc]-generated parsers.
*)
val fscanf : in_channel -> ('a, Scanning.scanbuf, 'b) format -> 'a -> 'b;;
some conversion fails, the scanning function aborts and applies the
error handling function [ef] to the scanning buffer and the
exception that aborted the scanning process. *)
+
+val bscanf_format :
+ Scanning.scanbuf -> ('a, 'b, 'c, 'd) format4 ->
+ (('a, 'b, 'c, 'd) format4 -> 'e) -> 'e;;
+(** [bscanf_format ib fmt f] reads a [format] argument to the format
+ specified by the second argument. The [format] argument read in
+ buffer [ib] must have the same type as [fmt]. *)
+
+val sscanf_format :
+ string -> ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4;;
+(** [sscanf_format ib fmt f] reads a [format] argument to the format
+ specified by the second argument and returns it. The [format]
+ argument read in string [s] must have the same type as [fmt]. *)
(* *)
(***********************************************************************)
-(* $Id: set.ml,v 1.18.4.1 2004/11/03 21:19:49 doligez Exp $ *)
+(* $Id: set.ml,v 1.19 2004/11/25 00:04:15 doligez Exp $ *)
(* Sets over ordered types *)
(* *)
(***********************************************************************)
-(* $Id: set.mli,v 1.32 2004/04/23 10:01:54 xleroy Exp $ *)
+(* $Id: set.mli,v 1.33 2005/07/21 14:52:45 doligez Exp $ *)
(** Sets over ordered types.
are purely applicative (no side-effects).
The implementation uses balanced binary trees, and is therefore
reasonably efficient: insertion and membership take time
- logarithmic in the size of the set, for instance.
+ logarithmic in the size of the set, for instance.
*)
-module type OrderedType =
+module type OrderedType =
sig
type t
(** The type of the set elements. *)
val exists: (elt -> bool) -> t -> bool
(** [exists p s] checks if at least one element of
the set satisfies the predicate [p]. *)
-
+
val filter: (elt -> bool) -> t -> t
(** [filter p s] returns the set of all elements in [s]
that satisfy predicate [p]. *)
(* *)
(***********************************************************************)
-(* $Id: sort.ml,v 1.9 2004/01/14 17:20:56 doligez Exp $ *)
+(* $Id: sort.ml,v 1.10 2005/10/25 18:34:07 doligez Exp $ *)
(* Merging and sorting *)
unsafe_set arr !j val_i
end
done
-
(* *)
(***********************************************************************)
-(* $Id: sort.mli,v 1.13 2001/12/07 13:40:58 xleroy Exp $ *)
+(* $Id: sort.mli,v 1.14 2005/10/25 18:34:07 doligez Exp $ *)
(** Sorting and merging lists.
predicate, [merge] returns a sorted list containing the elements
from the two lists. The behavior is undefined if the two
argument lists were not sorted. *)
-
(* *)
(***********************************************************************)
-(* $Id: stack.mli,v 1.18 2002/06/27 08:48:26 xleroy Exp $ *)
+(* $Id: stack.mli,v 1.19 2005/10/25 18:34:07 doligez Exp $ *)
(** Last-in first-out stacks.
- This module implements stacks (LIFOs), with in-place modification.
+ This module implements stacks (LIFOs), with in-place modification.
*)
type 'a t
(** [iter f s] applies [f] in turn to all elements of [s],
from the element at the top of the stack to the element at the
bottom of the stack. The stack itself is unchanged. *)
-
(* *)
(***********************************************************************)
-(* $Id: stdLabels.mli,v 1.11.2.1 2004/06/22 14:23:24 xleroy Exp $ *)
+(* $Id: stdLabels.mli,v 1.13 2004/11/25 00:04:15 doligez Exp $ *)
(** Standard labeled libraries.
(* *)
(***********************************************************************)
-(* $Id: stream.mli,v 1.24 2001/12/28 23:12:48 guesdon Exp $ *)
+(* $Id: stream.mli,v 1.25 2005/10/25 18:34:07 doligez Exp $ *)
(** Streams and parsers. *)
Warning: these functions create streams with fast access; it is illegal
to mix them with streams built with [[< >]]; would raise [Failure]
- when accessing such mixed streams.
+ when accessing such mixed streams.
*)
val from : (int -> 'a option) -> 'a t
(* *)
(***********************************************************************)
-(* $Id: string.mli,v 1.36.6.1 2004/11/03 21:17:18 doligez Exp $ *)
+(* $Id: string.mli,v 1.37 2004/11/25 00:04:15 doligez Exp $ *)
(** String operations. *)
(* *)
(***********************************************************************)
-(* $Id: stringLabels.mli,v 1.8.6.1 2004/06/22 14:23:25 xleroy Exp $ *)
+(* $Id: stringLabels.mli,v 1.10 2004/11/25 00:04:15 doligez Exp $ *)
(** String operations. *)
(* *)
(***********************************************************************)
-(* $Id: sys.ml,v 1.101.2.28 2005/08/11 15:29:25 doligez Exp $ *)
+(* $Id: sys.ml,v 1.138.2.1 2005/10/26 15:25:30 xleroy Exp $ *)
(* System interface *)
(* OCaml version string, must be in the format described in sys.mli. *)
-let ocaml_version = "3.08.4";;
+let ocaml_version = "3.09.0";;
(* *)
(***********************************************************************)
-(* $Id: sys.mli,v 1.45.4.1 2005/07/08 15:17:39 doligez Exp $ *)
+(* $Id: sys.mli,v 1.47 2005/10/25 18:34:07 doligez Exp $ *)
(** System interface. *)
(** Same as {!Sys.signal} but return value is ignored. *)
-(** {7 Signal numbers for the standard POSIX signals.} *)
+(** {7 Signal numbers for the standard POSIX signals.} *)
val sigabrt : int
(** Abnormal termination *)
val catch_break : bool -> unit
(** [catch_break] governs whether interactive interrupt (ctrl-C)
- terminates the program or raises the [Break] exception.
+ terminates the program or raises the [Break] exception.
Call [catch_break true] to enable raising [Break],
and [catch_break false] to let the system
terminate the program on user interrupt. *)
# #
#########################################################################
-# $Id: Makefile,v 1.59.2.1 2005/01/24 15:22:46 doligez Exp $
+# $Id: Makefile,v 1.61 2005/08/01 15:51:09 xleroy Exp $
include ../config/Makefile
clean::
rm -f ocamlmklib.ml
-# ocamlopt -pack support for Mac OS X: objcopy emulator
-
-install::
- $(BINUTILS_INSTALL_OBJCOPY) ocaml-objcopy-macosx $(BINUTILS_OBJCOPY)
-
# Converter olabl/ocaml 2.99 to ocaml 3
OCAML299TO3= lexer299.cmo ocaml299to3.cmo
(* *)
(***********************************************************************)
-(* $Id: depend.ml,v 1.7 2003/11/25 09:20:45 garrigue Exp $ *)
+(* $Id: depend.ml,v 1.9 2005/03/23 03:08:37 garrigue Exp $ *)
open Format
open Location
td.ptype_cstrs;
add_opt add_type bv td.ptype_manifest;
let rec add_tkind = function
- Ptype_abstract -> ()
+ Ptype_abstract | Ptype_private -> ()
| Ptype_variant (cstrs, _) ->
- List.iter (fun (c, args) -> List.iter (add_type bv) args) cstrs
+ List.iter (fun (c, args, _) -> List.iter (add_type bv) args) cstrs
| Ptype_record (lbls, _) ->
- List.iter (fun (l, mut, ty) -> add_type bv ty) lbls in
+ List.iter (fun (l, mut, ty, _) -> add_type bv ty) lbls in
add_tkind td.ptype_kind
let rec add_class_type bv cty =
(* *)
(***********************************************************************)
-(* $Id: dumpobj.ml,v 1.34 2004/05/26 11:10:52 garrigue Exp $ *)
+(* $Id: dumpobj.ml,v 1.35 2005/06/22 13:49:35 doligez Exp $ *)
(* Disassembler for executable and .cmo object files *)
| _ -> ()
let record_events orig evl =
- List.iter
+ List.iter
(fun ev ->
relocate_event orig ev;
Hashtbl.add event_table ev.ev_pos ev)
Const_base(Const_int i) -> printf "%d" i
| Const_base(Const_float f) -> print_float f
| Const_base(Const_string s) -> printf "%S" s
+ | Const_immstring s -> printf "%S" s
| Const_base(Const_char c) -> printf "%C" c
| Const_base(Const_int32 i) -> printf "%ldl" i
| Const_base(Const_nativeint i) -> printf "%ndn" i
done;
| Pubmet
-> let tag = inputs ic in
- let cache = inputu ic in
- print_int tag
+ let _cache = inputu ic in
+ print_int tag
| Nothing -> ()
with Not_found -> print_string "(unknown arguments)"
end;
done;
exit 0
-let _ = Printexc.catch main (); exit 0
+let _ = main ()
(* *)
(***********************************************************************)
-(* $Id: lexer299.mll,v 1.3 2004/03/10 08:56:01 garrigue Exp $ *)
+(* $Id: lexer299.mll,v 1.4 2005/06/22 13:52:36 doligez Exp $ *)
(* The lexer definition *)
{ let loc = { Location.loc_start = Lexing.lexeme_start_p lexbuf;
Location.loc_end = Lexing.lexeme_end_p lexbuf;
Location.loc_ghost = false }
- and warn = Warnings.Comment "the start of a comment"
in
- Location.prerr_warning loc warn;
+ Location.prerr_warning loc (Warnings.Comment_start);
comment_start_pos := [Lexing.lexeme_start lexbuf];
comment lexbuf;
token lexbuf
{ let loc = { Location.loc_start = Lexing.lexeme_start_p lexbuf;
Location.loc_end = Lexing.lexeme_end_p lexbuf;
Location.loc_ghost = false }
- and warn = Warnings.Comment "not the end of a comment"
in
- Location.prerr_warning loc warn;
+ Location.prerr_warning loc Warnings.Comment_not_end;
lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
STAR
}
(* *)
(***********************************************************************)
-(* $Id: lexer301.mll,v 1.4 2004/01/16 15:24:03 doligez Exp $ *)
+(* $Id: lexer301.mll,v 1.5 2004/11/30 18:57:04 doligez Exp $ *)
(* The lexer definition *)
token lexbuf }
| "(*)"
{ let loc = Location.curr lexbuf
- and warn = Warnings.Comment "the start of a comment"
+ and warn = Warnings.Comment_start
in
Location.prerr_warning loc warn;
comment_start_pos := [Lexing.lexeme_start lexbuf];
}
| "*)"
{ let loc = Location.curr lexbuf
- and warn = Warnings.Comment "not the end of a comment"
+ and warn = Warnings.Comment_not_end
in
Location.prerr_warning loc warn;
lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
# #
#########################################################################
-# $Id: make-package-macosx,v 1.8.4.3 2005/05/04 14:05:51 doligez Exp $
+# $Id: make-package-macosx,v 1.10 2005/08/13 20:59:37 doligez Exp $
cd package-macosx
rm -rf ocaml.pkg ocaml-rw.dmg
(* *)
(***********************************************************************)
-(* $Id: objinfo.ml,v 1.8 2000/03/27 12:18:09 xleroy Exp $ *)
+(* $Id: objinfo.ml,v 1.10 2005/06/22 12:45:55 doligez Exp $ *)
(* Dump a compilation unit description *)
done;
exit 0
-let _ = Printexc.catch main (); exit 0
-
-
+let _ = main ()
# #
#########################################################################
-# $Id: ocaml-objcopy-macosx,v 1.1.2.1 2005/01/25 13:13:52 doligez Exp $
+# $Id: ocaml-objcopy-macosx,v 1.1 2005/01/21 18:15:55 doligez Exp $
TEMP=/tmp/ocaml-objcopy-$$.o
(* *)
(***********************************************************************)
-(* $Id: ocamlcp.ml,v 1.37.6.1 2005/03/09 15:49:09 doligez Exp $ *)
+(* $Id: ocamlcp.ml,v 1.39 2005/05/09 13:39:17 doligez Exp $ *)
open Printf
let _cc s = option_with_arg "-cc" s
let _cclib s = option_with_arg "-cclib" s
let _ccopt s = option_with_arg "-ccopt" s
+ let _config = option "-config"
let _custom = option "-custom"
let _dllib = option_with_arg "-dllib"
let _dllpath = option_with_arg "-dllpath"
(* *)
(***********************************************************************)
-(* $Id: ocamldep.ml,v 1.33.4.1 2005/01/05 15:20:26 doligez Exp $ *)
+(* $Id: ocamldep.ml,v 1.36 2005/03/24 17:20:54 doligez Exp $ *)
open Format
open Location
let parse_use_file ic =
if is_ast_file ic Config.ast_impl_magic_number then
- let source_file = input_value ic in
+ let _source_file = input_value ic in
[Ptop_def (input_value ic : Parsetree.structure)]
else begin
seek_in ic 0;
let parse_interface ic =
if is_ast_file ic Config.ast_intf_magic_number then
- let source_file = input_value ic in
+ let _source_file = input_value ic in
(input_value ic : Parsetree.signature)
else begin
seek_in ic 0;
let usage = "Usage: ocamldep [-I <dir>] [-native] <files>"
+let print_version () =
+ printf "ocamldep, version %s@." Sys.ocaml_version;
+ exit 0;
+;;
+
let _ =
Clflags.classic := false;
add_to_load_path Filename.current_dir_name;
"-native", Arg.Set native_only,
" 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>";
"-slash", Arg.Set force_slash,
" (for Windows) Use forward slash / instead of backslash \\ in file paths";
- "-pp", Arg.String(fun s -> preprocessor := Some s),
- "<command> Pipe sources through preprocessor <command>"
+ "-version", Arg.Unit print_version,
+ " Print version and exit";
] file_dependencies usage;
exit (if !error_occurred then 2 else 0)
(* *)
(***********************************************************************)
-(* $Id: ocamlmklib.mlp,v 1.10.2.1 2004/07/08 06:45:51 garrigue Exp $ *)
+(* $Id: ocamlmklib.mlp,v 1.12 2004/11/27 01:04:19 doligez Exp $ *)
open Printf
exception Bad_argument of string
+let print_version () =
+ printf "ocamlmklib, version %s\n" Sys.ocaml_version;
+ exit 0;
+;;
+
let parse_arguments argv =
let i = ref 1 in
let next_arg () =
rpath := chop_prefix s "-Wl,-R" :: !rpath
else if s = "-v" || s = "-verbose" then
verbose := true
+ else if s = "-version" then
+ print_version ()
else if starts_with s "-F" then
c_opts := s :: !c_opts
else if s = "-framework" then
-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 =
(* *)
(***********************************************************************)
-(* $Id: ocamlprof.ml,v 1.37.2.1 2004/11/18 23:52:08 doligez Exp $ *)
+(* $Id: ocamlprof.ml,v 1.38 2005/03/24 17:20:54 doligez Exp $ *)
open Printf
(* *)
(***********************************************************************)
-(* $Id: primreq.ml,v 1.3 2000/03/27 12:18:09 xleroy Exp $ *)
+(* $Id: primreq.ml,v 1.4 2005/06/22 13:53:34 doligez Exp $ *)
(* Determine the set of C primitives required by the given .cmo and .cma
files *)
"Usage: primreq [options] <.cmo and .cma files>\nOptions are:";
if String.length !exclude_file > 0 then exclude !exclude_file;
StringSet.iter
- (fun s ->
+ (fun s ->
if s.[0] <> '%' then begin print_string s; print_newline() end)
!primitives;
exit 0
-let _ = Printexc.catch main (); exit 0
+let _ = main ()
(* *)
(***********************************************************************)
-(* $Id: profiling.ml,v 1.6.10.1 2004/11/18 23:52:08 doligez Exp $ *)
+(* $Id: profiling.ml,v 1.7 2005/03/24 17:20:54 doligez Exp $ *)
(* Run-time library for profiled programs *)
(* *)
(***********************************************************************)
-(* $Id: profiling.mli,v 1.5.10.1 2004/11/18 23:52:08 doligez Exp $ *)
+(* $Id: profiling.mli,v 1.6 2005/03/24 17:20:54 doligez Exp $ *)
(* Run-time library for profiled programs *)
(* *)
(***********************************************************************)
-(* $Id: genprintval.ml,v 1.37 2004/06/13 16:23:35 xleroy Exp $ *)
+(* $Id: genprintval.ml,v 1.38 2005/06/13 04:55:53 garrigue Exp $ *)
(* To print values *)
| (l, f) :: fields ->
if Btype.hash_variant l = tag then
match Btype.row_field_repr f with
- | Rpresent(Some ty) ->
+ | Rpresent(Some ty) | Reither(_,[ty],_,_) ->
let args =
tree_of_val (depth - 1) (O.field obj 1) ty in
Oval_variant (l, Some args)
(* *)
(***********************************************************************)
-(* $Id: topdirs.ml,v 1.62.2.1 2004/06/23 12:10:02 garrigue Exp $ *)
+(* $Id: topdirs.ml,v 1.64 2004/11/29 02:27:25 garrigue Exp $ *)
(* Toplevel directives *)
let v = eval_path path in
let print_function =
if is_old_style then
- (fun formatter repr -> (Obj.obj v) (Obj.obj repr))
+ (fun formatter repr -> Obj.obj v (Obj.obj repr))
else
- (fun formatter repr -> (Obj.obj v) formatter (Obj.obj repr)) in
+ (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in
install_printer path ty_arg print_function
with Exit -> ()
(* *)
(***********************************************************************)
-(* $Id: toploop.ml,v 1.87 2004/06/12 08:55:47 xleroy Exp $ *)
+(* $Id: toploop.ml,v 1.92 2005/08/08 09:41:51 xleroy Exp $ *)
(* The interactive toplevel loop *)
(* Print the outcome of an evaluation *)
-let pr_item env = function
+let rec pr_item env = function
| Tsig_value(id, decl) :: rem ->
let tree = Printtyp.tree_of_value_description id decl in
let valopt =
Some v
in
Some (tree, valopt, rem)
+ | Tsig_type(id, _, _) :: rem when Btype.is_row_name (Ident.name id) ->
+ pr_item env rem
| Tsig_type(id, decl, rs) :: rem ->
let tree = Printtyp.tree_of_type_declaration id decl rs in
Some (tree, None, rem)
let refill_lexbuf buffer len =
if !got_eof then (got_eof := false; 0) else begin
let prompt =
- if !first_line then "# "
+ if !Clflags.noprompt then ""
+ else if !first_line then "# "
else if Lexer.in_comment () then "* "
else " "
in
crc_intfs
let load_ocamlinit ppf =
- let home_init =
- try Filename.concat (Sys.getenv "HOME") ".ocamlinit"
- with Not_found -> ".ocamlinit" in
- if Sys.file_exists ".ocamlinit" then ignore(use_silently ppf ".ocamlinit")
- else if Sys.file_exists home_init then ignore(use_silently ppf home_init)
+ match !Clflags.init_file with
+ | Some f -> if Sys.file_exists f then ignore (use_silently ppf f)
+ else fprintf ppf "Init file not found: \"%s\".@." f
+ | None ->
+ if Sys.file_exists ".ocamlinit" then ignore (use_silently ppf ".ocamlinit")
+ else try
+ let home_init = Filename.concat (Sys.getenv "HOME") ".ocamlinit" in
+ if Sys.file_exists home_init then ignore (use_silently ppf home_init)
+ with Not_found -> ()
+;;
let set_paths () =
(* Add whatever -I options have been specified on the command line,
(* *)
(***********************************************************************)
-(* $Id: topmain.ml,v 1.34 2003/07/25 12:18:25 xleroy Exp $ *)
+(* $Id: topmain.ml,v 1.39 2005/01/28 17:52:58 doligez Exp $ *)
open Clflags
else exit 2
end
+let print_version () =
+ Printf.printf "The Objective Caml toplevel, version %s\n" Sys.ocaml_version;
+ exit 0;
+;;
+
let main () =
Arg.parse [
"-I", Arg.String(fun dir ->
let dir = Misc.expand_directory Config.standard_library dir in
include_dirs := dir :: !include_dirs),
"<dir> Add <dir> to the list of include directories";
+ "-init", Arg.String (fun s -> init_file := Some s),
+ "<file> Load <file> instead of default init file";
"-labels", Arg.Clear classic, " Labels commute (default)";
"-noassert", Arg.Set noassert, " Do not compile assertion checks";
"-nolabels", Arg.Set classic, " Ignore labels and do not commute";
+ "-noprompt", Arg.Set noprompt, " Suppress all prompts";
"-nostdlib", Arg.Set no_std_include,
" do not add default directory to the list of include directories";
"-principal", Arg.Set principal, " Check principality of type inference";
"-rectypes", Arg.Set recursive_types, " Allow arbitrary recursive types";
"-unsafe", Arg.Set fast, " No bound checking on array and string access";
+ "-version", Arg.Unit print_version, " Print version and exit";
"-w", Arg.String (Warnings.parse_options false),
"<flags> Enable or disable warnings according to <flags>:\n\
\032 A/a enable/disable all warnings\n\
\032 S/s enable/disable non-unit statement\n\
\032 U/u enable/disable unused match case\n\
\032 V/v enable/disable hidden instance variable\n\
+ \032 Y/y enable/disable suspicious unused variables\n\
+ \032 Z/z enable/disable all other unused variables\n\
\032 X/x enable/disable all other warnings\n\
- \032 default setting is \"Ale\"\n\
- \032 (all warnings but labels and fragile match enabled)";
+ \032 default setting is \"Aelz\"";
"-warn-error" , Arg.String (Warnings.parse_options true),
- "<flags> Enable or disable fatal warnings according to <flags>\n\
+ "<flags> Treat the warnings of <flags> as errors, if they are enabled.\n\
\032 (see option -w for the list of flags)\n\
\032 default setting is a (all warnings are non-fatal)";
(* *)
(***********************************************************************)
-(* $Id: btype.ml,v 1.35 2004/01/06 13:41:39 garrigue Exp $ *)
+(* $Id: btype.ml,v 1.37 2005/03/23 03:08:37 garrigue Exp $ *)
(* Basic operations on core types *)
if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
let proxy ty =
- let ty = repr ty in
- match ty.desc with
- | Tvariant row -> row_more row
+ let ty0 = repr ty in
+ match ty0.desc with
+ | Tvariant row when not (static_row row) ->
+ row_more row
| Tobject (ty, _) ->
let rec proxy_obj ty =
match ty.desc with
Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty
- | Tvar | Tnil | Tunivar -> ty
+ | Tvar | Tunivar | Tconstr _ -> ty
+ | Tnil -> ty0
| _ -> assert false
in proxy_obj ty
- | _ -> ty
+ | _ -> ty0
+
+(**** Utilities for private types ****)
+
+let has_constr_row t =
+ match (repr t).desc with
+ Tobject(t,_) ->
+ let rec check_row t =
+ match (repr t).desc with
+ Tfield(_,_,_,t) -> check_row t
+ | Tconstr _ -> true
+ | _ -> false
+ in check_row t
+ | Tvariant row ->
+ (match row_more row with {desc=Tconstr _} -> true | _ -> false)
+ | _ ->
+ false
+
+let is_row_name s =
+ let l = String.length s in
+ if l < 4 then false else String.sub s (l-4) 4 = "#row"
(**********************************)
row.row_fields;
match (repr row.row_more).desc with
Tvariant row -> iter_row f row
- | Tvar | Tnil | Tunivar | Tsubst _ ->
+ | Tvar | Tunivar | Tsubst _ | Tconstr _ ->
Misc.may (fun (_,l) -> List.iter f l) row.row_name;
List.iter f row.row_bound
| _ -> assert false
(* *)
(***********************************************************************)
-(* $Id: btype.mli,v 1.16 2004/01/06 13:41:39 garrigue Exp $ *)
+(* $Id: btype.mli,v 1.17 2005/03/23 03:08:37 garrigue Exp $ *)
(* Basic operations on core types *)
(* Return the proxy representative of the type: either itself
or a row variable *)
+(**** Utilities for private types ****)
+val has_constr_row: type_expr -> bool
+val is_row_name: string -> bool
+
(**** Utilities for type traversal ****)
val iter_type_expr: (type_expr -> unit) -> type_expr -> unit
(* *)
(***********************************************************************)
-(* $Id: ctype.ml,v 1.179.2.3 2005/07/11 07:49:09 garrigue Exp $ *)
+(* $Id: ctype.ml,v 1.197 2005/09/20 04:08:49 garrigue Exp $ *)
(* Operations on core types *)
(**** Check whether an object is open ****)
(* +++ Il faudra penser a eventuellement expanser l'abreviation *)
-let rec opened_object ty =
- match (repr ty).desc with
- Tobject (t, _) -> opened_object t
- | Tfield(_, _, _, t) -> opened_object t
+let rec object_row ty =
+ let ty = repr ty in
+ match ty.desc with
+ Tobject (t, _) -> object_row t
+ | Tfield(_, _, _, t) -> object_row t
+ | _ -> ty
+
+let opened_object ty =
+ match (object_row ty).desc with
| Tvar -> true
| Tunivar -> true
+ | Tconstr _ -> true
| _ -> false
(**** Close an object ****)
(**** Hiding of private methods ****)
let hide_private_methods ty =
- let (fl, _) = flatten_fields (object_fields ty) in
- List.iter
- (function (_, k, _) ->
- let k = field_kind_repr k in
- match k with
- Fvar r -> set_kind r Fabsent
- | _ -> ())
- fl
+ match (repr ty).desc with
+ Tobject (fi, nm) ->
+ nm := None;
+ let (fl, _) = flatten_fields fi in
+ List.iter
+ (function (_, k, _) ->
+ match field_kind_repr k with
+ Fvar r -> set_kind r Fabsent
+ | _ -> ())
+ fl
+ | _ ->
+ assert false
(*******************************)
let idx = ty.level in
if idx <> generic_level then begin
set_level ty generic_level;
- List.iter generalize_parents !(snd (Hashtbl.find graph idx))
+ List.iter generalize_parents !(snd (Hashtbl.find graph idx));
+ (* Special case for rows: must generalize the row variable *)
+ match ty.desc with
+ Tvariant row ->
+ let more = row_more row in
+ if more.level <> generic_level then generalize_parents more
+ | _ -> ()
end
in
(* If the row variable is not generic, we must keep it *)
let keep = more.level <> generic_level in
let more' =
- match more.desc with Tsubst ty -> ty
- | _ ->
+ match more.desc with
+ Tsubst ty -> ty
+ | Tconstr _ ->
+ if keep then save_desc more more.desc;
+ copy more
+ | Tvar | Tunivar ->
save_desc more more.desc;
if keep then more else newty more.desc
+ | _ -> assert false
in
(* Register new type first for recursion *)
more.desc <- Tsubst(newgenty(Ttuple[more';t]));
TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ));
List.iter (add_univar univ) inv.inv_parents
in
- TypeHash.iter
- (fun ty inv -> if ty.desc = Tunivar then add_univar ty inv)
+ TypeHash.iter (fun ty inv -> if ty.desc = Tunivar then add_univar ty inv)
inverted;
fun ty ->
try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty
-
+
let rec diff_list l1 l2 =
if l1 == l2 then [] else
match l1 with [] -> invalid_arg "Ctype.diff_list"
(* We shall really check the level on the row variable *)
let keep = more.desc = Tvar && more.level <> generic_level in
let more' = copy_rec more in
- let row = copy_row copy_rec fixed row keep more' in
+ let fixed' = fixed && (repr more').desc = Tvar in
+ let row = copy_row copy_rec fixed' row keep more' in
Tvariant row
| Tpoly (t1, tl) ->
let tl = List.map repr tl in
let ty = repr ty in
if ty == repr ty0 then raise Recursive_abbrev;
if not (List.memq ty !visited) then begin
- let level = ty.level in
visited := ty :: !visited;
match ty.desc with
Tconstr(p, args, abbrev) ->
(* Test the occurence of free univars in a type *)
(* that's way too expansive. Must do some kind of cacheing *)
-let occur_univar ty =
+let occur_univar env ty =
let visited = ref TypeMap.empty in
let rec occur_rec bound ty =
let ty = repr ty in
| Tpoly (ty, tyl) ->
let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
occur_rec bound ty
+ | Tconstr (_, [], _) -> ()
+ | Tconstr (p, tl, _) ->
+ begin try
+ let td = Env.find_type p env in
+ List.iter2
+ (fun t (pos,neg,_) -> if pos || neg then occur_rec bound t)
+ tl td.type_variance
+ with Not_found ->
+ List.iter (occur_rec bound) tl
+ end
| _ -> iter_type_expr (occur_rec bound) ty
in
try
with exn ->
unmark_type ty; raise exn
+(* Grouping univars by families according to their binders *)
+let add_univars =
+ List.fold_left (fun s (t,_) -> TypeSet.add (repr t) s)
+
+let get_univar_family univar_pairs univars =
+ if univars = [] then TypeSet.empty else
+ let rec insert s = function
+ cl1, (_::_ as cl2) ->
+ if List.exists (fun (t1,_) -> TypeSet.mem (repr t1) s) cl1 then
+ add_univars s cl2
+ else s
+ | _ -> s
+ in
+ let s = List.fold_right TypeSet.add univars TypeSet.empty in
+ List.fold_left insert s univar_pairs
+
+(* Whether a family of univars escapes from a type *)
+let univars_escape env univar_pairs vl ty =
+ let family = get_univar_family univar_pairs vl in
+ let visited = ref TypeSet.empty in
+ let rec occur t =
+ let t = repr t in
+ if TypeSet.mem t !visited then () else begin
+ visited := TypeSet.add t !visited;
+ match t.desc with
+ Tpoly (t, tl) ->
+ if List.exists (fun t -> TypeSet.mem (repr t) family) tl then ()
+ else occur t
+ | Tunivar ->
+ if TypeSet.mem t family then raise Occur
+ | Tconstr (_, [], _) -> ()
+ | Tconstr (p, tl, _) ->
+ begin try
+ let td = Env.find_type p env in
+ List.iter2 (fun t (pos,neg,_) -> if pos || neg then occur t)
+ tl td.type_variance
+ with Not_found ->
+ List.iter occur tl
+ end
+ | _ ->
+ iter_type_expr occur t
+ end
+ in
+ try occur ty; false with Occur -> true
+
+(* Wrapper checking that no variable escapes and updating univar_pairs *)
+let enter_poly env univar_pairs t1 tl1 t2 tl2 f =
+ let old_univars = !univar_pairs in
+ let known_univars =
+ List.fold_left (fun s (cl,_) -> add_univars s cl)
+ TypeSet.empty old_univars
+ in
+ let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
+ if List.exists (fun t -> TypeSet.mem t known_univars) tl1 &&
+ univars_escape env old_univars tl1 (newty(Tpoly(t2,tl2)))
+ || List.exists (fun t -> TypeSet.mem t known_univars) tl2 &&
+ univars_escape env old_univars tl2 (newty(Tpoly(t1,tl1)))
+ then raise (Unify []);
+ let cl1 = List.map (fun t -> t, ref None) tl1
+ and cl2 = List.map (fun t -> t, ref None) tl2 in
+ univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
+ try let res = f t1 t2 in univar_pairs := old_univars; res
+ with exn -> univar_pairs := old_univars; raise exn
+
let univar_pairs = ref []
| (Tconstr _, Tvar) when deep_occur t2 t1 ->
unify2 env t1 t2
| (Tvar, _) ->
- occur env t1 t2; occur_univar t2;
+ occur env t1 t2; occur_univar env t2;
update_level env t1.level t2;
link_type t1 t2
| (_, Tvar) ->
- occur env t2 t1; occur_univar t1;
+ occur env t2 t1; occur_univar env t1;
update_level env t2.level t1;
link_type t2 t1
| (Tunivar, Tunivar) ->
try
begin match (d1, d2) with
(Tvar, _) ->
- occur_univar t2
+ occur_univar env t2
| (_, Tvar) ->
let td1 = newgenty d1 in
occur env t2' td1;
- occur_univar td1;
+ occur_univar env td1;
if t1 == t1' then begin
(* The variable must be instantiated... *)
let ty = newty2 t1'.level d1 in
| (Tpoly (t1, []), Tpoly (t2, [])) ->
unify env t1 t2
| (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
- if List.length tl1 <> List.length tl2 then raise (Unify []);
- let old_univars = !univar_pairs in
- let cl1 = List.map (fun t -> t, ref None) tl1
- and cl2 = List.map (fun t -> t, ref None) tl2 in
- univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
- begin try
- unify env t1 t2;
- let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
- List.iter
- (fun t1 ->
- if List.memq t1 tl2 then () else
- try
- let t2 =
- List.find (fun t2 -> not (List.memq (repr t2) tl1)) tl2 in
- link_type t2 t1
- with Not_found -> assert false)
- tl1;
- univar_pairs := old_univars
- with exn ->
- univar_pairs := old_univars; raise exn
- end
+ enter_poly env univar_pairs t1 tl1 t2 tl2 (unify env)
| (_, _) ->
raise (Unify [])
end;
end;
let rm = row_more row in
if row.row_fixed then
- if row0.row_more == rm then () else begin
- link_type rm row0.row_more
- end
+ if row0.row_more == rm then () else
+ if rm.desc = Tvar then link_type rm row0.row_more else
+ unify env rm row0.row_more
else
let ty = newty2 generic_level (Tvariant {row0 with row_fields = rest}) in
update_level env rm.level ty;
raise (Unify ((mkvariant [l,f1] true,
mkvariant [l,f2] true) :: trace)))
pairs;
- (* Special case when there is only one field left *)
- if row0.row_closed then begin
- match filter_row_fields false (row_repr row1).row_fields with [l, fi] ->
- begin match row_field_repr fi with
- Reither(c, t1::tl, _, e) as f1 ->
- let f1' = Rpresent (Some t1) in
- set_row_field e f1';
- begin try
- if c then raise (Unify []);
- List.iter (unify env t1) tl
- with exn ->
- e := None;
- List.assoc l !undo := Some f1';
- raise exn
- end
- | Reither(true, [], _, e) ->
- set_row_field e (Rpresent None);
- | _ -> ()
- end
- | _ -> ()
- end
with exn ->
log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
end
unmark_type ty; raise (Unify [])
end;
(* also check for free univars *)
- occur_univar ty;
+ occur_univar env ty;
update_level env level ty
let rec moregen inst_nongen type_pairs env t1 t2 =
| (Tpoly (t1, []), Tpoly (t2, [])) ->
moregen inst_nongen type_pairs env t1 t2
| (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
- let old_univars = !univar_pairs in
- let cl1 = List.map (fun t -> t, ref None) tl1
- and cl2 = List.map (fun t -> t, ref None) tl2 in
- univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
- begin try
- moregen inst_nongen type_pairs env t1 t2;
- univar_pairs := old_univars
- with exn ->
- univar_pairs := old_univars; raise exn
- end
+ enter_poly env univar_pairs t1 tl1 t2 tl2
+ (moregen inst_nongen type_pairs env)
| (_, _) ->
raise (Unify [])
end
| (Tpoly (t1, []), Tpoly (t2, [])) ->
eqtype rename type_pairs subst env t1 t2
| (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
- let old_univars = !univar_pairs in
- let cl1 = List.map (fun t -> t, ref None) tl1
- and cl2 = List.map (fun t -> t, ref None) tl2 in
- univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
- begin try eqtype rename type_pairs subst env t1 t2
- with exn ->
- univar_pairs := old_univars;
- raise exn
- end;
- univar_pairs := old_univars
+ enter_poly env univar_pairs t1 tl1 t2 tl2
+ (eqtype rename type_pairs subst env)
| (Tunivar, Tunivar) ->
unify_univar t1 t2 !univar_pairs
| (_, _) ->
List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
and eqtype_fields rename type_pairs subst env ty1 ty2 =
- let (fields1, rest1) = flatten_fields ty1
- and (fields2, rest2) = flatten_fields ty2 in
+ let (fields2, rest2) = flatten_fields ty2 in
+ (* Try expansion, needed when called from Includecore.type_manifest *)
+ try match try_expand_head env rest2 with
+ {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2
+ | _ -> raise Cannot_expand
+ with Cannot_expand ->
+ let (fields1, rest1) = flatten_fields ty1 in
let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
eqtype rename type_pairs subst env rest1 rest2;
if (miss1 <> []) || (miss2 <> []) then raise (Unify []);
| _ -> raise (Unify [])
and eqtype_row rename type_pairs subst env row1 row2 =
+ (* Try expansion, needed when called from Includecore.type_manifest *)
+ try match try_expand_head env (row_more row2) with
+ {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2
+ | _ -> raise Cannot_expand
+ with Cannot_expand ->
let row1 = row_repr row1 and row2 = row_repr row2 in
let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
if row1.row_closed <> row2.row_closed
end
| None -> assert false
+let has_constr_row' env t =
+ has_constr_row (expand_abbrev env t)
+
let rec build_subtype env visited loops posi level t =
let t = repr t in
match t.desc with
let c = collect tlist' in
if c > Unchanged then (newty (Ttuple (List.map fst tlist')), c)
else (t, Unchanged)
- | Tconstr(p, tl, abbrev) when level > 0 && generic_abbrev env p ->
+ | Tconstr(p, tl, abbrev)
+ when level > 0 && generic_abbrev env p && not (has_constr_row' env t) ->
let t' = repr (expand_abbrev env t) in
let level' = pred_expand level in
begin try match t'.desc with
let visited = t :: visited in
begin try
let decl = Env.find_type p env in
- if level = 0 && generic_abbrev env p then warn := true;
+ if level = 0 && generic_abbrev env p && not (has_constr_row' env t)
+ then warn := true;
let tl' =
List.map2
(fun (co,cn,_) t ->
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 short = posi && List.length fields <= 1 in
let fields =
List.map
(fun (l,f as orig) -> match row_field_repr f with
Rpresent None ->
- if posi && not short then
+ if posi then
(l, Reither(true, [], false, ref None)), Unchanged
else
orig, Unchanged
| Rpresent(Some t) ->
let (t', c) = build_subtype env visited loops posi level' t in
- if posi && level > 0 && not short then begin
+ if posi && level > 0 then begin
bound := t' :: !bound;
(l, Reither(false, [t'], false, ref None)), c
end else
fields
in
let c = collect fields in
- if posi && short && c = Unchanged then (t, Unchanged) else
let row =
{ row_fields = List.map fst fields; row_more = newvar();
row_bound = !bound; row_closed = posi; row_fixed = false;
let rec subtype_rec env trace t1 t2 cstrs =
let t1 = repr t1 in
let t2 = repr t2 in
- if t1 == t2 then [] else
+ if t1 == t2 then cstrs else
begin try
TypePairs.find subtypes (t1, t2);
(trace, t1, t2, !univar_pairs)::cstrs
end
| (Tobject (f1, _), Tobject (f2, _))
- when opened_object f1 && opened_object f2 ->
+ when (object_row f1).desc = Tvar && (object_row f2).desc = Tvar ->
(* Same row variable implies same object. *)
(trace, t1, t2, !univar_pairs)::cstrs
| (Tobject (f1, _), Tobject (f2, _)) ->
subtype_fields env trace f1 f2 cstrs
| (Tvariant row1, Tvariant row2) ->
- let row1 = row_repr row1 and row2 = row_repr row2 in
begin try
- if not row1.row_closed then raise Exit;
- let r1, r2, pairs =
- merge_row_fields row1.row_fields row2.row_fields in
- if filter_row_fields false r1 <> [] then raise Exit;
- List.fold_left
- (fun cstrs (_,f1,f2) ->
- match row_field_repr f1, row_field_repr f2 with
- (Rpresent None|Reither(true,_,_,_)), Rpresent None ->
- cstrs
- | Rpresent(Some t1), Rpresent(Some t2) ->
- subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
- | Reither(false, t1::_, _, _), Rpresent(Some t2) ->
- subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
- | Rabsent, _ -> cstrs
- | _ -> raise Exit)
- cstrs pairs
+ subtype_row env trace row1 row2 cstrs
with Exit ->
(trace, t1, t2, !univar_pairs)::cstrs
end
| (Tpoly (u1, []), Tpoly (u2, [])) ->
subtype_rec env trace u1 u2 cstrs
- | (Tpoly (t1, tl1), Tpoly (t2,tl2)) ->
- let old_univars = !univar_pairs in
- let cl1 = List.map (fun t -> t, ref None) tl1
- and cl2 = List.map (fun t -> t, ref None) tl2 in
- univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
- let cstrs = subtype_rec env trace t1 t2 cstrs in
- univar_pairs := old_univars;
- cstrs
+ | (Tpoly (u1, tl1), Tpoly (u2,tl2)) ->
+ begin try
+ enter_poly env univar_pairs u1 tl1 u2 tl2
+ (fun t1 t2 -> subtype_rec env trace t1 t2 cstrs)
+ with Unify _ ->
+ (trace, t1, t2, !univar_pairs)::cstrs
+ end
| (_, _) ->
(trace, t1, t2, !univar_pairs)::cstrs
end
cstrs tl1 tl2
and subtype_fields env trace ty1 ty2 cstrs =
+ (* Assume that either rest1 or rest2 is not Tvar *)
let (fields1, rest1) = flatten_fields ty1 in
let (fields2, rest2) = flatten_fields ty2 in
let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
- (trace, rest1, build_fields (repr ty2).level miss2 (newvar ()),
- !univar_pairs)
- ::
- begin match rest2.desc with
- Tnil -> []
- | _ ->
- [trace, build_fields (repr ty1).level miss1 rest1, rest2, !univar_pairs]
- end
- @
- (List.fold_left
- (fun cstrs (_, k1, t1, k2, t2) ->
- (* Theses fields are always present *)
- subtype_rec env ((t1, t2)::trace) t1 t2 cstrs)
- cstrs pairs)
+ let cstrs =
+ if rest2.desc = Tnil then cstrs else
+ if miss1 = [] then
+ subtype_rec env ((rest1, rest2)::trace) rest1 rest2 cstrs
+ else
+ (trace, build_fields (repr ty1).level miss1 rest1, rest2,
+ !univar_pairs) :: cstrs
+ in
+ let cstrs =
+ if miss2 = [] then cstrs else
+ (trace, rest1, build_fields (repr ty2).level miss2 (newvar ()),
+ !univar_pairs) :: cstrs
+ in
+ List.fold_left
+ (fun cstrs (_, k1, t1, k2, t2) ->
+ (* Theses fields are always present *)
+ subtype_rec env ((t1, t2)::trace) t1 t2 cstrs)
+ cstrs pairs
+
+and subtype_row env trace row1 row2 cstrs =
+ let row1 = row_repr row1 and row2 = row_repr row2 in
+ let r1, r2, pairs =
+ merge_row_fields row1.row_fields row2.row_fields in
+ let more1 = repr row1.row_more
+ and more2 = repr row2.row_more in
+ match more1.desc, more2.desc with
+ Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 ->
+ subtype_rec env ((more1,more2)::trace) more1 more2 cstrs
+ | (Tvar|Tconstr _), (Tvar|Tconstr _)
+ when row1.row_closed && r1 = [] ->
+ List.fold_left
+ (fun cstrs (_,f1,f2) ->
+ match row_field_repr f1, row_field_repr f2 with
+ (Rpresent None|Reither(true,_,_,_)), Rpresent None ->
+ cstrs
+ | Rpresent(Some t1), Rpresent(Some t2) ->
+ subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
+ | Reither(false, t1::_, _, _), Rpresent(Some t2) ->
+ subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
+ | Rabsent, _ -> cstrs
+ | _ -> raise Exit)
+ cstrs pairs
+ | Tunivar, Tunivar
+ when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] ->
+ let cstrs =
+ subtype_rec env ((more1,more2)::trace) more1 more2 cstrs in
+ List.fold_left
+ (fun cstrs (_,f1,f2) ->
+ match row_field_repr f1, row_field_repr f2 with
+ Rpresent None, Rpresent None
+ | Reither(true,[],_,_), Reither(true,[],_,_)
+ | Rabsent, Rabsent ->
+ cstrs
+ | Rpresent(Some t1), Rpresent(Some t2)
+ | Reither(false,[t1],_,_), Reither(false,[t2],_,_) ->
+ subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
+ | _ -> raise Exit)
+ cstrs pairs
+ | _ ->
+ raise Exit
let subtype env ty1 ty2 =
TypePairs.clear subtypes;
newty2 ty.level ty.desc
| Tunivar ->
ty
+ | Tconstr _ ->
+ newty2 ty.level Tvar
| _ ->
assert false
then tyl else ty::tyl)
[ty] tyl
in
- if List.length tyl' < List.length tyl + 1 then
+ if List.length tyl' <= List.length tyl then
let f = Reither(b, List.rev tyl', m, ref None) in
set_row_field e f;
f
assert (not (Path.isfree id decl.cty_path));
let decl =
{ cty_params = List.map (nondep_type_rec env id) decl.cty_params;
+ cty_variance = decl.cty_variance;
cty_type = nondep_class_type env id decl.cty_type;
cty_path = decl.cty_path;
cty_new =
assert (not (Path.isfree id decl.clty_path));
let decl =
{ clty_params = List.map (nondep_type_rec env id) decl.clty_params;
+ clty_variance = decl.clty_variance;
clty_type = nondep_class_type env id decl.clty_type;
clty_path = decl.clty_path }
in
(* *)
(***********************************************************************)
-(* $Id: ctype.mli,v 1.52.8.1 2004/12/09 07:36:31 garrigue Exp $ *)
+(* $Id: ctype.mli,v 1.53 2004/12/09 12:40:53 garrigue Exp $ *)
(* Operations on core types *)
(* *)
(***********************************************************************)
-(* $Id: env.ml,v 1.54.2.1 2005/07/27 15:05:05 xleroy Exp $ *)
+(* $Id: env.ml,v 1.56 2005/08/13 20:59:37 doligez Exp $ *)
(* Environment handling *)
ref ((fun env mty1 path1 mty2 -> assert false) :
t -> module_type -> Path.t -> module_type -> unit)
+(* The name of the compilation unit currently compiled.
+ "" if outside a compilation unit. *)
+
+let current_unit = ref ""
+
(* Persistent structure descriptions *)
type pers_struct =
with Not_found ->
read_pers_struct name (find_in_path_uncap !load_path (name ^ ".cmi"))
-let reset_cache() =
+let reset_cache () =
+ current_unit := "";
Hashtbl.clear persistent_structures;
Consistbl.clear crc_units
+let set_unit_name name =
+ current_unit := name
+
(* Lookup by identifier *)
let rec find_module_descr path env =
begin try
Ident.find_name s env.components
with Not_found ->
+ if s = !current_unit then raise Not_found;
let ps = find_pers_struct s in
(Pident(Ident.create_persistent s), ps.ps_comps)
end
begin try
Ident.find_name s env.modules
with Not_found ->
+ if s = !current_unit then raise Not_found;
let ps = find_pers_struct s in
(Pident(Ident.create_persistent s), Tmty_signature ps.ps_sig)
end
(* *)
(***********************************************************************)
-(* $Id: env.mli,v 1.28.8.1 2005/07/27 15:05:06 xleroy Exp $ *)
+(* $Id: env.mli,v 1.30 2005/08/13 20:59:37 doligez Exp $ *)
(* Environment handling *)
val enter_class: string -> class_declaration -> t -> Ident.t * t
val enter_cltype: string -> cltype_declaration -> t -> Ident.t * t
-(* Reset the cache of in-core module interfaces.
- To be called in particular when load_path changes. *)
-
+(* Initialize the cache of in-core module interfaces. *)
val reset_cache: unit -> unit
+(* Remember the name of the current compilation unit. *)
+val set_unit_name: string -> unit
+
(* Read, save a signature to/from a file *)
val read_signature: string -> string -> signature
(* *)
(***********************************************************************)
-(* $Id: includecore.ml,v 1.29 2003/07/02 09:14:33 xleroy Exp $ *)
+(* $Id: includecore.ml,v 1.32 2005/08/08 05:40:52 garrigue Exp $ *)
(* Inclusion checks for the core language *)
let private_flags priv1 priv2 =
match (priv1, priv2) with (Private, Public) -> false | (_, _) -> true
+(* Inclusion between manifest types (particularly for private row types) *)
+
+let is_absrow env ty =
+ match ty.desc with
+ Tconstr(Pident id, _, _) ->
+ begin match Ctype.expand_head env ty with
+ {desc=Tobject _|Tvariant _} -> true
+ | _ -> false
+ end
+ | _ -> false
+
+let type_manifest env ty1 params1 ty2 params2 =
+ let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in
+ match ty1'.desc, ty2'.desc with
+ 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) &&
+ let r1, r2, pairs =
+ Ctype.merge_row_fields row1.row_fields row2.row_fields in
+ (not row2.row_closed ||
+ row1.row_closed && Ctype.filter_row_fields false r1 = []) &&
+ List.for_all
+ (fun (_,f) -> match Btype.row_field_repr f with
+ Rabsent | Reither _ -> true | Rpresent _ -> false)
+ r2 &&
+ let to_equal = ref (List.combine params1 params2) in
+ List.for_all
+ (fun (_, f1, f2) ->
+ match Btype.row_field_repr f1, Btype.row_field_repr f2 with
+ Rpresent(Some t1),
+ (Rpresent(Some t2) | Reither(false, [t2], _, _)) ->
+ to_equal := (t1,t2) :: !to_equal; true
+ | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true
+ | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_)
+ when List.length tl1 = List.length tl2 && c1 = c2 ->
+ to_equal := List.combine tl1 tl2 @ !to_equal; true
+ | Rabsent, (Reither _ | Rabsent) -> true
+ | _ -> false)
+ pairs &&
+ let tl1, tl2 = List.split !to_equal in
+ Ctype.equal env true tl1 tl2
+ | Tobject (fi1, _), Tobject (fi2, _)
+ when is_absrow env (snd(Ctype.flatten_fields fi2)) ->
+ let (fields2,rest2) = Ctype.flatten_fields fi2 in
+ Ctype.equal env true (ty1::params1) (rest2::params2) &&
+ let (fields1,rest1) = Ctype.flatten_fields fi1 in
+ (match rest1 with {desc=Tnil|Tvar|Tconstr _} -> true | _ -> false) &&
+ let pairs, miss1, miss2 = Ctype.associate_fields fields1 fields2 in
+ miss2 = [] &&
+ 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 =
(_, None) ->
Ctype.equal env true decl1.type_params decl2.type_params
| (Some ty1, Some ty2) ->
- Ctype.equal env true (ty1::decl1.type_params)
- (ty2::decl2.type_params)
+ type_manifest env ty1 decl1.type_params ty2 decl2.type_params
| (None, Some ty2) ->
let ty1 =
Btype.newgenty (Tconstr(Pident id, decl2.type_params, ref Mnil))
Ctype.equal env true decl1.type_params decl2.type_params &&
Ctype.equal env false [ty1] [ty2]
end &&
- begin decl2.type_kind <> Type_abstract || decl2.type_manifest <> None ||
- List.for_all2
- (fun (co1,cn1,ct1) (co2,cn2,ct2) -> (not co1 || co2) && (not cn1 || cn2))
- decl1.type_variance decl2.type_variance
- end
+ if match decl2.type_kind with
+ | Type_record(_,_,priv) | Type_variant(_,priv) -> priv = Private
+ | Type_abstract ->
+ match decl2.type_manifest with None -> true
+ | Some ty -> Btype.has_constr_row (Ctype.expand_head env ty)
+ then
+ List.for_all2
+ (fun (co1,cn1,ct1) (co2,cn2,ct2) -> (not co1 || co2) && (not cn1 || cn2))
+ decl1.type_variance decl2.type_variance
+ else true
(* Inclusion between exception declarations *)
(* *)
(***********************************************************************)
-(* $Id: includemod.ml,v 1.34.2.1 2005/07/27 15:05:06 xleroy Exp $ *)
+(* $Id: includemod.ml,v 1.37 2005/08/13 20:59:37 doligez Exp $ *)
(* Inclusion checks for the module language *)
(* Simplify a structure coercion *)
-let simplify_structure_coercion init_size cc =
+let simplify_structure_coercion cc =
let rec is_identity_coercion pos = function
| [] ->
- pos = init_size
+ true
| (n, c) :: rem ->
n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem in
if is_identity_coercion 0 cc
(* Build a table of the components of sig1, along with their positions.
The table is indexed by kind and name of component *)
let rec build_component_table pos tbl = function
- [] -> (tbl, pos)
+ [] -> tbl
| item :: rem ->
let (id, name) = item_ident_name item in
let nextpos =
| Tsig_class(_, _,_) -> pos+1 in
build_component_table nextpos
(Tbl.add name (id, item, pos) tbl) rem in
- let (comps1, size1) =
+ let comps1 =
build_component_table 0 Tbl.empty sig1 in
(* Pair each component of sig2 with a component of sig1,
identifying the names along the way.
end
| 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
+ l >= 4 && String.sub s (l-4) 4 = "#row" ->
+ (* Do not report in case of failure,
+ as the main type will generate an error *)
+ Field_type (String.sub s 0 (String.length s - 4)), false
+ | _ -> name2, true
+ in
begin try
let (id1, item1, pos1) = Tbl.find name2 comps1 in
let new_subst =
pair_components new_subst
((item1, item2, pos1) :: paired) unpaired rem
with Not_found ->
- pair_components subst paired (Missing_field id2 :: unpaired) rem
+ let unpaired =
+ if report then Missing_field id2 :: unpaired else unpaired in
+ pair_components subst paired unpaired rem
end in
(* Do the pairing and checking, and return the final coercion *)
- simplify_structure_coercion size1 (pair_components subst [] [] sig2)
+ simplify_structure_coercion (pair_components subst [] [] sig2)
(* Inclusion between signature components *)
(* *)
(***********************************************************************)
-(* $Id: mtype.ml,v 1.25 2004/06/12 08:55:47 xleroy Exp $ *)
+(* $Id: mtype.ml,v 1.26 2005/09/28 07:18:30 garrigue Exp $ *)
(* Operations on module types *)
| Tsig_type(id, decl, rs) :: rem ->
let newdecl =
match decl.type_manifest with
- None ->
+ Some ty when not (Btype.has_constr_row ty) -> decl
+ | _ ->
{ decl with type_manifest =
Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos),
decl.type_params, ref Mnil))) }
- | _ -> decl in
+ in
Tsig_type(id, newdecl, rs) :: strengthen_sig env rem p
| (Tsig_exception(id, d) as sigelt) :: rem ->
sigelt :: strengthen_sig env rem p
(* *)
(***********************************************************************)
-(* $Id: oprint.ml,v 1.19 2004/06/12 08:55:47 xleroy Exp $ *)
+(* $Id: oprint.ml,v 1.22 2005/03/23 03:08:37 garrigue Exp $ *)
open Format
open Outcometree
(* Class types *)
+let type_parameter ppf (ty, (co, cn)) =
+ fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "")
+ ty
+
let print_out_class_params ppf =
function
[] -> ()
| tyl ->
fprintf ppf "@[<1>[%a]@]@ "
- (print_list (fun ppf x -> fprintf ppf "'%s" x)
- (fun ppf -> fprintf ppf ", "))
+ (print_list type_parameter (fun ppf -> fprintf ppf ", "))
tyl
let rec print_out_class_type ppf =
fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name !out_type
ty pr_prims prims
-and print_out_type_decl kwd ppf (name, args, ty, constraints) =
+and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) =
let print_constraints ppf params =
List.iter
(fun (ty1, ty2) ->
!out_type ty2)
params
in
- let type_parameter ppf (ty, (co, cn)) =
- fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "")
- ty
- in
let type_defined ppf =
match args with
[] -> fprintf ppf "%s" name
let print_private ppf = function
Asttypes.Private -> fprintf ppf "private "
| Asttypes.Public -> () in
- let rec print_out_tkind = function
- | Otyp_abstract ->
- fprintf ppf "@[<2>@[<hv 2>%t@]%a@]" print_name_args print_constraints
- constraints
- | Otyp_record (lbls, priv) ->
- fprintf ppf "@[<2>@[<hv 2>%t = %a{%a@;<1 -2>}@]%a@]" print_name_args
+ let rec print_out_tkind ppf = function
+ | Otyp_abstract -> ()
+ | Otyp_record lbls ->
+ fprintf ppf " = %a{%a@;<1 -2>}"
print_private priv
(print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
- print_constraints constraints
- | Otyp_sum (constrs, priv) ->
- fprintf ppf "@[<2>@[<hv 2>%t =@;<1 2>%a%a@]%a@]" print_name_args
+ | Otyp_sum constrs ->
+ fprintf ppf " =@;<1 2>%a%a"
print_private priv
(print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
- print_constraints constraints
| ty ->
- fprintf ppf "@[<2>@[<hv 2>%t =@ %a@]%a@]" print_name_args !out_type
- ty print_constraints constraints in
- print_out_tkind ty
+ fprintf ppf " =@;<1 2>%a%a"
+ print_private priv
+ !out_type ty
+ in
+ fprintf ppf "@[<2>@[<hv 2>%t%a@]%a@]"
+ print_name_args
+ print_out_tkind ty
+ print_constraints constraints
and print_out_constr ppf (name, tyl) =
match tyl with
[] -> fprintf ppf "%s" name
(* *)
(***********************************************************************)
-(* $Id: outcometree.mli,v 1.12 2004/06/12 08:55:48 xleroy Exp $ *)
+(* $Id: outcometree.mli,v 1.14 2005/03/23 03:08:37 garrigue Exp $ *)
(* Module [Outcometree]: results displayed by the toplevel *)
| Otyp_constr of out_ident * out_type list
| Otyp_manifest of out_type * out_type
| Otyp_object of (string * out_type) list * bool option
- | Otyp_record of (string * bool * out_type) list * Asttypes.private_flag
+ | Otyp_record of (string * bool * out_type) list
| Otyp_stuff of string
- | Otyp_sum of (string * out_type list) list * Asttypes.private_flag
+ | Otyp_sum of (string * out_type list) list
| Otyp_tuple of out_type list
| Otyp_var of bool * string
| Otyp_variant of
| Omty_signature of out_sig_item list
and out_sig_item =
| Osig_class of
- bool * string * string list * out_class_type * out_rec_status
+ bool * string * (string * (bool * bool)) list * out_class_type *
+ out_rec_status
| Osig_class_type of
- bool * string * string list * out_class_type * out_rec_status
+ bool * string * (string * (bool * bool)) list * out_class_type *
+ out_rec_status
| Osig_exception of string * out_type list
| Osig_modtype of string * out_module_type
| Osig_module of string * out_module_type * out_rec_status
| Osig_type of out_type_decl * out_rec_status
| Osig_value of string * out_type * string list
and out_type_decl =
- string * (string * (bool * bool)) list * out_type *
+ string * (string * (bool * bool)) list * out_type * Asttypes.private_flag *
(out_type * out_type) list
and out_rec_status =
| Orec_not
(* *)
(***********************************************************************)
-(* $Id: parmatch.ml,v 1.65.8.1 2005/02/02 06:57:53 garrigue Exp $ *)
+(* $Id: parmatch.ml,v 1.70 2005/03/24 17:20:54 doligez Exp $ *)
(* Detection of partial matches and unused match cases. *)
| _,_ ->
fatal_error "Parmatch.read_args"
-let set_args q r = match q with
+let do_set_args erase_mutable q r = match q with
| {pat_desc = Tpat_tuple omegas} ->
let args,rest = read_args omegas r in
make_pat (Tpat_tuple args) q.pat_type q.pat_env::rest
let args,rest = read_args omegas r in
make_pat
(Tpat_record
- (List.map2 (fun (lbl,_) arg -> lbl,arg) omegas args))
+ (List.map2 (fun (lbl,_) arg ->
+ if
+ erase_mutable &&
+ (match lbl.lbl_mut with
+ | Mutable -> true | Immutable -> false)
+ then
+ lbl, omega
+ else
+ lbl,arg)
+ omegas args))
q.pat_type q.pat_env::
rest
| {pat_desc = Tpat_construct (c,omegas)} ->
q::r (* case any is used in matching.ml *)
| _ -> fatal_error "Parmatch.set_args"
+let set_args q r = do_set_args false q r
+and set_args_erase_mutable q r = do_set_args true q r
(* filter pss acording to pattern q *)
let filter_one q pss =
*)
let build_other env = match env with
-| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _} as c,_)},_) as p
+| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _} as c,_)},_)
::_ ->
make_pat
(Tpat_construct
*)
begin match casel with
| [] -> ()
- | _ ->
- Location.prerr_warning loc
- (Warnings.Other
- "Bad style, all clauses in this pattern-matching are guarded.")
+ | _ -> Location.prerr_warning loc Warnings.All_clauses_guarded
end ;
Partial
| ps::_ ->
if Warnings.is_active Warnings.Unused_match then
let rec do_rec pref = function
| [] -> ()
- | (q,act as clause)::rem ->
+ | (q,act)::rem ->
let qs = [q] in
begin try
let pss =
ps
| Used ->
check_used_extra pss qs
- with e -> (* useless ? *)
- Location.prerr_warning (location_of_clause qs)
- (Warnings.Other "Fatal Error in Parmatch.check_unused") ;
- raise e
+ with e -> assert false
end ;
if has_guard act then
(* *)
(***********************************************************************)
-(* $Id: parmatch.mli,v 1.9 2003/08/18 08:26:18 garrigue Exp $ *)
+(* $Id: parmatch.mli,v 1.10 2005/03/11 10:12:05 maranget Exp $ *)
(* Detection of partial matches and unused match cases. *)
open Types
val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list
+(* Those to functions recombine one pattern and its arguments:
+ For instance:
+ (_,_)::p1::p2::rem -> (p1, p2)::rem
+ The second one will replace mutable arguments by '_'
+*)
val set_args : pattern -> pattern list -> pattern list
+val set_args_erase_mutable : pattern -> pattern list -> pattern list
val pat_of_constr : pattern -> constructor_description -> pattern
val complete_constrs :
(* *)
(***********************************************************************)
-(* $Id: printtyp.ml,v 1.130.2.3 2005/04/15 08:16:41 garrigue Exp $ *)
+(* $Id: printtyp.ml,v 1.139 2005/08/16 00:48:56 garrigue Exp $ *)
(* Printing functions *)
let delayed = ref ([] : type_expr list)
let add_delayed t =
- if not (List.mem_assq t !names) then delayed := t :: !delayed
+ if not (List.memq t !delayed) then delayed := t :: !delayed
let is_aliased ty = List.memq (proxy ty) !aliased
let add_alias ty =
let tyl = List.map repr tyl in
(* let tyl = List.filter is_aliased tyl in *)
if tyl = [] then tree_of_typexp sch ty else begin
+ let old_delayed = !delayed in
List.iter add_delayed tyl;
let tl = List.map name_of_type tyl in
- Otyp_poly (tl, tree_of_typexp sch ty)
+ let tr = Otyp_poly (tl, tree_of_typexp sch ty) in
+ delayed := old_delayed; tr
end
| Tunivar ->
Otyp_var (false, name_of_type ty)
let rest =
match rest.desc with
| Tvar | Tunivar -> Some (is_non_gen sch rest)
+ | Tconstr _ -> Some false
| Tnil -> None
| _ -> fatal_error "typfields (1)"
in
| _ -> "?"
in
let type_defined decl =
- if List.exists2
- (fun ty x -> x <> (true,true,true) &&
- (decl.type_kind = Type_abstract && ty_manifest = None
- || (repr ty).desc <> Tvar))
+ let abstr =
+ match decl.type_kind with
+ Type_abstract ->
+ begin match decl.type_manifest with
+ None -> true
+ | Some ty -> has_constr_row ty
+ end
+ | Type_variant(_,p) | Type_record(_,_,p) ->
+ p = Private
+ in
+ let vari =
+ List.map2
+ (fun ty (co,cn,ct) ->
+ if abstr || (repr ty).desc <> Tvar then (co,cn) else (true,true))
decl.type_params decl.type_variance
- then
- let vari = List.map (fun (co,cn,ct) -> (co,cn)) decl.type_variance in
- (Ident.name id,
- List.combine
- (List.map (fun ty -> type_param (tree_of_typexp false ty)) params)
- vari)
- else
- let ty =
- tree_of_typexp false
- (Btype.newgenty (Tconstr(Pident id, params, ref Mnil)))
- in
- match ty with
- | Otyp_constr (Oide_ident id, tyl) ->
- (id, List.map (fun ty -> (type_param ty, (true, true))) tyl)
- | _ -> ("?", [])
+ in
+ (Ident.name id,
+ List.map2 (fun ty cocn -> type_param (tree_of_typexp false ty), cocn)
+ params vari)
in
let tree_of_manifest ty1 =
match ty_manifest with
in
let (name, args) = type_defined decl in
let constraints = tree_of_constraints params in
- let ty =
+ let ty, priv =
match decl.type_kind with
| Type_abstract ->
begin match ty_manifest with
- | None -> Otyp_abstract
- | Some ty -> tree_of_typexp false ty
+ | None -> (Otyp_abstract, Public)
+ | Some ty ->
+ tree_of_typexp false ty,
+ (if has_constr_row ty then Private else Public)
end
| Type_variant(cstrs, priv) ->
- tree_of_manifest (Otyp_sum (List.map tree_of_constructor 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))
+ tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), priv
in
- (name, args, ty, constraints)
+ (name, args, ty, priv, constraints)
and tree_of_constructor (name, args) =
(name, tree_of_typlist false args)
in
let all_vars =
Vars.fold (fun l (m, t) all -> (l, m, t) :: all) sign.cty_vars [] in
+ (* Consequence of PR#3607: order of Map.fold has changed! *)
+ let all_vars = List.rev all_vars in
let csil =
List.fold_left
(fun csil (l, m, t) ->
prepare_class_type [] cty;
!Oprint.out_class_type ppf (tree_of_class_type false [] cty)
+let tree_of_class_param param variance =
+ (match tree_of_typexp true param with
+ Otyp_var (_, s) -> s
+ | _ -> "?"),
+ if (repr param).desc = Tvar then (true, true) else variance
+
let tree_of_class_params params =
let tyl = tree_of_typlist true params in
List.map (function Otyp_var (_, s) -> s | _ -> "?") tyl
let vir_flag = cl.cty_new = None in
Osig_class
- (vir_flag, Ident.name id, tree_of_class_params params,
+ (vir_flag, Ident.name id,
+ List.map2 tree_of_class_param params cl.cty_variance,
tree_of_class_type true params cl.cty_type,
tree_of_rec rs)
fields in
Osig_class_type
- (virt, Ident.name id, tree_of_class_params params,
+ (virt, Ident.name id,
+ List.map2 tree_of_class_param params cl.clty_variance,
tree_of_class_type true params cl.clty_type,
tree_of_rec rs)
| [] -> []
| Tsig_value(id, decl) :: rem ->
tree_of_value_description id decl :: tree_of_signature rem
+ | Tsig_type(id, _, _) :: rem when is_row_name (Ident.name id) ->
+ tree_of_signature rem
| Tsig_type(id, decl, rs) :: rem ->
Osig_type(tree_of_type_decl id decl, tree_of_rec rs) ::
tree_of_signature rem
(* *)
(***********************************************************************)
-(* $Id: subst.ml,v 1.46 2004/06/12 08:55:48 xleroy Exp $ *)
+(* $Id: subst.ml,v 1.48 2005/03/23 03:08:37 garrigue Exp $ *)
(* Substitutions *)
Tlink ty2
| _ ->
let dup =
- s.for_saving || more.level = generic_level || static_row row in
+ s.for_saving || more.level = generic_level || static_row row ||
+ match more.desc with Tconstr _ -> true | _ -> false in
(* Various cases for the row variable *)
let more' =
- match more.desc with Tsubst ty -> ty
- | _ ->
+ match more.desc with
+ Tsubst ty -> ty
+ | Tconstr _ -> typexp s more
+ | Tunivar | Tvar ->
save_desc more more.desc;
if s.for_saving then newpersty more.desc else
if dup && more.desc <> Tunivar then newgenvar () else more
+ | _ -> assert false
in
(* Register new type first for recursion *)
more.desc <- Tsubst(newgenty(Ttuple[more';ty']));
let class_declaration s decl =
let decl =
{ cty_params = List.map (typexp s) decl.cty_params;
+ cty_variance = decl.cty_variance;
cty_type = class_type s decl.cty_type;
cty_path = type_path s decl.cty_path;
cty_new =
let cltype_declaration s decl =
let decl =
{ clty_params = List.map (typexp s) decl.clty_params;
+ clty_variance = decl.clty_variance;
clty_type = class_type s decl.clty_type;
clty_path = type_path s decl.clty_path }
in
(* *)
(***********************************************************************)
-(* $Id: typeclass.ml,v 1.78.2.2 2005/07/12 11:44:47 garrigue Exp $ *)
+(* $Id: typeclass.ml,v 1.85 2005/07/22 06:42:36 garrigue Exp $ *)
open Misc
open Parsetree
try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
raise(Error(loc, Method_type_mismatch (lab, trace)))
+let delayed_meth_specs = ref []
+
let declare_method val_env meths self_type lab priv sty loc =
let (_, ty') =
Ctype.filter_self_method val_env lab priv meths self_type
in
- let ty =
- match sty.ptyp_desc, priv with
- Ptyp_poly ([],sty), Public -> transl_simple_type_univars val_env sty
- | _ -> transl_simple_type val_env false sty
+ let unif ty =
+ try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+ raise(Error(loc, Method_type_mismatch (lab, trace)))
in
- begin try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
- raise(Error(loc, Method_type_mismatch (lab, trace)))
- end
+ match sty.ptyp_desc, priv with
+ Ptyp_poly ([],sty), Public ->
+ delayed_meth_specs :=
+ lazy (unif (transl_simple_type_univars val_env sty)) ::
+ !delayed_meth_specs
+ | _ -> unif (transl_simple_type val_env false sty)
let type_constraint val_env sty sty' loc =
let ty = transl_simple_type val_env false sty in
let (params, clty) =
Ctype.instance_class decl.clty_params decl.clty_type
in
- let sty = Ctype.self_type clty in
if List.length params <> List.length styl then
raise(Error(scty.pcty_loc,
Parameter_arity_mismatch (lid, List.length params,
let cty = class_type env scty in
Tcty_fun (l, ty, cty)
+let class_type env scty =
+ delayed_meth_specs := [];
+ let cty = class_type env scty in
+ List.iter Lazy.force (List.rev !delayed_meth_specs);
+ delayed_meth_specs := [];
+ cty
+
(*******************************)
module StringSet = Set.Make(struct type t = string let compare = compare end)
let l1 = names priv_meths and l2 = names pub_meths' in
let added = List.filter (fun x -> List.mem x l1) l2 in
if added <> [] then
- Location.prerr_warning loc
- (Warnings.Other
- (String.concat " "
- ("the following private methods were made public implicitly:\n "
- :: added)));
-
+ Location.prerr_warning loc (Warnings.Implicit_public_methods added);
{cl_field = fields; cl_meths = meths}, sign
and class_expr cl_num val_env met_env scl =
Ctype.end_def ();
if Btype.is_optional l && all_labeled cl.cl_type then
Location.prerr_warning pat.pat_loc
- (Warnings.Other "This optional argument cannot be erased");
+ Warnings.Unerasable_optional_argument;
rc {cl_desc = Tclass_fun (pat, pv, cl, partial);
cl_loc = scl.pcl_loc;
cl_type = Tcty_fun (l, Ctype.instance pat.pat_type, cl.cl_type);
in
let dummy_class =
{cty_params = []; (* Dummy value *)
+ cty_variance = [];
cty_type = dummy_cty; (* Dummy value *)
cty_path = unbound_class;
cty_new =
let env =
Env.add_cltype ty_id
{clty_params = []; (* Dummy value *)
+ clty_variance = [];
clty_type = dummy_cty; (* Dummy value *)
clty_path = unbound_class} (
if define_class then
end;
(* Class and class type temporary definitions *)
+ let cty_variance = List.map (fun _ -> true, true) params in
let cltydef =
{clty_params = params; clty_type = class_body typ;
+ clty_variance = cty_variance;
clty_path = Path.Pident obj_id}
and clty =
{cty_params = params; cty_type = typ;
+ cty_variance = cty_variance;
cty_path = Path.Pident obj_id;
cty_new =
match cl.pci_virt with
let (params', typ') = Ctype.instance_class params typ in
let cltydef =
{clty_params = params'; clty_type = class_body typ';
+ clty_variance = cty_variance;
clty_path = Path.Pident obj_id}
and clty =
{cty_params = params'; cty_type = typ';
+ cty_variance = cty_variance;
cty_path = Path.Pident obj_id;
cty_new =
match cl.pci_virt with
let extract_type_decls
(id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
arity, pub_meths, coe, expr, required) decls =
- ((obj_id, obj_abbr), required) :: ((cl_id, cl_abbr), required) :: decls
-
-let rec compact = function
- [] -> []
- | a :: b :: l -> (a,b) :: compact l
- | _ -> fatal_error "Typeclass.compact"
+ (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) :: decls
let merge_type_decls
- (id, clty, ty_id, cltydef, _obj_id, _obj_abbr, _cl_id, _cl_abbr,
- arity, pub_meths, coe, expr, req) ((obj_id, obj_abbr), (cl_id, cl_abbr)) =
+ (id, _clty, ty_id, _cltydef, obj_id, _obj_abbr, cl_id, _cl_abbr,
+ arity, pub_meths, coe, expr, req) (obj_abbr, cl_abbr, clty, cltydef) =
(id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
arity, pub_meths, coe, expr)
let res = List.rev_map (final_decl env define_class) res in
let decls = List.fold_right extract_type_decls res [] in
let decls = Typedecl.compute_variance_decls env decls in
- let res = List.map2 merge_type_decls res (compact decls) in
+ let res = List.map2 merge_type_decls res decls in
let env = List.fold_left (final_env define_class) env res in
let res = List.map (check_coercions env) res in
(res, env)
(* *)
(***********************************************************************)
-(* $Id: typecore.ml,v 1.160.2.2 2005/04/04 05:14:10 garrigue Exp $ *)
+(* $Id: typecore.ml,v 1.176 2005/09/15 03:09:26 garrigue Exp $ *)
(* Typechecking for the core language *)
| Label_multiply_defined of Longident.t
| Label_missing of string list
| Label_not_mutable of Longident.t
- | Bad_format of string
+ | Incomplete_format of string
+ | Bad_conversion of string * int * char
| Undefined_method of type_expr * string
| Undefined_inherited_method of string
| Unbound_class of Longident.t
let type_object =
ref (fun env s -> assert false :
Env.t -> Location.t -> Parsetree.class_structure ->
- class_structure * class_signature * string list)
+ class_structure * class_signature * string list)
(*
Saving and outputting type information.
| Const_int32 _ -> instance Predef.type_int32
| Const_int64 _ -> instance Predef.type_int64
| Const_nativeint _ -> instance Predef.type_nativeint
-
+
(* Specific version of type_option, using newty rather than newgenty *)
let type_option ty =
let enter_orpat_variables loc env p1_vs p2_vs =
(* unify_vars operate on sorted lists *)
-
+
let p1_vs = sort_pattern_variables p1_vs
and p2_vs = sort_pattern_variables p2_vs in
- let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with
+ 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 ->
if x1==x2 then
unify_vars rem1 rem2
raise (Error (loc, Orpat_vars min_var)) in
unify_vars p1_vs p2_vs
-
let rec build_as_type env p =
match p.pat_desc with
Tpat_alias(p1, _) -> build_as_type env p1
let tyl = List.map (build_as_type env) pl in
newty (Ttuple tyl)
| Tpat_construct(cstr, pl) ->
+ if cstr.cstr_private = Private then p.pat_type else
let tyl = List.map (build_as_type env) pl in
let ty_args, ty_res = instance_constructor cstr in
List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty})
row_fixed=false; row_closed=false})
| Tpat_record lpl ->
let lbl = fst(List.hd lpl) in
+ if lbl.lbl_private = Private then p.pat_type else
let ty = newvar () in
let ppl = List.map (fun (l,p) -> l.lbl_pos, p) lpl in
let do_label lbl =
let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
let type_self_pattern cl_num privty val_env met_env par_env spat =
- let spat =
+ let spat =
mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")),
"selfpat-" ^ cl_num))
in
| Texp_record(lbl_exp_list, opt_init_exp) ->
List.for_all
(fun (lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp)
- lbl_exp_list
+ lbl_exp_list
&& is_nonexpansive_opt opt_init_exp
| Texp_field(exp, lbl) -> is_nonexpansive exp
| Texp_array [] -> true
None -> true
| Some e -> is_nonexpansive e
-(* Typing of printf formats.
+(* Typing of printf formats.
(Handling of * modifiers contributed by Thorsten Ohl.) *)
let type_format loc fmt =
- let len = String.length fmt in
- let ty_input = newvar ()
- and ty_result = newvar ()
- and ty_aresult = newvar () in
+
let ty_arrow gty ty = newty (Tarrow ("", instance gty, ty, Cok)) in
- let invalid_fmt s = raise (Error (loc, Bad_format s)) in
- let incomplete i = invalid_fmt (String.sub fmt i (len - i)) in
- let invalid i j = invalid_fmt (String.sub fmt i (j - i + 1)) in
-
- let rec scan_format i =
- if i >= len then ty_aresult, ty_result else
- match fmt.[i] with
- | '%' -> scan_flags i (i + 1)
- | _ -> scan_format (i + 1)
- and scan_flags i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '#' | '0' | '-' | ' ' | '+' -> scan_flags i (j + 1)
- | _ -> scan_skip i j
- and scan_skip i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '_' -> scan_rest true i j
- | _ -> scan_rest false i j
- and scan_rest skip i j =
- let rec scan_width i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '*' ->
- let ty_aresult, ty_result = scan_dot i (j + 1) in
- ty_aresult, ty_arrow Predef.type_int ty_result
- | '_' -> scan_fixed_width i (j + 1)
- | '.' -> scan_precision i (j + 1)
- | _ -> scan_fixed_width i j
- and scan_fixed_width i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '0' .. '9' | '-' | '+' -> scan_fixed_width i (j + 1)
- | '.' -> scan_precision i (j + 1)
- | _ -> scan_conversion i j
- and scan_dot i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '.' -> scan_precision i (j + 1)
- | _ -> scan_conversion i j
- and scan_precision i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '*' ->
- let ty_aresult, ty_result = scan_conversion i (j + 1) in
- ty_aresult, ty_arrow Predef.type_int ty_result
- | _ -> scan_fixed_precision i j
- and scan_fixed_precision i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '0' .. '9' | '-' | '+' -> scan_fixed_precision i (j + 1)
- | _ -> scan_conversion i j
+ let bad_conversion fmt i c =
+ raise (Error (loc, Bad_conversion (fmt, i, c))) in
+ let incomplete_format fmt =
+ raise (Error (loc, Incomplete_format fmt)) in
- and conversion j ty_arg =
- let ty_aresult, ty_result = scan_format (j + 1) in
- ty_aresult,
- if skip then ty_result else ty_arrow ty_arg ty_result
+ let range_closing_index fmt i =
- and scan_conversion i j =
- if j >= len then incomplete i else
+ let len = String.length fmt in
+ let find_closing j =
+ if j >= len then incomplete_format fmt else
+ try String.index_from fmt j ']' with
+ | Not_found -> incomplete_format fmt in
+ let skip_pos j =
+ if j >= len then incomplete_format fmt else
+ match fmt.[j] with
+ | ']' -> find_closing (j + 1)
+ | c -> find_closing j in
+ let rec skip_neg j =
+ if j >= len then incomplete_format fmt else
+ match fmt.[j] with
+ | '^' -> skip_pos (j + 1)
+ | c -> skip_pos j in
+ find_closing (skip_neg (i + 1)) in
+
+ let rec type_in_format fmt =
+
+ let len = String.length fmt in
+
+ let ty_input = newvar ()
+ and ty_result = newvar ()
+ and ty_aresult = newvar () in
+
+ let meta = ref 0 in
+
+ let rec scan_format i =
+ if i >= len then
+ if !meta = 0
+ then ty_aresult, ty_result
+ else incomplete_format fmt else
+ match fmt.[i] with
+ | '%' -> scan_opts i (i + 1)
+ | _ -> scan_format (i + 1)
+ and scan_opts i j =
+ if j >= len then incomplete_format fmt else
match fmt.[j] with
- | '%' | '!' -> scan_format (j + 1)
- | 's' | 'S' | '[' -> conversion j Predef.type_string
- | 'c' | 'C' -> conversion j Predef.type_char
- | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' -> conversion j Predef.type_int
- | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float
- | 'B' | 'b' -> conversion j Predef.type_bool
- | 'a' ->
+ | '_' -> scan_rest true i (j + 1)
+ | _ -> scan_rest false i j
+ and scan_rest skip i j =
+ let rec scan_flags i j =
+ if j >= len then incomplete_format fmt else
+ match fmt.[j] with
+ | '#' | '0' | '-' | ' ' | '+' -> scan_flags i (j + 1)
+ | _ -> scan_width i j
+ and scan_width i j = scan_width_or_prec_value scan_precision i j
+ and scan_decimal_string scan i j =
+ if j >= len then incomplete_format fmt else
+ match fmt.[j] with
+ | '0' .. '9' -> scan_decimal_string scan i (j + 1)
+ | _ -> scan i j
+ and scan_width_or_prec_value scan i j =
+ if j >= len then incomplete_format fmt else
+ match fmt.[j] with
+ | '*' ->
+ let ty_aresult, ty_result = scan i (j + 1) in
+ ty_aresult, ty_arrow Predef.type_int ty_result
+ | '-' | '+' -> scan_decimal_string scan i (j + 1)
+ | _ -> scan_decimal_string scan i j
+ and scan_precision i j =
+ if j >= len then incomplete_format fmt else
+ match fmt.[j] with
+ | '.' -> scan_width_or_prec_value scan_conversion i (j + 1)
+ | _ -> scan_conversion i j
+
+ and conversion j ty_arg =
+ let ty_aresult, ty_result = scan_format (j + 1) in
+ ty_aresult,
+ if skip then ty_result else ty_arrow ty_arg ty_result
+
+ and scan_conversion i j =
+ if j >= len then incomplete_format fmt else
+ match fmt.[j] with
+ | '%' | '!' -> scan_format (j + 1)
+ | 's' | 'S' -> conversion j Predef.type_string
+ | '[' ->
+ let j = range_closing_index fmt j in
+ conversion j Predef.type_string
+ | 'c' | 'C' -> conversion j Predef.type_char
+ | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' ->
+ conversion j Predef.type_int
+ | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float
+ | 'B' | 'b' -> conversion j Predef.type_bool
+ | 'a' ->
let ty_arg = newvar () in
- let ty_a = ty_arrow ty_input (ty_arrow ty_arg ty_aresult) in
+ let ty_a = ty_arrow ty_input (ty_arrow ty_arg ty_aresult) in
let ty_aresult, ty_result = conversion j ty_arg in
ty_aresult, ty_arrow ty_a ty_result
- | 't' -> conversion j (ty_arrow ty_input ty_aresult)
- | 'n' | 'l' when j + 1 = len -> conversion j Predef.type_int
- | 'n' | 'l' | 'L' as c ->
+ | 't' -> conversion j (ty_arrow ty_input ty_aresult)
+ | 'l' | 'n' | 'L' as c ->
let j = j + 1 in
- if j >= len then incomplete i else begin
- match fmt.[j] with
- | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
- let ty_arg =
- match c with
- | 'l' -> Predef.type_int32
- | 'n' -> Predef.type_nativeint
- | _ -> Predef.type_int64 in
+ if j >= len then conversion (j - 1) Predef.type_int else begin
+ match fmt.[j] with
+ | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
+ let ty_arg =
+ match c with
+ | 'l' -> Predef.type_int32
+ | 'n' -> Predef.type_nativeint
+ | _ -> Predef.type_int64 in
conversion j ty_arg
- | _ ->
- if c = 'l' || c = 'n'
- then conversion (j - 1) Predef.type_int
- else invalid i (j - 1)
+ | c -> conversion (j - 1) Predef.type_int
end
- | c -> invalid i j in
- scan_width i j in
-
- let ty_ares, ty_res = scan_format 0 in
- newty
- (Tconstr(Predef.path_format4,
- [ty_res; ty_input; ty_ares; ty_result],
- ref Mnil))
+ | '{' | '(' as c ->
+ let j = j + 1 in
+ if j >= len then incomplete_format fmt else
+ let sj =
+ Printf.sub_format incomplete_format bad_conversion c fmt j in
+ let sfmt = String.sub fmt j (sj - j - 1) in
+ let ty_sfmt = type_in_format sfmt in
+ begin match c with
+ | '{' -> conversion sj ty_sfmt
+ | _ -> incr meta; conversion (j - 1) ty_sfmt end
+ | ')' when !meta > 0 -> decr meta; scan_format (j + 1)
+ | c -> bad_conversion fmt i c in
+ scan_flags i j in
+
+ let ty_ares, ty_res = scan_format 0 in
+ newty
+ (Tconstr(Predef.path_format4,
+ [ty_res; ty_input; ty_ares; ty_result],
+ ref Mnil)) in
+
+ type_in_format fmt
(* Approximate the type of an expression, for better recursion *)
-let rec approx_type sty =
+let rec approx_type env sty =
match sty.ptyp_desc with
Ptyp_arrow (p, _, sty) ->
let ty1 = if is_optional p then type_option (newvar ()) else newvar () in
- newty (Tarrow (p, ty1, approx_type sty, Cok))
+ newty (Tarrow (p, ty1, approx_type env sty, Cok))
+ | Ptyp_tuple args ->
+ newty (Ttuple (List.map (approx_type env) args))
+ | Ptyp_constr (lid, ctl) ->
+ begin try
+ let tyl = List.map (approx_type env) ctl in
+ let (path, _) = Env.lookup_type lid env in
+ newconstr path tyl
+ with Not_found -> newvar ()
+ end
| _ -> newvar ()
let rec type_approx env sexp =
| Pexp_constraint (e, sty1, sty2) ->
let approx_ty_opt = function
| None -> newvar ()
- | Some sty -> approx_type sty
+ | Some sty -> approx_type env sty
in
let ty = type_approx env e
and ty1 = approx_ty_opt sty1
(* Typing of expressions *)
let unify_exp env exp expected_ty =
+ (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
+ Printtyp.raw_type_expr expected_ty; *)
try
unify env exp.exp_type expected_ty
with
| Pexp_function _ -> (* defined in type_expect *)
type_expect env sexp (newvar())
| Pexp_apply(sfunct, sargs) ->
+ begin_def (); (* one more level for non-returning functions *)
if !Clflags.principal then begin_def ();
let funct = type_exp env sfunct in
if !Clflags.principal then begin
end_def ();
generalize_structure funct.exp_type
end;
+ let rec lower_args ty_fun =
+ match (expand_head env ty_fun).desc with
+ Tarrow (l, ty, ty_fun, com) ->
+ unify_var env (newvar()) ty;
+ lower_args ty_fun
+ | _ -> ()
+ in
+ let ty = instance funct.exp_type in
+ end_def ();
+ lower_args ty;
+ begin_def ();
let (args, ty_res) = type_application env funct sargs in
- let funct = {funct with exp_type = instance funct.exp_type} in
+ end_def ();
+ unify_var env (newvar()) funct.exp_type;
re {
exp_desc = Texp_apply(funct, args);
exp_loc = sexp.pexp_loc;
in
let missing = missing_labels 0 label_names in
raise(Error(sexp.pexp_loc, Label_missing missing))
- end;
+ end
+ else if opt_sexp <> None && List.length lid_sexp_list = !num_fields then
+ Location.prerr_warning sexp.pexp_loc Warnings.Useless_record_with;
re {
exp_desc = Texp_record(lbl_exp_list, opt_exp);
exp_loc = sexp.pexp_loc;
let (id, typ) =
filter_self_method env met Private meths privty
in
+ if (repr typ).desc = Tvar then
+ Location.prerr_warning sexp.pexp_loc
+ (Warnings.Undeclared_virtual_method met);
(Texp_send(obj, Tmeth_val id), typ)
| Texp_ident(path, {val_kind = Val_anc (methods, cl_num)}) ->
let method_id =
| {desc = Tpoly (ty, tl); level = l} ->
if !Clflags.principal && l <> generic_level then
Location.prerr_warning sexp.pexp_loc
- (Warnings.Other
- "This use of a polymorphic method is not principal");
+ (Warnings.Not_principal "this use of a polymorphic method");
snd (instance_poly false tl ty)
| {desc = Tvar} as ty ->
let ty' = newvar () in
with
Not_found ->
raise(Error(sexp.pexp_loc, Unbound_instance_variable lab))
- end
+ end
| Pexp_override lst ->
- let _ =
+ let _ =
List.fold_right
(fun (lab, _) l ->
if List.exists ((=) lab) l then
[Some eta_var, Required])}],
Total) } in
if warn then Location.prerr_warning texp.exp_loc
- (Warnings.Other "Eliminated optional argument without principality");
+ (Warnings.Without_principality "eliminated optional argument");
if is_nonexpansive texp then func texp else
(* let-expand to have side effects *)
let let_pat, let_var = var_pair "let" texp.exp_type in
instance (result_type omitted ty_fun))
| (l1, sarg1) :: sargl ->
let (ty1, ty2) =
- match (expand_head env ty_fun).desc with
+ let ty_fun = expand_head env ty_fun in
+ match ty_fun.desc with
Tvar ->
let t1 = newvar () and t2 = newvar () in
+ let not_identity = function
+ Texp_ident(_,{val_kind=Val_prim
+ {Primitive.prim_name="%identity"}}) ->
+ false
+ | _ -> true
+ in
+ if ty_fun.level >= t1.level && not_identity funct.exp_desc then
+ Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument;
unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
(t1, t2)
| Tarrow (l,t1,t2,_) when l = l1
match expand_head env ty_fun with
{desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun'
when (sargs <> [] || more_sargs <> []) && commu_repr com = Cok ->
- let may_warn loc msg =
+ let may_warn loc w =
if not !warned && !Clflags.principal && lv <> generic_level
then begin
warned := true;
- Location.prerr_warning loc (Warnings.Other msg)
+ Location.prerr_warning loc w
end
in
let name = label_name l
let (l', sarg0, sargs1, sargs2) = extract_label name sargs in
if sargs1 <> [] then
may_warn sarg0.pexp_loc
- "Commuting this argument is not principal";
+ (Warnings.Not_principal "commuting this argument");
(l', sarg0, sargs1 @ sargs2, more_sargs)
with Not_found ->
let (l', sarg0, sargs1, sargs2) =
extract_label name more_sargs in
if sargs1 <> [] || sargs <> [] then
may_warn sarg0.pexp_loc
- "Commuting this argument is not principal";
+ (Warnings.Not_principal "commuting this argument");
(l', sarg0, sargs @ sargs1, sargs2)
in
sargs, more_sargs,
Some (fun () -> type_argument env sarg0 ty)
else begin
may_warn sarg0.pexp_loc
- "Using an optional argument here is not principal";
+ (Warnings.Not_principal "using an optional argument here");
Some (fun () -> option_some (type_argument env sarg0
(extract_option_type env ty)))
end
(List.mem_assoc "" sargs || List.mem_assoc "" more_sargs)
then begin
may_warn funct.exp_loc
- "Eliminated an optional argument without principality";
+ (Warnings.Without_principality "eliminated optional argument");
ignored := (l,ty,lv) :: !ignored;
Some (fun () -> option_none (instance ty) Location.none)
end else begin
may_warn funct.exp_loc
- "Commuted an argument without principality";
+ (Warnings.Without_principality "commuted an argument");
None
end
in
in
if is_optional l && all_labeled ty_res then
Location.prerr_warning (fst (List.hd cases)).pat_loc
- (Warnings.Other "This optional argument cannot be erased");
+ Warnings.Unerasable_optional_argument;
re {
exp_desc = Texp_function(cases, partial);
exp_loc = sexp.pexp_loc;
| Some sty ->
let ty = Typetexp.transl_simple_type env false sty in
repr ty
- in
+ in
let set_type ty =
unify_exp env
{ exp_desc = Texp_tuple []; exp_loc = sexp.pexp_loc;
(* Typing of statements (expressions whose values are discarded) *)
and type_statement env sexp =
- let exp = type_exp env sexp in
- match (expand_head env exp.exp_type).desc with
- | Tarrow _ ->
- Location.prerr_warning sexp.pexp_loc Warnings.Partial_application;
- exp
- | Tconstr (p, _, _) when Path.same p Predef.path_unit -> exp
- | Tvar ->
- add_delayed_check (fun () -> check_partial_application env exp);
- exp
- | _ ->
- Location.prerr_warning sexp.pexp_loc Warnings.Statement_type;
- exp
+ begin_def();
+ let exp = type_exp env sexp in
+ end_def();
+ let ty = expand_head env exp.exp_type and tv = newvar() in
+ begin match ty.desc with
+ | Tarrow _ ->
+ Location.prerr_warning sexp.pexp_loc Warnings.Partial_application
+ | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
+ | Tvar when ty.level > tv.level ->
+ Location.prerr_warning sexp.pexp_loc Warnings.Nonreturning_statement
+ | Tvar ->
+ add_delayed_check (fun () -> check_partial_application env exp)
+ | _ ->
+ Location.prerr_warning sexp.pexp_loc Warnings.Statement_type
+ end;
+ unify_var env tv ty;
+ exp
(* Typing of match cases *)
print_labels labels
| Label_not_mutable lid ->
fprintf ppf "The record field label %a is not mutable" longident lid
- | Bad_format s ->
- fprintf ppf "Bad format `%s'" s
+ | Incomplete_format s ->
+ fprintf ppf "Premature end of format string ``%S''" s
+ | Bad_conversion (fmt, i, c) ->
+ fprintf ppf
+ "Bad conversion %%%c, at char number %d \
+ in format string ``%s''" c i fmt
| Undefined_method (ty, me) ->
reset_and_mark_loops ty;
fprintf ppf
(* *)
(***********************************************************************)
-(* $Id: typecore.mli,v 1.35 2003/11/25 09:20:42 garrigue Exp $ *)
+(* $Id: typecore.mli,v 1.37 2005/03/04 14:51:31 weis Exp $ *)
(* Type inference for the core language *)
| Label_multiply_defined of Longident.t
| Label_missing of string list
| Label_not_mutable of Longident.t
- | Bad_format of string
+ | Incomplete_format of string
+ | Bad_conversion of string * int * char
| Undefined_method of type_expr * string
| Undefined_inherited_method of string
| Unbound_class of Longident.t
(* *)
(***********************************************************************)
-(* $Id: typedecl.ml,v 1.67.10.5 2005/07/11 08:07:50 garrigue Exp $ *)
+(* $Id: typedecl.ml,v 1.75 2005/08/16 00:48:56 garrigue Exp $ *)
(**** Typing of type definitions ****)
| Not_an_exception of Longident.t
| Bad_variance of int * (bool*bool) * (bool*bool)
| Unavailable_type_constructor of Path.t
+ | Bad_fixed_type of string
exception Error of Location.t * error
{desc = Tconstr(p, _, _)} -> Path.same p Predef.path_float
| _ -> false
+(* Set the row variable in a fixed type *)
+let set_fixed_row env loc p decl =
+ let tm =
+ match decl.type_manifest with
+ None -> assert false
+ | Some t -> Ctype.expand_head env t
+ in
+ let rv =
+ match tm.desc with
+ Tvariant row ->
+ let row = Btype.row_repr row in
+ tm.desc <- Tvariant {row with row_fixed = true};
+ if Btype.static_row row then Btype.newgenty Tnil
+ else row.row_more
+ | Tobject (ty, _) ->
+ snd (Ctype.flatten_fields ty)
+ | _ ->
+ raise (Error (loc, Bad_fixed_type "is not an object or variant"))
+ in
+ if rv.desc <> Tvar then
+ raise (Error (loc, Bad_fixed_type "has no row variable"));
+ rv.desc <- Tconstr (p, decl.type_params, ref Mnil)
+
(* Translate one type declaration *)
module StringSet =
type_arity = List.length params;
type_kind =
begin match sdecl.ptype_kind with
- Ptype_abstract ->
+ Ptype_abstract | Ptype_private ->
Type_abstract
| Ptype_variant (cstrs, priv) ->
let all_constrs = ref StringSet.empty in
List.iter
- (fun (name, args) ->
+ (fun (name, args, loc) ->
if StringSet.mem name !all_constrs then
raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
all_constrs := StringSet.add name !all_constrs)
cstrs;
- if List.length (List.filter (fun (name, args) -> args <> []) cstrs)
+ 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) ->
+ (fun (name, args, loc) ->
(name, List.map (transl_simple_type env true) args))
cstrs, priv)
| Ptype_record (lbls, priv) ->
let all_labels = ref StringSet.empty in
List.iter
- (fun (name, mut, arg) ->
+ (fun (name, mut, arg, loc) ->
if StringSet.mem name !all_labels then
raise(Error(sdecl.ptype_loc, Duplicate_label name));
all_labels := StringSet.add name !all_labels)
lbls;
let lbls' =
List.map
- (fun (name, mut, arg) ->
+ (fun (name, mut, arg, loc) ->
let ty = transl_simple_type env true arg in
name, mut, match ty.desc with Tpoly(t,[]) -> t | _ -> ty)
lbls in
begin match sdecl.ptype_manifest with
None -> None
| Some sty ->
- let ty = transl_simple_type env true sty in
+ let ty =
+ transl_simple_type env (sdecl.ptype_kind <> Ptype_private) sty in
if Ctype.cyclic_abbrev env id ty then
raise(Error(sdecl.ptype_loc, Recursive_abbrev name));
Some ty
raise(Error(loc, Unconsistent_constraint tr)))
cstrs;
Ctype.end_def ();
-
+ if sdecl.ptype_kind = Ptype_private then begin
+ let (p, _) =
+ try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env
+ with Not_found -> assert false in
+ set_fixed_row env sdecl.ptype_loc p decl
+ end;
(id, decl)
(* Generalize a type declaration *)
| Type_variant (l, _) ->
let rec find_pl = function
Ptype_variant(pl, _) -> pl
- | Ptype_record _ | Ptype_abstract -> assert false
+ | Ptype_record _ | Ptype_abstract | Ptype_private -> assert false
in
let pl = find_pl sdecl.ptype_kind in
List.iter
(fun (name, tyl) ->
- let styl = try List.assoc name pl with Not_found -> assert false in
+ let styl =
+ try let (_,sty,_) = List.find (fun (n,_,_) -> n = name) pl in sty
+ with Not_found -> assert false in
List.iter2
(fun sty ty ->
check_constraints_rec env sty.ptyp_loc visited ty)
| Type_record (l, _, _) ->
let rec find_pl = function
Ptype_record(pl, _) -> pl
- | Ptype_variant _ | Ptype_abstract -> assert false
+ | Ptype_variant _ | Ptype_abstract | Ptype_private -> assert false
in
let pl = find_pl sdecl.ptype_kind in
let rec get_loc name = function
[] -> assert false
- | (name', _, sty) :: tl ->
+ | (name', _, sty, _) :: tl ->
if name = name' then sty.ptyp_loc else get_loc name tl
in
List.iter
| Tconstr(path', args', _) ->
if Path.same path path' then begin
if not (Ctype.equal env false args args') then
- raise (Error(loc,
+ raise (Error(loc,
Parameters_differ(cpath, ty, Ctype.newconstr path args)))
end
(* Attempt to expand a type abbreviation if:
1- [to_check path'] holds
(otherwise the expansion cannot involve [path]);
2- we haven't expanded this type constructor before
- (otherwise we could loop if [path'] is itself
+ (otherwise we could loop if [path'] is itself
a non-regular abbreviation). *)
else if to_check path' && not (List.mem path' prev_exp) then begin
try
(* Attempt expansion *)
let (params0, body0) = Env.find_type_expansion path' env in
- let (params, body) =
+ let (params, body) =
Ctype.instance_parameterized_type params0 body0 in
begin
try List.iter2 (Ctype.unify env) params args'
compute_variance_rec
(posi && co || nega && cn)
(posi && cn || nega && co)
- (cntr || ct)
+ (cntr || ct)
ty)
tl decl.type_variance
with Not_found ->
| Type_variant (tll, _) ->
List.iter
(fun (_,tl) ->
- List.iter (compute_variance env tvl true false false) tl)
+ List.iter (compute_variance env tvl true false false) tl)
tll
| Type_record (ftl, _, _) ->
List.iter
(fun (_, mut, ty) ->
- let cn = (mut = Mutable) in
- compute_variance env tvl true cn cn ty)
+ let cn = (mut = Mutable) in
+ compute_variance env tvl true cn cn ty)
ftl
end;
- let required =
+ 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
+ and required =
List.map (fun (c,n as r) -> if c || n then r else (true,true))
required
in
List.iter2
(fun (ty, co, cn, ct) (c, n) ->
- if ty.desc <> Tvar then begin
+ if ty.desc <> Tvar || priv = Private then begin
co := c; cn := n; ct := n;
compute_variance env tvl2 c n n ty
end)
List.map (fun _ -> (false, false, false)) decl.type_params
(* for typeclass.ml *)
-let compute_variance_decls env decls =
- let decls, required = List.split decls in
+let compute_variance_decls env cldecls =
+ let decls, required =
+ List.fold_right
+ (fun (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) (decls, req) ->
+ (obj_id, obj_abbr) :: decls, required :: req)
+ cldecls ([],[])
+ in
let variances = List.map init_variance decls in
- fst (compute_variance_fixpoint env decls required variances)
+ let (decls, _) = compute_variance_fixpoint env decls required variances in
+ List.map2
+ (fun (_,decl) (_, _, cl_abbr, clty, cltydef, _) ->
+ let variance = List.map (fun (c,n,t) -> (c,n)) decl.type_variance in
+ (decl, {cl_abbr with type_variance = decl.type_variance},
+ {clty with cty_variance = variance},
+ {cltydef with clty_variance = variance}))
+ decls cldecls
(* 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
+ in
+ let name_sdecl_list =
+ List.map
+ (fun (name,sdecl) ->
+ name^"#row",
+ {sdecl with ptype_kind = Ptype_abstract; ptype_manifest = None})
+ fixed_types
+ @ name_sdecl_list
+ in
(* Create identifiers. *)
let id_list =
List.map (fun (name, _) -> Ident.create name) name_sdecl_list
(* Translate a "with" constraint -- much simplified version of
transl_type_decl. *)
-let transl_with_constraint env sdecl =
+let transl_with_constraint env row_path sdecl =
reset_type_variables();
Ctype.begin_def();
let params =
with Ctype.Unify tr ->
raise(Error(loc, Unconsistent_constraint tr)))
sdecl.ptype_cstrs;
+ let no_row = sdecl.ptype_kind <> Ptype_private in
let decl =
{ type_params = params;
type_arity = List.length params;
type_manifest =
begin match sdecl.ptype_manifest with
None -> None
- | Some sty -> Some(transl_simple_type env true sty)
+ | Some sty ->
+ Some(transl_simple_type env no_row sty)
end;
type_variance = [];
}
in
+ begin match row_path with None -> ()
+ | Some p -> set_fixed_row env sdecl.ptype_loc p decl
+ end;
begin match Ctype.closed_type_decl decl with None -> ()
| Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
end;
let approx_type_decl env name_sdecl_list =
List.map
- (fun (name, sdecl) ->
+ (fun (name, sdecl) ->
(Ident.create name,
abstract_type_decl (List.length sdecl.ptype_params)))
name_sdecl_list
"but it is" (variance v1)
| Unavailable_type_constructor p ->
fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p
+ | Bad_fixed_type r ->
+ fprintf ppf "This fixed type %s" r
(* *)
(***********************************************************************)
-(* $Id: typedecl.mli,v 1.26.10.2 2005/04/15 08:16:41 garrigue Exp $ *)
+(* $Id: typedecl.mli,v 1.29 2005/08/13 20:59:37 doligez Exp $ *)
(* Typing of type definitions and primitive definitions *)
open Format
val transl_type_decl:
- Env.t -> (string * Parsetree.type_declaration) list ->
+ Env.t -> (string * Parsetree.type_declaration) list ->
(Ident.t * type_declaration) list * Env.t
val transl_exception:
- Env.t -> Parsetree.exception_declaration -> exception_declaration
+ Env.t -> Parsetree.exception_declaration -> exception_declaration
val transl_exn_rebind:
- Env.t -> Location.t -> Longident.t -> Path.t * exception_declaration
+ Env.t -> Location.t -> Longident.t -> Path.t * exception_declaration
val transl_value_decl:
- Env.t -> Parsetree.value_description -> value_description
+ Env.t -> Parsetree.value_description -> value_description
val transl_with_constraint:
- Env.t -> Parsetree.type_declaration -> type_declaration
+ Env.t -> Path.t option -> Parsetree.type_declaration -> type_declaration
val abstract_type_decl: int -> type_declaration
val approx_type_decl:
- Env.t -> (string * Parsetree.type_declaration) list ->
+ Env.t -> (string * Parsetree.type_declaration) list ->
(Ident.t * type_declaration) list
val check_recmod_typedecl:
Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit
(* for typeclass.ml *)
val compute_variance_decls:
Env.t ->
- ((Ident.t * type_declaration) * ((bool * bool) list * Location.t)) list ->
- (Ident.t * type_declaration) list
+ (Ident.t * type_declaration * type_declaration * class_declaration *
+ cltype_declaration * ((bool * bool) list * Location.t)) list ->
+ (type_declaration * type_declaration * class_declaration *
+ cltype_declaration) list
type error =
Repeated_parameter
| Not_an_exception of Longident.t
| Bad_variance of int * (bool*bool) * (bool*bool)
| Unavailable_type_constructor of Path.t
+ | Bad_fixed_type of string
exception Error of Location.t * error
(* *)
(***********************************************************************)
-(* $Id: typemod.ml,v 1.69.2.1 2005/01/12 17:01:58 doligez Exp $ *)
+(* $Id: typemod.ml,v 1.73 2005/08/08 09:41:51 xleroy Exp $ *)
(* Type-checking of the module language *)
(* Merge one "with" constraint in a signature *)
+let rec add_rec_types env = function
+ Tsig_type(id, decl, Trec_next) :: rem ->
+ add_rec_types (Env.add_type id decl env) rem
+ | _ -> env
+
+let check_type_decl env id row_id newdecl decl rs rem =
+ let env = Env.add_type id newdecl env in
+ let env =
+ match row_id with None -> env | Some id -> Env.add_type id newdecl env in
+ let env = if rs = Trec_not then env else add_rec_types env rem in
+ Includemod.type_declarations env id newdecl decl
+
let merge_constraint initial_env loc sg lid constr =
- let rec merge env sg namelist =
+ let rec merge env sg namelist row_id =
match (sg, namelist, constr) with
([], _, _) ->
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 ->
+ let decl_row =
+ { type_params =
+ List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params;
+ type_arity = List.length sdecl.ptype_params;
+ type_kind = Type_abstract;
+ type_manifest = None;
+ type_variance =
+ List.map (fun (c,n) -> (c,n,n)) sdecl.ptype_variance }
+ and id_row = Ident.create (s^"#row") in
+ let initial_env = Env.add_type id_row decl_row initial_env in
+ let newdecl = Typedecl.transl_with_constraint
+ initial_env (Some(Pident id_row)) sdecl in
+ check_type_decl env id row_id newdecl decl rs rem;
+ let decl_row = {decl_row with type_params = newdecl.type_params} in
+ let rs' = if rs = Trec_first then Trec_not else rs in
+ Tsig_type(id_row, decl_row, rs') :: Tsig_type(id, newdecl, rs) :: rem
| (Tsig_type(id, decl, rs) :: rem, [s], Pwith_type sdecl)
when Ident.name id = s ->
- let newdecl = Typedecl.transl_with_constraint initial_env sdecl in
- Includemod.type_declarations env id newdecl decl;
+ let newdecl = Typedecl.transl_with_constraint initial_env None sdecl in
+ check_type_decl env id row_id newdecl decl rs rem;
Tsig_type(id, newdecl, rs) :: rem
+ | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_type sdecl)
+ when Ident.name id = s ^ "#row" ->
+ merge env rem namelist (Some id)
| (Tsig_module(id, mty, rs) :: rem, [s], Pwith_module lid)
when Ident.name id = s ->
let (path, mty') = type_module_path initial_env loc lid in
Tsig_module(id, newmty, rs) :: rem
| (Tsig_module(id, mty, rs) :: rem, s :: namelist, _)
when Ident.name id = s ->
- let newsg = merge env (extract_sig env loc mty) namelist in
+ let newsg = merge env (extract_sig env loc mty) namelist None in
Tsig_module(id, Tmty_signature newsg, rs) :: rem
| (item :: rem, _, _) ->
- item :: merge (Env.add_item item env) rem namelist in
+ item :: merge (Env.add_item item env) rem namelist row_id in
try
- merge initial_env sg (Longident.flatten lid)
+ merge initial_env sg (Longident.flatten lid) None
with Includemod.Error explanation ->
raise(Error(loc, With_mismatch(lid, explanation)))
| [] -> rem
| d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem
+let rec map_rec' fn decls rem =
+ match decls with
+ | (id,_ as d1) :: dl when Btype.is_row_name (Ident.name id) ->
+ fn Trec_not d1 :: map_rec' fn dl rem
+ | _ -> map_rec fn decls rem
+
(* Auxiliary for translating recursively-defined module types.
Return a module type that approximates the shape of the given module
type AST. Retain only module, type, and module type
| 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
+ 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
sdecls;
let (decls, newenv) = Typedecl.transl_type_decl env sdecls in
let rem = transl_sig newenv srem in
- map_rec (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem
+ map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem
| Psig_exception(name, sarg) ->
let arg = Typedecl.transl_exception env sarg in
let (id, newenv) = Env.enter_exception name arg env in
enrich_type_decls anchor decls env newenv in
let (str_rem, sig_rem, final_env) = type_struct newenv' srem in
(Tstr_type decls :: str_rem,
- map_rec (fun rs (id, info) -> Tsig_type(id, info, rs)) decls sig_rem,
+ map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls sig_rem,
final_env)
| {pstr_desc = Pstr_exception(name, sarg)} :: srem ->
let arg = Typedecl.transl_exception env sarg in
(* *)
(***********************************************************************)
-(* $Id: typemod.mli,v 1.24 2004/06/13 12:48:01 xleroy Exp $ *)
+(* $Id: typemod.mli,v 1.26 2005/08/08 09:41:52 xleroy Exp $ *)
(* Type-checking of the module language *)
(* *)
(***********************************************************************)
-(* $Id: types.ml,v 1.24 2004/06/12 08:55:49 xleroy Exp $ *)
+(* $Id: types.ml,v 1.25 2004/12/09 12:40:53 garrigue Exp $ *)
(* Representation of types and declarations *)
{ cty_params: type_expr list;
mutable cty_type: class_type;
cty_path: Path.t;
- cty_new: type_expr option }
+ cty_new: type_expr option;
+ cty_variance: (bool * bool) list }
type cltype_declaration =
{ clty_params: type_expr list;
clty_type: class_type;
- clty_path: Path.t }
+ clty_path: Path.t;
+ clty_variance: (bool * bool) list }
(* Type expressions for the module language *)
(* *)
(***********************************************************************)
-(* $Id: types.mli,v 1.24 2004/06/12 08:55:49 xleroy Exp $ *)
+(* $Id: types.mli,v 1.25 2004/12/09 12:40:53 garrigue Exp $ *)
(* Representation of types and declarations *)
{ cty_params: type_expr list;
mutable cty_type: class_type;
cty_path: Path.t;
- cty_new: type_expr option }
+ cty_new: type_expr option;
+ cty_variance: (bool * bool) list }
type cltype_declaration =
{ clty_params: type_expr list;
clty_type: class_type;
- clty_path: Path.t }
+ clty_path: Path.t;
+ clty_variance: (bool * bool) list }
(* Type expressions for the module language *)
let type_variables = ref (Tbl.empty : (string, type_expr) Tbl.t)
let univars = ref ([] : (string * type_expr) list)
let pre_univars = ref ([] : type_expr list)
-let local_aliases = ref ([] : string list)
-
-let used_variables = ref (Tbl.empty : (string, type_expr) Tbl.t)
-let bindings = ref ([] : (Location.t * type_expr * type_expr) list)
- (* These two variables are used for the "delayed" policy. *)
-
-let reset_pre_univars () =
- pre_univars := [];
- local_aliases := []
+let used_variables = ref (Tbl.empty : (string, type_expr * Location.t) Tbl.t)
let reset_type_variables () =
reset_global_level ();
x :: y :: l -> y :: x :: swap_list l
| l -> l
-type policy = Fixed | Extensible | Delayed | Univars
+type policy = Fixed | Extensible | Univars
let rec transl_type env policy styp =
match styp.ptyp_desc with
raise (Error (styp.ptyp_loc, Invalid_variable_name ("'" ^ name)));
begin try
instance (List.assoc name !univars)
+ with Not_found -> try
+ instance (fst(Tbl.find name !used_variables))
with Not_found ->
- match policy with
- Fixed ->
- begin try
- instance (Tbl.find name !type_variables)
- with Not_found ->
- raise(Error(styp.ptyp_loc, Unbound_type_variable ("'" ^ name)))
- end
- | Extensible ->
- begin try
- instance (Tbl.find name !type_variables)
- with Not_found ->
- let v = new_global_var () in
- type_variables := Tbl.add name v !type_variables;
- v
- end
- | Univars ->
- begin try
- instance (Tbl.find name !type_variables)
- with Not_found ->
- let v = new_pre_univar () in
- type_variables := Tbl.add name v !type_variables;
- local_aliases := name :: !local_aliases;
- v
- end
- | Delayed ->
- begin try
- instance (Tbl.find name !used_variables)
- with Not_found -> try
- let v1 = instance (Tbl.find name !type_variables) in
- let v2 = new_global_var () in
- used_variables := Tbl.add name v2 !used_variables;
- bindings := (styp.ptyp_loc, v1, v2)::!bindings;
- v2
- with Not_found ->
- let v = new_global_var () in
- type_variables := Tbl.add name v !type_variables;
- used_variables := Tbl.add name v !used_variables;
- v
- end
+ let v =
+ if policy = Univars then new_pre_univar () else newvar () in
+ used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables;
+ v
end
| Ptyp_arrow(l, st1, st2) ->
let ty1 = transl_type env policy st1 in
raise(Error(styp.ptyp_loc, Present_has_no_type l)))
present;
let bound = ref row.row_bound in
- let single = List.length row.row_fields = 1 in
let fields =
- if single then row.row_fields else
List.map
(fun (l,f) -> l,
if List.mem l present then f else
let t =
try List.assoc alias !univars
with Not_found ->
- let v1 = instance ( Tbl.find alias !type_variables) in
- (* Special case if using indirect variable bindings *)
- if policy = Delayed then
- try instance (Tbl.find alias !used_variables)
- with Not_found ->
- let v2 = new_global_var () in
- used_variables := Tbl.add alias v2 !used_variables;
- bindings := (styp.ptyp_loc, v1, v2)::!bindings;
- v2
- else v1
+ instance (fst(Tbl.find alias !used_variables))
in
let ty = transl_type env policy st in
begin try unify_var env t ty with Unify trace ->
with Not_found ->
begin_def ();
let t = newvar () in
- type_variables := Tbl.add alias t !type_variables;
- let local = (policy = Univars || !univars <> []) in
- if local then local_aliases := alias :: !local_aliases;
- if policy = Delayed then
- used_variables := Tbl.add alias t !used_variables;
+ used_variables := Tbl.add alias (t, styp.ptyp_loc) !used_variables;
let ty = transl_type env policy st in
begin try unify_var env t ty with Unify trace ->
let trace = swap_list trace in
raise(Error(styp.ptyp_loc, Alias_type_mismatch trace))
end;
end_def ();
- if local then generalize_structure t
- else generalize_global t;
+ generalize_structure t;
instance t
end
| Ptyp_variant(fields, closed, present) ->
with Not_found ->
(l, f) :: fields
in
- (* closed and only one field: make it present anyway *)
- let single = closed && List.length fields = 1 in
let rec add_field fields = function
Rtag (l, c, stl) ->
name := None;
let f = match present with
- Some present when not (single || List.mem l present) ->
+ 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)
| _ ->
raise(Error(sty.ptyp_loc, Not_a_variant ty))
in
- let single = single && List.length fl = 1 in
List.fold_left
(fun fields (l, f) ->
let f = match present with
- Some present when not (single || List.mem l present) ->
+ Some present when not (List.mem l present) ->
begin match f with
Rpresent(Some ty) ->
bound := ty :: !bound;
function
[] ->
newty Tnil
- | {pfield_desc = Pfield_var} as field::_ ->
+ | {pfield_desc = Pfield_var}::_ ->
if policy = Univars then new_pre_univar () else newvar ()
| {pfield_desc = Pfield(s, e)}::l ->
let ty1 = transl_type env policy e in
make_fixed_univars ty;
Btype.unmark_type ty
+let globalize_used_variables env fixed =
+ let r = ref [] in
+ Tbl.iter
+ (fun name (ty, loc) ->
+ let v = new_global_var () in
+ let snap = Btype.snapshot () in
+ if try unify env v ty; true with _ -> Btype.backtrack snap; false
+ then try
+ r := (loc, v, Tbl.find name !type_variables) :: !r
+ with Not_found ->
+ if fixed && (repr ty).desc = Tvar then
+ raise(Error(loc, Unbound_type_variable ("'"^name)));
+ let v2 = new_global_var () in
+ r := (loc, v, v2) :: !r;
+ type_variables := Tbl.add name v2 !type_variables)
+ !used_variables;
+ used_variables := Tbl.empty;
+ fun () ->
+ List.iter
+ (function (loc, t1, t2) ->
+ try unify env t1 t2 with Unify trace ->
+ raise (Error(loc, Type_mismatch trace)))
+ !r
+
let transl_simple_type env fixed styp =
- univars := []; local_aliases := [];
+ univars := []; used_variables := Tbl.empty;
let typ = transl_type env (if fixed then Fixed else Extensible) styp in
- type_variables := List.fold_right Tbl.remove !local_aliases !type_variables;
+ globalize_used_variables env fixed ();
make_fixed_univars typ;
typ
let transl_simple_type_univars env styp =
- univars := [];
- reset_pre_univars ();
+ univars := []; used_variables := Tbl.empty; pre_univars := [];
begin_def ();
let typ = transl_type env Univars styp in
+ (* Only keep already global variables in used_variables *)
+ let new_variables = !used_variables in
+ used_variables := Tbl.empty;
+ Tbl.iter
+ (fun name p ->
+ if Tbl.mem name !type_variables then
+ used_variables := Tbl.add name p !used_variables)
+ new_variables;
+ globalize_used_variables env false ();
end_def ();
generalize typ;
let univs =
else (v.desc <- Tunivar ; v :: acc))
[] !pre_univars
in
- type_variables := List.fold_right Tbl.remove !local_aliases !type_variables;
- reset_pre_univars ();
make_fixed_univars typ;
instance (Btype.newgenty (Tpoly (typ, univs)))
let transl_simple_type_delayed env styp =
- univars := [];
- used_variables := Tbl.empty;
- bindings := [];
- let typ = transl_type env Delayed styp in
- let b = !bindings in
- used_variables := Tbl.empty;
- bindings := [];
- (typ,
- function () ->
- List.iter
- (function (loc, t1, t2) ->
- try unify env t1 t2 with Unify trace ->
- raise (Error(loc, Type_mismatch trace)))
- b)
+ univars := []; used_variables := Tbl.empty;
+ let typ = transl_type env Extensible styp in
+ (typ, globalize_used_variables env false)
let transl_type_scheme env styp =
reset_type_variables();
--- /dev/null
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Damien Doligez, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2004 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id: unused_var.ml,v 1.4 2004/11/30 18:57:04 doligez Exp $ *)
+
+open Parsetree
+
+let silent v = String.length v > 0 && v.[0] = '_';;
+
+let add_vars tbl (vll1, vll2) =
+ let add_var (v, _loc, used) = Hashtbl.add tbl v used in
+ List.iter add_var vll1;
+ List.iter add_var vll2;
+;;
+
+let rm_vars tbl (vll1, vll2) =
+ let rm_var (v, _, _) = Hashtbl.remove tbl v in
+ List.iter rm_var vll1;
+ List.iter rm_var vll2;
+;;
+
+let w_suspicious x = Warnings.Unused_var x;;
+let w_strict x = Warnings.Unused_var_strict x;;
+
+let check_rm_vars ppf tbl (vlul_pat, vlul_as) =
+ let check_rm_var kind (v, loc, used) =
+ if not !used && not (silent v)
+ then Location.print_warning loc ppf (kind v);
+ Hashtbl.remove tbl v;
+ in
+ List.iter (check_rm_var w_strict) vlul_pat;
+ List.iter (check_rm_var w_suspicious) vlul_as;
+;;
+
+let check_rm_let ppf tbl vlulpl =
+ let check_rm_one flag (v, loc, used) =
+ Hashtbl.remove tbl v;
+ flag && (silent v || not !used)
+ in
+ let warn_var w_kind (v, loc, used) =
+ if not (silent v) && not !used
+ then Location.print_warning loc ppf (w_kind v)
+ in
+ let check_rm_pat (def, def_as) =
+ let def_unused = List.fold_left check_rm_one true def in
+ let all_unused = List.fold_left check_rm_one def_unused def_as in
+ List.iter (warn_var (if all_unused then w_suspicious else w_strict)) def;
+ List.iter (warn_var w_suspicious) def_as;
+ in
+ List.iter check_rm_pat vlulpl;
+;;
+
+let rec get_vars ((vacc, asacc) as acc) p =
+ match p.ppat_desc with
+ | Ppat_any -> acc
+ | Ppat_var v -> ((v, p.ppat_loc, ref false) :: vacc, asacc)
+ | Ppat_alias (pp, v) ->
+ get_vars (vacc, ((v, p.ppat_loc, ref false) :: asacc)) pp
+ | Ppat_constant _ -> acc
+ | Ppat_tuple pl -> List.fold_left get_vars acc pl
+ | Ppat_construct (_, po, _) -> get_vars_option acc po
+ | Ppat_variant (_, po) -> get_vars_option acc po
+ | Ppat_record ipl ->
+ 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_constraint (pp, _) -> get_vars acc pp
+ | Ppat_type _ -> acc
+
+and get_vars_option acc po =
+ match po with
+ | Some p -> get_vars acc p
+ | None -> acc
+;;
+
+let get_pel_vars pel =
+ List.map (fun (p, _) -> get_vars ([], []) p) pel
+;;
+
+let rec structure ppf tbl l =
+ List.iter (structure_item ppf tbl) l
+
+and structure_item ppf tbl s =
+ match s.pstr_desc with
+ | Pstr_eval e -> expression ppf tbl e;
+ | Pstr_value (recflag, pel) -> let_pel ppf tbl recflag pel None;
+ | Pstr_primitive _ -> ()
+ | Pstr_type _ -> ()
+ | Pstr_exception _ -> ()
+ | Pstr_exn_rebind _ -> ()
+ | Pstr_module (_, me) -> module_expr ppf tbl me;
+ | Pstr_recmodule stml ->
+ List.iter (fun (_, _, me) -> module_expr ppf tbl me) stml;
+ | Pstr_modtype _ -> ()
+ | Pstr_open _ -> ()
+ | Pstr_class cdl -> List.iter (class_declaration ppf tbl) cdl;
+ | Pstr_class_type _ -> ()
+ | Pstr_include _ -> ()
+
+and expression ppf tbl e =
+ match e.pexp_desc with
+ | Pexp_ident (Longident.Lident id) ->
+ begin try (Hashtbl.find tbl id) := true;
+ with Not_found -> ()
+ end;
+ | Pexp_ident _ -> ()
+ | Pexp_constant _ -> ()
+ | Pexp_let (recflag, pel, e) ->
+ let_pel ppf tbl recflag pel (Some (fun ppf tbl -> expression ppf tbl e));
+ | Pexp_function (_, eo, pel) ->
+ expression_option ppf tbl eo;
+ match_pel ppf tbl pel;
+ | Pexp_apply (e, lel) ->
+ expression ppf tbl e;
+ List.iter (fun (_, e) -> expression ppf tbl e) lel;
+ | Pexp_match (e, pel) ->
+ expression ppf tbl e;
+ match_pel ppf tbl pel;
+ | Pexp_try (e, pel) ->
+ expression ppf tbl e;
+ match_pel ppf tbl pel;
+ | Pexp_tuple el -> List.iter (expression ppf tbl) el;
+ | Pexp_construct (_, eo, _) -> expression_option ppf tbl eo;
+ | Pexp_variant (_, eo) -> expression_option ppf tbl eo;
+ | Pexp_record (iel, eo) ->
+ List.iter (fun (_, e) -> expression ppf tbl e) iel;
+ expression_option ppf tbl eo;
+ | Pexp_field (e, _) -> expression ppf tbl e;
+ | Pexp_setfield (e1, _, e2) ->
+ expression ppf tbl e1;
+ expression ppf tbl e2;
+ | Pexp_array el -> List.iter (expression ppf tbl) el;
+ | Pexp_ifthenelse (e1, e2, eo) ->
+ expression ppf tbl e1;
+ expression ppf tbl e2;
+ expression_option ppf tbl eo;
+ | Pexp_sequence (e1, e2) ->
+ expression ppf tbl e1;
+ expression ppf tbl e2;
+ | Pexp_while (e1, e2) ->
+ expression ppf tbl e1;
+ expression ppf tbl e2;
+ | Pexp_for (id, e1, e2, _, e3) ->
+ expression ppf tbl e1;
+ expression ppf tbl e2;
+ let defined = ([ (id, e.pexp_loc, ref false) ], []) in
+ add_vars tbl defined;
+ expression ppf tbl e3;
+ check_rm_vars ppf tbl defined;
+ | Pexp_constraint (e, _, _) -> expression ppf tbl e;
+ | Pexp_when (e1, e2) ->
+ expression ppf tbl e1;
+ expression ppf tbl e2;
+ | Pexp_send (e, _) -> expression ppf tbl e;
+ | Pexp_new _ -> ()
+ | Pexp_setinstvar (_, e) -> expression ppf tbl e;
+ | Pexp_override sel -> List.iter (fun (_, e) -> expression ppf tbl e) sel;
+ | Pexp_letmodule (_, me, e) ->
+ module_expr ppf tbl me;
+ expression ppf tbl e;
+ | Pexp_assert e -> expression ppf tbl e;
+ | Pexp_assertfalse -> ()
+ | Pexp_lazy e -> expression ppf tbl e;
+ | Pexp_poly (e, _) -> expression ppf tbl e;
+ | Pexp_object cs -> class_structure ppf tbl cs;
+
+and expression_option ppf tbl eo =
+ match eo with
+ | Some e -> expression ppf tbl e;
+ | None -> ()
+
+and let_pel ppf tbl recflag pel body =
+ match recflag with
+ | Asttypes.Recursive ->
+ let defined = get_pel_vars pel in
+ List.iter (add_vars tbl) defined;
+ List.iter (fun (_, e) -> expression ppf tbl e) pel;
+ begin match body with
+ | None ->
+ List.iter (rm_vars tbl) defined;
+ | Some f ->
+ f ppf tbl;
+ check_rm_let ppf tbl defined;
+ end;
+ | _ ->
+ List.iter (fun (_, e) -> expression ppf tbl e) pel;
+ begin match body with
+ | None -> ()
+ | Some f ->
+ let defined = get_pel_vars pel in
+ List.iter (add_vars tbl) defined;
+ f ppf tbl;
+ check_rm_let ppf tbl defined;
+ end;
+
+and match_pel ppf tbl pel =
+ List.iter (match_pe ppf tbl) pel
+
+and match_pe ppf tbl (p, e) =
+ let defined = get_vars ([], []) p in
+ add_vars tbl defined;
+ expression ppf tbl e;
+ check_rm_vars ppf tbl defined;
+
+and module_expr ppf tbl me =
+ match me.pmod_desc with
+ | Pmod_ident _ -> ()
+ | Pmod_structure s -> structure ppf tbl s
+ | Pmod_functor (_, _, me) -> module_expr ppf tbl me
+ | Pmod_apply (me1, me2) ->
+ module_expr ppf tbl me1;
+ module_expr ppf tbl me2;
+ | Pmod_constraint (me, _) -> module_expr ppf tbl me
+
+and class_declaration ppf tbl cd = class_expr ppf tbl cd.pci_expr
+
+and class_expr ppf tbl ce =
+ match ce.pcl_desc with
+ | Pcl_constr _ -> ()
+ | Pcl_structure cs -> class_structure ppf tbl cs
+ | Pcl_fun (_, _, _, ce) -> class_expr ppf tbl ce
+ | Pcl_apply (ce, _) -> class_expr ppf tbl ce
+ | Pcl_let (recflag, pel, ce) ->
+ let_pel ppf tbl recflag pel (Some (fun ppf tbl -> class_expr ppf tbl ce));
+ | Pcl_constraint (ce, _) -> class_expr ppf tbl ce;
+
+and class_structure ppf tbl (p, cfl) =
+ let defined = get_vars ([], []) p in
+ add_vars tbl defined;
+ List.iter (class_field ppf tbl) cfl;
+ check_rm_vars ppf tbl defined;
+
+and class_field ppf tbl cf =
+ match cf with
+ | Pcf_inher (ce, _) -> class_expr ppf tbl ce;
+ | Pcf_val (_, _, e, _) -> expression ppf tbl e;
+ | Pcf_virt _ -> ()
+ | Pcf_meth (_, _, e, _) -> expression ppf tbl e;
+ | Pcf_cstr _ -> ()
+ | Pcf_let (recflag, pel, _) -> let_pel ppf tbl recflag pel None;
+ | Pcf_init e -> expression ppf tbl e;
+;;
+
+let warn ppf ast =
+ if Warnings.is_active (w_suspicious "") || Warnings.is_active (w_strict "")
+ then begin
+ let tbl = Hashtbl.create 97 in
+ structure ppf tbl ast;
+ end;
+ ast
+;;
--- /dev/null
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Damien Doligez, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2004 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id: unused_var.mli,v 1.1 2005/10/26 12:39:02 doligez Exp $ *)
+
+val warn : Format.formatter -> Parsetree.structure -> Parsetree.structure;;
(* *)
(***********************************************************************)
-(* $Id: ccomp.ml,v 1.17.2.1 2005/02/02 15:39:40 xleroy Exp $ *)
+(* $Id: ccomp.ml,v 1.18 2005/03/24 17:20:54 doligez Exp $ *)
(* Compiling C files and building C libraries *)
(* *)
(***********************************************************************)
-(* $Id: clflags.ml,v 1.46 2003/07/17 08:38:28 xleroy Exp $ *)
+(* $Id: clflags.ml,v 1.49 2005/08/01 15:51:09 xleroy Exp $ *)
(* Command-line parameters *)
and use_vmthreads = ref false (* -vmthread *)
and noassert = ref false (* -noassert *)
and verbose = ref false (* -verbose *)
+and noprompt = ref false (* -noprompt *)
+and init_file = ref (None : string option) (* -init *)
and use_prims = ref "" (* -use-prims ... *)
and use_runtime = ref "" (* -use-runtime ... *)
and principal = ref false (* -principal *)
and no_auto_link = ref false (* -noautolink *)
and dllpaths = ref ([] : string list) (* -dllpath *)
and make_package = ref false (* -pack *)
+and for_package = ref (None: string option) (* -for-pack *)
let dump_parsetree = ref false (* -dparsetree *)
and dump_rawlambda = ref false (* -drawlambda *)
and dump_lambda = ref false (* -dlambda *)
--- /dev/null
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2005 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: clflags.mli,v 1.1 2005/10/26 13:23:27 doligez Exp $ *)
+
+val objfiles : string list ref
+val ccobjs : string list ref
+val dllibs : string list ref
+val compile_only : bool ref
+val output_name : string option ref
+val include_dirs : string list ref
+val no_std_include : bool ref
+val print_types : bool ref
+val make_archive : bool ref
+val debug : bool ref
+val fast : bool ref
+val link_everything : bool ref
+val custom_runtime : bool ref
+val output_c_object : bool ref
+val ccopts : string list ref
+val classic : bool ref
+val nopervasives : bool ref
+val preprocessor : string option ref
+val save_types : bool ref
+val use_threads : bool ref
+val use_vmthreads : bool ref
+val noassert : bool ref
+val verbose : bool ref
+val noprompt : bool ref
+val init_file : string option ref
+val use_prims : string ref
+val use_runtime : string ref
+val principal : bool ref
+val recursive_types : bool ref
+val make_runtime : bool ref
+val gprofile : bool ref
+val c_compiler : string ref
+val c_linker : string ref
+val no_auto_link : bool ref
+val dllpaths : string list ref
+val make_package : bool ref
+val for_package : string option ref
+val dump_parsetree : bool ref
+val dump_rawlambda : bool ref
+val dump_lambda : bool ref
+val dump_instr : bool ref
+val keep_asm_file : bool ref
+val optimize_for_speed : bool ref
+val dump_cmm : bool ref
+val dump_selection : bool ref
+val dump_live : bool ref
+val dump_spill : bool ref
+val dump_split : bool ref
+val dump_interf : bool ref
+val dump_prefer : bool ref
+val dump_regalloc : bool ref
+val dump_reload : bool ref
+val dump_scheduling : bool ref
+val dump_linear : bool ref
+val keep_startup_file : bool ref
+val dump_combine : bool ref
+val native_code : bool ref
+val inline_threshold : int ref
+val dont_write_files : bool ref
+val std_include_flag : string -> string
+val std_include_dir : unit -> string list
(* *)
(***********************************************************************)
-(* $Id: config.mli,v 1.33 2003/07/03 15:13:23 xleroy Exp $ *)
+(* $Id: config.mli,v 1.35 2005/08/01 15:51:09 xleroy Exp $ *)
(* System configuration *)
(* The linker to use for packaging (ocamlopt -pack) *)
val ranlib: string
(* Command to randomize a library, or "" if not needed *)
-val binutils_nm: string
- (* The "nm" command from GNU binutils, or "" if not available *)
-val binutils_objcopy: string
- (* The "objcopy" command from GNU binutils, or "" if not available *)
val cc_profile : string
(* The command line option to the C compiler to enable profiling. *)
val default_executable_name: string
(* Name of executable produced by linking if none is given with -o,
e.g. [a.out] under Unix. *)
+
+val systhread_supported : bool
+ (* Whether the system thread library is implemented *)
+
+val print_config : out_channel -> unit;;
(* *)
(***********************************************************************)
-(* $Id: config.mlp,v 1.196 2004/06/12 08:55:49 xleroy Exp $ *)
+(* $Id: config.mlp,v 1.198 2005/08/01 15:51:09 xleroy Exp $ *)
(* The main OCaml version string has moved to stdlib/sys.ml *)
let version = Sys.ocaml_version
+let standard_library_default = "%%LIBDIR%%"
+
let standard_library =
try
Sys.getenv "OCAMLLIB"
try
Sys.getenv "CAMLLIB"
with Not_found ->
- "%%LIBDIR%%"
+ standard_library_default
let standard_runtime = "%%BYTERUN%%"
let ccomp_type = "%%CCOMPTYPE%%"
let native_partial_linker = "%%PARTIALLD%%"
let native_pack_linker = "%%PACKLD%%"
let ranlib = "%%RANLIBCMD%%"
-let binutils_nm = "%%BINUTILS_NM%%"
-let binutils_objcopy = "%%BINUTILS_OBJCOPY%%"
let cc_profile = "%%CC_PROFILE%%"
let exec_magic_number = "Caml1999X008"
and cmi_magic_number = "Caml1999I010"
and cmo_magic_number = "Caml1999O006"
and cma_magic_number = "Caml1999A007"
-and cmx_magic_number = "Caml1999Y009"
+and cmx_magic_number = "Caml1999Y010"
and cmxa_magic_number = "Caml1999Z010"
and ast_impl_magic_number = "Caml1999M010"
and ast_intf_magic_number = "Caml1999N009"
"Unix" -> "a.out"
| "Win32" | "Cygwin" -> "camlprog.exe"
| _ -> "camlprog"
+
+let systhread_supported = %%SYSTHREAD_SUPPORT%%;;
+
+let print_config oc =
+ let p name valu = Printf.fprintf oc "%s: %s\n" name valu in
+ let p_bool name valu = Printf.fprintf oc "%s: %B\n" name valu in
+ p "version" version;
+ p "standard_library_default" standard_library_default;
+ p "standard_library" standard_library;
+ p "standard_runtime" standard_runtime;
+ p "ccomp_type" ccomp_type;
+ p "bytecomp_c_compiler" bytecomp_c_compiler;
+ p "bytecomp_c_linker" bytecomp_c_linker;
+ p "bytecomp_c_libraries" bytecomp_c_libraries;
+ p "native_c_compiler" native_c_compiler;
+ p "native_c_linker" native_c_linker;
+ p "native_c_libraries" native_c_libraries;
+ p "native_partial_linker" native_partial_linker;
+ p "ranlib" ranlib;
+ p "cc_profile" cc_profile;
+ p "architecture" architecture;
+ p "model" model;
+ p "system" system;
+ p "ext_obj" ext_obj;
+ p "ext_asm" ext_asm;
+ p "ext_lib" ext_lib;
+ p "ext_dll" ext_dll;
+ p "os_type" Sys.os_type;
+ p "default_executable_name" default_executable_name;
+ p_bool "systhread_supported" systhread_supported;
+ flush oc;
+;;
(* *)
(***********************************************************************)
-(* $Id: misc.ml,v 1.33.2.1 2004/07/07 16:47:27 xleroy Exp $ *)
+(* $Id: misc.ml,v 1.34 2004/07/13 12:25:20 xleroy Exp $ *)
(* Errors *)
(* *)
(***********************************************************************)
-(* $Id: misc.mli,v 1.24.6.1 2004/07/07 16:47:27 xleroy Exp $ *)
+(* $Id: misc.mli,v 1.25 2004/07/13 12:25:20 xleroy Exp $ *)
(* Miscellaneous useful types and functions *)
(* *)
(***********************************************************************)
-(* $Id: tbl.ml,v 1.12 2000/04/21 08:13:21 weis Exp $ *)
+(* $Id: tbl.ml,v 1.13 2004/11/25 13:28:27 doligez Exp $ *)
type ('a, 'b) t =
Empty
let rec add x data = function
Empty ->
Node(Empty, x, data, Empty, 1)
- | Node(l, v, d, r, h) as t ->
+ | Node(l, v, d, r, h) ->
let c = compare x v in
if c = 0 then
Node(l, x, data, r, h)
let rec remove x = function
Empty ->
Empty
- | Node(l, v, d, r, h) as t ->
+ | Node(l, v, d, r, h) ->
let c = compare x v in
if c = 0 then
merge l r
(* *)
(***********************************************************************)
-(* $Id: warnings.ml,v 1.17.4.1 2005/02/22 14:30:32 doligez Exp $ *)
+(* $Id: warnings.ml,v 1.23 2005/09/15 03:09:26 garrigue Exp $ *)
(* Please keep them in alphabetical order *)
type t = (* A is all *)
- | Comment of string (* C *)
+ | Comment_start (* C *)
+ | Comment_not_end
| Deprecated (* D *)
| Fragile_pat of string (* E *)
| Partial_application (* F *)
| Partial_match of string (* P *)
| Statement_type (* S *)
| Unused_match (* U *)
- | Unused_pat (* U *)
+ | Unused_pat
| Hide_instance_variable of string (* V *)
- | Other of string (* X *)
+ | Illegal_backslash (* X *)
+ | Implicit_public_methods of string list
+ | Unerasable_optional_argument
+ | Undeclared_virtual_method of string
+ | Not_principal of string
+ | Without_principality of string
+ | Unused_argument
+ | Nonreturning_statement
+ | Camlp4 of string
+ | All_clauses_guarded
+ | Useless_record_with
+ | Unused_var of string (* Y *)
+ | Unused_var_strict of string (* Z *)
;;
let letter = function (* 'a' is all *)
- | Comment _ -> 'c'
+ | Comment_start
+ | Comment_not_end -> 'c'
| Deprecated -> 'd'
| Fragile_pat _ -> 'e'
| Partial_application -> 'f'
| Method_override _ -> 'm'
| Partial_match _ -> 'p'
| Statement_type -> 's'
- | Unused_match|Unused_pat -> 'u'
+ | Unused_match
+ | Unused_pat -> 'u'
| Hide_instance_variable _ -> 'v'
- | Other _ -> 'x'
+ | Illegal_backslash
+ | Implicit_public_methods _
+ | Unerasable_optional_argument
+ | Undeclared_virtual_method _
+ | Not_principal _
+ | Without_principality _
+ | Unused_argument
+ | Nonreturning_statement
+ | Camlp4 _
+ | Useless_record_with
+ | All_clauses_guarded -> 'x'
+ | Unused_var _ -> 'y'
+ | Unused_var_strict _ -> 'z'
;;
let active = Array.create 27 true;;
done
;;
-let () = parse_options false "el";;
+let () = parse_options false "elz";;
let message = function
| Partial_match "" -> "this pattern-matching is not exhaustive."
maybe some arguments are missing."
| Statement_type ->
"this expression should have type unit."
- | Comment s -> "this is " ^ s ^ "."
+ | Comment_start -> "this is the start of a comment."
+ | Comment_not_end -> "this is not the end of a comment."
| Deprecated -> "this syntax is deprecated."
- | Other s -> s
+ | Unused_var v | Unused_var_strict v -> "unused variable " ^ v ^ "."
+ | Illegal_backslash -> "illegal backslash escape in string."
+ | Implicit_public_methods l ->
+ "the following private methods were made public implicitly:\n "
+ ^ String.concat " " l ^ "."
+ | Unerasable_optional_argument -> "this optional argument cannot be erased."
+ | Undeclared_virtual_method m -> "the virtual method "^m^" is not declared."
+ | Not_principal s -> s^" is not principal."
+ | Without_principality s -> s^" without principality."
+ | Unused_argument -> "this argument will not be used by the function."
+ | Nonreturning_statement -> "this statement never returns."
+ | Camlp4 s -> s
+ | All_clauses_guarded ->
+ "bad style, all clauses in this pattern-matching are guarded."
+ | Useless_record_with ->
+ "this record is defined by a `with' expression,\n\
+ but no fields are borrowed from the original."
;;
let nerrors = ref 0;;
let print ppf w =
let msg = message w in
+ let flag = Char.uppercase (letter w) in
let newlines = ref 0 in
for i = 0 to String.length msg - 1 do
if msg.[i] = '\n' then incr newlines;
in
let countnewline x = incr newlines; newline x in
Format.pp_set_all_formatter_output_functions ppf out flush countnewline space;
- Format.fprintf ppf "%s" msg;
+ Format.fprintf ppf "%c: %s" flag msg;
Format.pp_print_flush ppf ();
Format.pp_set_all_formatter_output_functions ppf out flush newline space;
let (n, _) = translate (letter w) in
(* *)
(***********************************************************************)
-(* $Id: warnings.mli,v 1.13 2003/05/02 08:46:06 weis Exp $ *)
+(* $Id: warnings.mli,v 1.16 2005/09/15 03:09:26 garrigue Exp $ *)
open Format
type t = (* A is all *)
- | Comment of string (* C *)
+ | Comment_start (* C *)
+ | Comment_not_end
| Deprecated (* D *)
| Fragile_pat of string (* E *)
| Partial_application (* F *)
| Partial_match of string (* P *)
| Statement_type (* S *)
| Unused_match (* U *)
- | Unused_pat (* U *)
+ | Unused_pat
| Hide_instance_variable of string (* V *)
- | Other of string (* X *)
+ | Illegal_backslash (* X *)
+ | Implicit_public_methods of string list
+ | Unerasable_optional_argument
+ | Undeclared_virtual_method of string
+ | Not_principal of string
+ | Without_principality of string
+ | Unused_argument
+ | Nonreturning_statement
+ | Camlp4 of string
+ | All_clauses_guarded
+ | Useless_record_with
+ | Unused_var of string (* Y *)
+ | Unused_var_strict of string (* Z *)
;;
val parse_options : bool -> string -> unit;;
/* Began 14 Sept 2003 - watford@uiuc.edu */
/***********************************************************************/
-/* $Id: ocaml.c,v 1.7.2.1 2004/08/09 08:51:09 xleroy Exp $ */
+/* $Id: ocaml.c,v 1.8 2004/08/20 17:04:35 doligez Exp $ */
/*@@ Wedit generated application. Written Sat Jun 02 18:22:38 2001
@@header: D:\lcc\inria\inriares.h
/* Began 14 Sept 2003 - watford@uiuc.edu */
/***********************************************************************/
-/* $Id: startocaml.c,v 1.9.2.2 2005/02/02 15:41:30 xleroy Exp $ */
+/* $Id: startocaml.c,v 1.11 2005/03/24 17:20:54 doligez Exp $ */
#include <windows.h>
#include <stdio.h>
ocamlyacc
*.c.x
ocamlyacc.xcoff
+version.h
# #
#########################################################################
-# $Id: Makefile,v 1.8 2000/08/10 09:58:08 xleroy Exp $
+# $Id: Makefile,v 1.9 2004/11/27 01:04:19 doligez Exp $
# Makefile for the parser generator.
ocamlyacc$(EXE): $(OBJS)
$(CC) $(CFLAGS) $(CCLINKFLAGS) -o ocamlyacc $(OBJS)
+version.h : ../stdlib/sys.ml
+ sed -n -e 's/;;//' \
+ -e '/let *ocaml_version *= */s//#define OCAML_VERSION /p' \
+ <../stdlib/sys.ml >version.h
+
clean:
- rm -f *.o ocamlyacc$(EXE) *~
+ rm -f *.o ocamlyacc$(EXE) *~ version.h
depend:
error.o: defs.h
lalr.o: defs.h
lr0.o: defs.h
-main.o: defs.h
+main.o: defs.h version.h
mkpar.o: defs.h
output.o: defs.h
reader.o: defs.h
# #
#########################################################################
-# $Id: Makefile.nt,v 1.4 2002/06/07 09:49:45 xleroy Exp $
+# $Id: Makefile.nt,v 1.5 2005/02/02 15:51:24 xleroy Exp $
# Makefile for the parser generator.
ocamlyacc.exe: $(OBJS)
$(BYTECC) $(BYTECCCOMPOPTS) -o ocamlyacc.exe $(OBJS)
+version.h : ../stdlib/sys.ml
+ sed -n -e 's/;;//' \
+ -e '/let *ocaml_version *= */s//#define OCAML_VERSION /p' \
+ <../stdlib/sys.ml >version.h
+
clean:
- rm -f *.$(O) ocamlyacc.exe *~
+ rm -f *.$(O) ocamlyacc.exe *~ version.h
.SUFFIXES: .c .$(O)
error.$(O): defs.h
lalr.$(O): defs.h
lr0.$(O): defs.h
-main.$(O): defs.h
+main.$(O): defs.h version.h
mkpar.$(O): defs.h
output.$(O): defs.h
reader.$(O): defs.h
/* Based on public-domain code from Berkeley Yacc */
-/* $Id: error.c,v 1.13 2004/06/12 11:59:11 xleroy Exp $ */
+/* $Id: error.c,v 1.15 2004/11/02 10:48:14 doligez Exp $ */
/* routines for printing error messages */
void unexpected_EOF(void)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", unexpected end-of-file\n",
- myname, lineno, virtual_input_file_name);
+ fprintf(stderr, "File \"%s\", line %d: unexpected end-of-file\n",
+ virtual_input_file_name, lineno);
done(1);
}
void syntax_error(int st_lineno, char *st_line, char *st_cptr)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", syntax error\n",
- myname, st_lineno, virtual_input_file_name);
+ fprintf(stderr, "File \"%s\", line %d: syntax error\n",
+ virtual_input_file_name, st_lineno);
print_pos(st_line, st_cptr);
done(1);
}
void unterminated_comment(int c_lineno, char *c_line, char *c_cptr)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", unmatched /*\n",
- myname, c_lineno, virtual_input_file_name);
+ fprintf(stderr, "File \"%s\", line %d: unmatched /*\n",
+ virtual_input_file_name, c_lineno);
print_pos(c_line, c_cptr);
done(1);
}
void unterminated_string(int s_lineno, char *s_line, char *s_cptr)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", unterminated string\n",
- myname, s_lineno, virtual_input_file_name);
+ fprintf(stderr, "File \"%s\", line %d: unterminated string\n",
+ virtual_input_file_name, s_lineno);
print_pos(s_line, s_cptr);
done(1);
}
void unterminated_text(int t_lineno, char *t_line, char *t_cptr)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", unmatched %%{\n",
- myname, t_lineno, virtual_input_file_name);
+ fprintf(stderr, "File \"%s\", line %d: unmatched %%{\n",
+ virtual_input_file_name, t_lineno);
print_pos(t_line, t_cptr);
done(1);
}
void unterminated_union(int u_lineno, char *u_line, char *u_cptr)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", unterminated %%union \
-declaration\n", myname, u_lineno, virtual_input_file_name);
+ fprintf(stderr, "File \"%s\", line %d: unterminated %%union declaration\n",
+ virtual_input_file_name, u_lineno);
print_pos(u_line, u_cptr);
done(1);
}
void over_unionized(char *u_cptr)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", too many %%union \
-declarations\n", myname, lineno, virtual_input_file_name);
+ fprintf(stderr, "File \"%s\", line %d: too many %%union declarations\n",
+ virtual_input_file_name, lineno);
print_pos(line, u_cptr);
done(1);
}
void illegal_tag(int t_lineno, char *t_line, char *t_cptr)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", illegal tag\n",
- myname, t_lineno, virtual_input_file_name);
+ fprintf(stderr, "File \"%s\", line %d: illegal tag\n",
+ virtual_input_file_name, t_lineno);
print_pos(t_line, t_cptr);
done(1);
}
void illegal_character(char *c_cptr)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", illegal character\n",
- myname, lineno, virtual_input_file_name);
+ fprintf(stderr, "File \"%s\", line %d: illegal character\n",
+ virtual_input_file_name, lineno);
print_pos(line, c_cptr);
done(1);
}
void used_reserved(char *s)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", illegal use of reserved symbol \
-%s\n", myname, lineno, virtual_input_file_name, s);
+ fprintf(stderr, "File \"%s\", line %d: illegal use of reserved symbol \
+`%s'\n", virtual_input_file_name, lineno, s);
done(1);
}
void tokenized_start(char *s)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", the start symbol %s cannot be \
-declared to be a token\n", myname, lineno, virtual_input_file_name, s);
+ fprintf(stderr, "File \"%s\", line %d: the start symbol `%s' cannot \
+be declared to be a token\n", virtual_input_file_name, lineno, s);
done(1);
}
void retyped_warning(char *s)
{
- fprintf(stderr, "%s: w - line %d of \"%s\", the type of %s has been \
-redeclared\n", myname, lineno, virtual_input_file_name, s);
+ fprintf(stderr, "File \"%s\", line %d: warning: the type of `%s' has been \
+redeclared\n", virtual_input_file_name, lineno, s);
}
void reprec_warning(char *s)
{
- fprintf(stderr, "%s: w - line %d of \"%s\", the precedence of %s has been \
-redeclared\n", myname, lineno, virtual_input_file_name, s);
+ fprintf(stderr, "File \"%s\", line %d: warning: the precedence of `%s' has \
+been redeclared\n", virtual_input_file_name, lineno, s);
}
void revalued_warning(char *s)
{
- fprintf(stderr, "%s: w - line %d of \"%s\", the value of %s has been \
-redeclared\n", myname, lineno, virtual_input_file_name, s);
+ fprintf(stderr, "File \"%s\", line %d: warning: the value of `%s' has been \
+redeclared\n", virtual_input_file_name, lineno, s);
}
void terminal_start(char *s)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", the entry point %s is a \
-token\n", myname, lineno, virtual_input_file_name, s);
+ fprintf(stderr, "File \"%s\", line %d: the entry point `%s' is a \
+token\n", virtual_input_file_name, lineno, s);
done(1);
}
void too_many_entries(void)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", more than 256 entry points\n",
- myname, lineno, virtual_input_file_name);
+ fprintf(stderr, "File \"%s\", line %d: more than 256 entry points\n",
+ virtual_input_file_name, lineno);
done(1);
}
void no_grammar(void)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", no grammar has been \
-specified\n", myname, lineno, virtual_input_file_name);
+ fprintf(stderr, "File \"%s\", line %d: no grammar has been specified\n",
+ virtual_input_file_name, lineno);
done(1);
}
void terminal_lhs(int s_lineno)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", a token appears on the lhs \
-of a production\n", myname, s_lineno, virtual_input_file_name);
+ fprintf(stderr, "File \"%s\", line %d: a token appears on the lhs \
+of a production\n", virtual_input_file_name, s_lineno);
done(1);
}
void prec_redeclared(void)
{
- fprintf(stderr, "%s: w - line %d of \"%s\", conflicting %%prec \
-specifiers\n", myname, lineno, virtual_input_file_name);
+ fprintf(stderr, "File \"%s\", line %d: warning: conflicting %%prec \
+specifiers\n", virtual_input_file_name, lineno);
}
void unterminated_action(int a_lineno, char *a_line, char *a_cptr)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", unterminated action\n",
- myname, a_lineno, virtual_input_file_name);
+ fprintf(stderr, "File \"%s\", line %d: unterminated action\n",
+ virtual_input_file_name, a_lineno);
print_pos(a_line, a_cptr);
done(1);
}
void dollar_warning(int a_lineno, int i)
{
- fprintf(stderr, "%s: w - line %d of \"%s\", $%d references beyond the \
-end of the current rule\n", myname, a_lineno, virtual_input_file_name, i);
+ fprintf(stderr, "File \"%s\", line %d: warning: $%d references beyond the \
+end of the current rule\n", virtual_input_file_name, a_lineno, i);
}
void dollar_error(int a_lineno, char *a_line, char *a_cptr)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", illegal $-name\n",
- myname, a_lineno, virtual_input_file_name);
+ fprintf(stderr, "File \"%s\", line %d: illegal $-name\n",
+ virtual_input_file_name, a_lineno);
print_pos(a_line, a_cptr);
done(1);
}
void untyped_lhs(void)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", $$ is untyped\n",
- myname, lineno, virtual_input_file_name);
+ fprintf(stderr, "File \"%s\", line %d: $$ is untyped\n",
+ virtual_input_file_name, lineno);
done(1);
}
void untyped_rhs(int i, char *s)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", $%d (%s) is untyped\n",
- myname, lineno, virtual_input_file_name, i, s);
+ fprintf(stderr, "File \"%s\", line %d: $%d (%s) is untyped\n",
+ virtual_input_file_name, lineno, i, s);
done(1);
}
void unknown_rhs(int i)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", $%d is unbound\n",
- myname, lineno, virtual_input_file_name, i);
+ fprintf(stderr, "File \"%s\", line %d: $%d is unbound\n",
+ virtual_input_file_name, lineno, i);
done(1);
}
void illegal_token_ref(int i, char *name)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", $%d refers to terminal `%s', which has no argument\n",
- myname, lineno, virtual_input_file_name, i, name);
+ fprintf(stderr, "File \"%s\", line %d: $%d refers to terminal `%s', \
+which has no argument\n",
+ virtual_input_file_name, lineno, i, name);
done(1);
}
void default_action_error(void)
{
- fprintf(stderr, "%s: e - line %d of \"%s\", no action specified for this production\n",
- myname, lineno, virtual_input_file_name);
+ fprintf(stderr, "File \"%s\", line %d: no action specified for this \
+production\n",
+ virtual_input_file_name, lineno);
done(1);
}
void undefined_goal(char *s)
{
- fprintf(stderr, "%s: e - the start symbol %s is undefined\n", myname, s);
+ fprintf(stderr, "%s: e - the start symbol `%s' is undefined\n", myname, s);
done(1);
}
void undefined_symbol(char *s)
{
- fprintf(stderr, "%s: e - the symbol %s is undefined\n", myname, s);
+ fprintf(stderr, "%s: e - the symbol `%s' is undefined\n", myname, s);
done(1);
}
void entry_without_type(char *s)
{
fprintf(stderr,
- "%s: e - no type has been declared for the start symbol %s\n",
+ "%s: e - no type has been declared for the start symbol `%s'\n",
myname, s);
done(1);
}
void polymorphic_entry_point(char *s)
{
fprintf(stderr,
- "%s: e - the start symbol %s has a polymorphic type\n",
+ "%s: e - the start symbol `%s' has a polymorphic type\n",
myname, s);
done(1);
}
-
/* Based on public-domain code from Berkeley Yacc */
-/* $Id: main.c,v 1.18 2004/04/21 23:26:05 doligez Exp $ */
+/* $Id: main.c,v 1.19 2004/11/27 01:04:19 doligez Exp $ */
#include <signal.h>
#include <string.h>
#include <unistd.h>
#endif
+#include "version.h"
+
char dflag;
char lflag;
char rflag;
goto no_more_options;
case 'v':
- vflag = 1;
+ if (!strcmp (argv[i], "-version")){
+ printf ("The Objective Caml parser generator, version "
+ OCAML_VERSION "\n");
+ exit (0);
+ }else{
+ vflag = 1;
+ }
break;
case 'q':
/* Based on public-domain code from Berkeley Yacc */
-/* $Id: reader.c,v 1.28.2.2 2005/06/21 12:28:35 doligez Exp $ */
+/* $Id: reader.c,v 1.32 2005/10/06 06:34:51 garrigue Exp $ */
#include <string.h>
#include "defs.h"
nrules-2, input_file_name, lineno);
*/
if (sflag)
- fprintf(f, "yyact.(%d) <- (fun parser_env ->\n", nrules-2);
+ fprintf(f, "yyact.(%d) <- (fun __caml_parser_env ->\n", nrules-2);
else
- fprintf(f, "; (fun parser_env ->\n");
+ fprintf(f, "; (fun __caml_parser_env ->\n");
n = 0;
for (i = nitems - 1; pitem[i]; --i) ++n;
if (item->class == TERM && !item->tag) continue;
fprintf(f, " let _%d = ", i);
if (item->tag)
- fprintf(f, "(Parsing.peek_val parser_env %d : %s) in\n", n - i,
+ fprintf(f, "(Parsing.peek_val __caml_parser_env %d : %s) in\n", n - i,
item->tag);
else if (sflag)
- fprintf(f, "Parsing.peek_val parser_env %d in\n", n - i);
+ fprintf(f, "Parsing.peek_val __caml_parser_env %d in\n", n - i);
else
- fprintf(f, "(Parsing.peek_val parser_env %d : '%s) in\n", n - i,
+ fprintf(f, "(Parsing.peek_val __caml_parser_env %d : '%s) in\n", n - i,
item->name);
}
fprintf(f, " Obj.repr(\n");
{
while (*s != 0) {
char c = *s++;
- if (c == '\'') return 1;
+ if (c == '\'' || c == '#') return 1;
+ if (c == '[') {
+ c = *s;
+ while (c == ' ' || c == '\t' || c == '\r' || c == '\n') c = *++s;
+ if (c == '<' || c == '>') return 1;
+ }
if (In_bitmap(caml_ident_start, c)) {
while (In_bitmap(caml_ident_body, *s)) s++;
}
"(* Entry %s *)\n", bp->name);
if (sflag)
fprintf(action_file,
- "yyact.(%d) <- (fun parser_env -> raise (Parsing.YYexit (Parsing.peek_val parser_env 0)))\n",
+ "yyact.(%d) <- (fun __caml_parser_env -> raise "
+ "(Parsing.YYexit (Parsing.peek_val __caml_parser_env 0)))\n",
ntotalrules);
else
fprintf(action_file,
- "; (fun parser_env -> raise (Parsing.YYexit (Parsing.peek_val parser_env 0)))\n");
+ "; (fun __caml_parser_env -> raise "
+ "(Parsing.YYexit (Parsing.peek_val __caml_parser_env 0)))\n");
ntotalrules++;
last_was_action = 1;
end_rule();
/* Based on public-domain code from Berkeley Yacc */
-/* $Id: skeleton.c,v 1.12.6.1 2005/06/21 12:28:36 doligez Exp $ */
+/* $Id: skeleton.c,v 1.13 2005/08/13 20:59:37 doligez Exp $ */
#include "defs.h"
projects / ocaml.git / commitdiff