diff --git a/.depend b/.depend index 9c00f119b..2c1a7958c 100644 --- a/.depend +++ b/.depend @@ -317,13 +317,13 @@ bytecomp/translobj.cmi: bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi bytecomp/typeopt.cmi: typing/typedtree.cmi typing/path.cmi \ bytecomp/lambda.cmi bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \ - typing/stypes.cmi typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \ + typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \ bytecomp/instruct.cmi typing/ident.cmi utils/config.cmi \ - parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi + parsing/asttypes.cmi bytecomp/bytegen.cmi bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \ - typing/stypes.cmx typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \ + typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \ bytecomp/instruct.cmx typing/ident.cmx utils/config.cmx \ - parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi + parsing/asttypes.cmi bytecomp/bytegen.cmi bytecomp/bytelibrarian.cmo: utils/misc.cmi utils/config.cmi \ bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \ bytecomp/bytelibrarian.cmi @@ -406,10 +406,12 @@ bytecomp/printlambda.cmx: typing/types.cmx typing/primitive.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.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/simplif.cmo: typing/stypes.cmi bytecomp/lambda.cmi typing/ident.cmi \ + utils/clflags.cmi parsing/asttypes.cmi typing/annot.cmi \ + bytecomp/simplif.cmi +bytecomp/simplif.cmx: typing/stypes.cmx bytecomp/lambda.cmx typing/ident.cmx \ + utils/clflags.cmx parsing/asttypes.cmi typing/annot.cmi \ + bytecomp/simplif.cmi bytecomp/switch.cmo: bytecomp/switch.cmi bytecomp/switch.cmx: bytecomp/switch.cmi bytecomp/symtable.cmo: utils/tbl.cmi bytecomp/runtimedef.cmi \ @@ -601,9 +603,9 @@ asmcomp/codegen.cmx: asmcomp/split.cmx asmcomp/spill.cmx asmcomp/reload.cmx \ asmcomp/coloring.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/coloring.cmi asmcomp/coloring.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/coloring.cmi asmcomp/comballoc.cmo: asmcomp/reg.cmi asmcomp/mach.cmi utils/config.cmi \ - asmcomp/comballoc.cmi + asmcomp/arch.cmo asmcomp/comballoc.cmi asmcomp/comballoc.cmx: asmcomp/reg.cmx asmcomp/mach.cmx utils/config.cmx \ - asmcomp/comballoc.cmi + asmcomp/arch.cmx asmcomp/comballoc.cmi asmcomp/compilenv.cmo: utils/misc.cmi typing/ident.cmi typing/env.cmi \ utils/config.cmi asmcomp/cmx_format.cmi asmcomp/clambda.cmi \ asmcomp/compilenv.cmi @@ -684,12 +686,14 @@ asmcomp/schedgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/schedgen.cmi asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/scheduling.cmi asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/scheduling.cmi -asmcomp/selectgen.cmo: utils/tbl.cmi asmcomp/reg.cmi asmcomp/proc.cmi \ - utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi asmcomp/debuginfo.cmi \ - asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/selectgen.cmi -asmcomp/selectgen.cmx: utils/tbl.cmx asmcomp/reg.cmx asmcomp/proc.cmx \ - utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx asmcomp/debuginfo.cmx \ - asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selectgen.cmi +asmcomp/selectgen.cmo: utils/tbl.cmi bytecomp/simplif.cmi asmcomp/reg.cmi \ + asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi \ + asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ + asmcomp/selectgen.cmi +asmcomp/selectgen.cmx: utils/tbl.cmx bytecomp/simplif.cmx asmcomp/reg.cmx \ + asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx \ + asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ + asmcomp/selectgen.cmi asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi asmcomp/proc.cmi \ utils/misc.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ utils/clflags.cmi asmcomp/arch.cmo asmcomp/selection.cmi diff --git a/Changes b/Changes index b0cefb050..13c40bd84 100644 --- a/Changes +++ b/Changes @@ -22,6 +22,104 @@ Standard library: Bug Fixes: +Objective Caml 3.12.1: +---------------------- + +Bug fixes: +- PR#4345, PR#4767: problems with camlp4 printing of float values +- PR#4380: ocamlbuild should not use tput on windows +- PR#4487, PR#5164: multiple 'module type of' are incompatible +- PR#4552: ocamlbuild does not create symlinks when using '.itarget' file +- PR#4673, PR#5144: camlp4 fails on object copy syntax +- PR#4702: system threads: cleanup tick thread at exit +- PR#4732: camlp4 rejects polymorphic variants using keywords from macros +- PR#4778: Win32/MSVC port: rare syntax error in generated MASM assembly file +- PR#4794, PR#4959: call annotations not generated by ocamlopt +- PR#4820: revised syntax pretty printer crashes with 'Stack_overflow' +- PR#4928: wrong printing of classes and class types by camlp4 +- PR#4939: camlp4 rejects patterns of the '?x:_' form +- PR#4967: ocamlbuild passes wrong switches to ocamldep through menhir +- PR#4972: mkcamlp4 does not include 'dynlink.cma' +- PR#5039: ocamlbuild should use '-linkpkg' only when linking programs +- PR#5066: ocamldoc: add -charset option used in html generator +- PR#5069: fcntl() in caml_sys_open may block, do it within blocking section +- PR#5071, PR#5129, PR#5134: inconsistencies between camlp4 and camlp4* binaries +- PR#5080, PR#5104: regression in type constructor handling by camlp4 +- PR#5090: bad interaction between toplevel and camlp4 +- PR#5095: ocamlbuild ignores some tags when building bytecode objects +- PR#5100: ocamlbuild always rebuilds a 'cmxs' file +- PR#5103: build and install objinfo when building with ocamlbuild +- PR#5109: crash when a parser calls a lexer that calls another parser +- PR#5110: invalid module name when using optional argument +- PR#5115: bytecode executables produced by msvc64 port crash on 32-bit versions +- PR#5117: bigarray: wrong function name without HAS_MMAP; missing include +- PR#5118: Camlp4o and integer literals +- PR#5122: camlp4 rejects lowercase identifiers for module types +- PR#5123: shift_right_big_int returns a wrong zero +- PR#5124: substitution inside a signature leads to odd printing +- PR#5128: typo in 'Camlp4ListComprehension' syntax extension +- PR#5136: obsolete function used in emacs mode +- PR#5145: ocamldoc: missing html escapes +- PR#5146: problem with spaces in multi-line string constants +- PR#5149: (partial) various documentation problems +- PR#5156: rare compiler crash with objects +- PR#5165: ocamlbuild does not pass '-thread' option to ocamlfind +- PR#5167: camlp4r loops when printing package type +- PR#5172: camlp4 support for 'module type of' construct +- PR#5175: in bigarray accesses, make sure bigarray expr is evaluated only once +- PR#5177: Gc.compact implies Gc.full_major +- PR#5182: use bytecode version of ocamldoc to generate man pages +- PR#5184: under Windows, alignment issue with bigarrays mapped from files +- PR#5188: double-free corruption in bytecode system threads +- PR#5192: mismatch between words and bytes in interpreting max_young_wosize +- PR#5202: error in documentation of atan2 +- PR#5209: natdynlink incorrectly detected on BSD systems +- PR#5213: ocamlbuild should pass '-rectypes' to ocamldoc when needed +- PR#5217: ocamlfind plugin should add '-linkpkg' for toplevel +- PR#5228: document the exceptions raised by functions in 'Filename' +- PR#5229: typo in build script ('TAG_LINE' vs 'TAGLINE') +- PR#5230: error in documentation of Scanf.Scanning.open_in +- PR#5234: option -shared reverses order of -cclib options +- PR#5237: incorrect .size directives generated for x86-32 and x86-64 +- PR#5244: String.compare uses polymorphic compare_val (regression of PR#4194) +- PR#5248: regression introduced while fixing PR#5118 +- PR#5252: typo in docs +- PR#5258: win32unix: unix fd leak under windows +- PR#5269: (tentative fix) Wrong ext_ref entries in .annot files +- PR#5272: caml.el doesn't recognize downto as a keyword +- PR#5276: issue with ocamlc -pack and recursively-packed modules +- PR#5280: alignment constraints incorrectly autodetected on MIPS 32 +- PR#5281: typo in error message +- PR#5308: unused variables not detected in "include (struct .. end)" +- camlp4 revised syntax printing bug in the toplevel (reported on caml-list) +- configure: do not define _WIN32 under cygwin +- Hardened generic comparison in the case where two custom blocks + are compared and have different sets of custom operations. +- Hardened comparison between bigarrays in the case where the two + bigarrays have different kinds. +- Fixed wrong autodetection of expm1() and log1p(). +- don't add .exe suffix when installing the ocamlmktop shell script +- ocamldoc: minor fixes related to the display of ocamldoc options +- fixed bug with huge values in OCAMLRUNPARAM +- mismatch between declaration and definition of caml_major_collection_slice + +Feature wishes: +- PR#4992: added '-ml-synonym' and '-mli-synonym' options to ocamldep +- PR#5065: added '-ocamldoc' option to ocamlbuild +- PR#5139: added possibility to add options to ocamlbuild +- PR#5158: added access to current camlp4 parsers and printers +- PR#5180: improved instruction selection for float operations on amd64 +- stdlib: added a 'usage_string' function to Arg +- allow with constraints to add a type equation to a datatype definition +- ocamldoc: allow to merge '@before' tags like other ones +- ocamlbuild: allow dependency on file "_oasis" + +Other changes: +- Changed default minor heap size from 32k to 256k words. +- Added new operation 'compare_ext' to custom blocks, called when + comparing a custom block value with an unboxed integer. + + Objective Caml 3.12.0: ---------------------- diff --git a/INSTALL b/INSTALL index 378ac8561..ba355b035 100644 --- a/INSTALL +++ b/INSTALL @@ -255,10 +255,6 @@ From the top directory, become superuser and do: umask 022 # make sure to give read & execute permission to all make install - In the ocamlbuild setting instead of make install do: - - ./build/install.sh - 7- Installation is complete. Time to clean up. From the toplevel directory, do "make clean". diff --git a/LICENSE b/LICENSE index cecc326cc..29b5c8503 100644 --- a/LICENSE +++ b/LICENSE @@ -6,8 +6,9 @@ INRIA" in the following directories and their sub-directories: and "the Compiler" refers to all files marked "Copyright INRIA" in the following directories and their sub-directories: - asmcomp, boot, bytecomp, debugger, driver, lex, ocamldoc, parsing, - tools, toplevel, typing, utils, yacc + asmcomp, boot, build, bytecomp, debugger, driver, lex, man, + ocamlbuild, ocamldoc, parsing, testsuite, tools, toplevel, typing, + utils, yacc The Compiler is distributed under the terms of the Q Public License version 1.0 with a change to choice of law (included below). diff --git a/README b/README index 7f588a6e3..703cbf1c4 100644 --- a/README +++ b/README @@ -21,7 +21,7 @@ native-code compiler currently runs on the following platforms: Tier 1 (actively used and maintained by the core Caml team): - AMD64 (Opteron) Linux + AMD64 (Opteron) Linux, MacOS X, MS Windows IA32 (Pentium) Linux, FreeBSD, MacOS X, MS Windows PowerPC MacOS X diff --git a/README.win32 b/README.win32 index 768743ae3..9a493d96a 100644 --- a/README.win32 +++ b/README.win32 @@ -37,7 +37,7 @@ the GPL. Thus, these .exe files can only be distributed under a license that is compatible with the GPL. Executables generated by MSVC or by MinGW have no such restrictions. -(**) The debugger is supported but the "replay" function of it are not enabled. +(**) The debugger is supported but the "replay" functions are not enabled. Other functions are available (step, goto, run...). The remainder of this document gives more information on each port. @@ -183,6 +183,10 @@ by Jacob Navia, then significantly improved by Christopher A. Watford. The native Win32 port built with Mingw -------------------------------------- +NOTE: Due to changes in cygwin's compilers, this port is not available +in OCaml 3.12.1. A patch will be made available soon after the release +of 3.12.1. + REQUIREMENTS: This port runs under MS Windows Vista, XP, and 2000. @@ -232,7 +236,7 @@ You will need the following software components to perform the recompilation: - Windows NT, 2000, XP, or Vista. - Cygwin: http://sourceware.cygnus.com/cygwin/ Install at least the following packages: binutils, diffutils, - gcc-core, gcc-mingw-core, make, mingw-runtime, ncurses, w32-api. + gcc-core, gcc-mingw-core, make, mingw-runtime, ncurses, w32api. - TCL/TK version 8.5 (see above). - The flexdll tool (see above). @@ -302,7 +306,9 @@ NOTES: The libraries available in this port are "num", "str", "threads", "unix" and "labltk". "graph" is not available. -The replay debugger is supported. +The replay debugger is fully supported. +When upgrading from 3.12.0 to 3.12.1, you will need to remove +/usr/local/bin/ocamlmktop.exe before typing "make install". ------------------------------------------------------------------------------ diff --git a/VERSION b/VERSION index c4057261b..ddd05a2f4 100644 --- a/VERSION +++ b/VERSION @@ -1,4 +1,4 @@ -3.13.0+dev4 (2011-06-20) +3.13.0+dev5 (2011-07-20) # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 40f95a285..a33a0fa9c 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -338,9 +338,12 @@ let emit_instr fallthrough i = | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then begin - if src.typ = Float then - ` movsd {emit_reg src}, {emit_reg dst}\n` - else + match src.typ, src.loc, dst.loc with + Float, Reg _, Reg _ -> + ` movapd {emit_reg src}, {emit_reg dst}\n` + | Float, _, _ -> + ` movsd {emit_reg src}, {emit_reg dst}\n` + | _ -> ` movq {emit_reg src}, {emit_reg dst}\n` end | Lop(Iconst_int n) -> @@ -359,7 +362,7 @@ let emit_instr fallthrough i = | _ -> let lbl = new_label() in float_constants := (lbl, s) :: !float_constants; - ` movlpd {emit_label lbl}(%rip), {emit_reg i.res.(0)}\n` + ` movsd {emit_label lbl}(%rip), {emit_reg i.res.(0)}\n` end | Lop(Iconst_symbol s) -> ` {load_symbol_addr s}, {emit_reg i.res.(0)}\n` @@ -412,7 +415,7 @@ let emit_instr fallthrough i = | Single -> ` cvtss2sd {emit_addressing addr i.arg 0}, {emit_reg dest}\n` | Double | Double_u -> - ` movlpd {emit_addressing addr i.arg 0}, {emit_reg dest}\n` + ` movsd {emit_addressing addr i.arg 0}, {emit_reg dest}\n` end | Lop(Istore(chunk, addr)) -> begin match chunk with @@ -428,7 +431,7 @@ let emit_instr fallthrough i = ` cvtsd2ss {emit_reg i.arg.(0)}, %xmm15\n`; ` movss %xmm15, {emit_addressing addr i.arg 1}\n` | Double | Double_u -> - ` movlpd {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` + ` movsd {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` end | Lop(Ialloc n) -> if !fastcode_flag then begin diff --git a/asmcomp/amd64/emit_nt.mlp b/asmcomp/amd64/emit_nt.mlp index 3374f4d36..724d6ee01 100644 --- a/asmcomp/amd64/emit_nt.mlp +++ b/asmcomp/amd64/emit_nt.mlp @@ -332,10 +332,13 @@ let emit_instr fallthrough i = | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then begin - if src.typ = Float then - ` movsd {emit_reg dst}, {emit_reg src}\n` - else - ` mov {emit_reg dst}, {emit_reg src}\n` + match src.typ, src.loc, dst.loc with + Float, Reg _, Reg _ -> + ` movapd {emit_reg dst}, {emit_reg src}\n` + | Float, _, _ -> + ` movsd {emit_reg dst}, {emit_reg src}\n` + | _ -> + ` mov {emit_reg dst}, {emit_reg src}\n` end | Lop(Iconst_int n) -> if n = 0n then begin @@ -357,7 +360,7 @@ let emit_instr fallthrough i = | _ -> let lbl = new_label() in float_constants := (lbl, s) :: !float_constants; - ` movlpd {emit_reg i.res.(0)}, {emit_label lbl}\n` + ` movsd {emit_reg i.res.(0)}, {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> add_used_symbol s; @@ -418,7 +421,7 @@ let emit_instr fallthrough i = | Single -> ` cvtss2sd {emit_reg dest}, REAL4 PTR {emit_addressing addr i.arg 0}\n` | Double | Double_u -> - ` movlpd {emit_reg dest}, REAL8 PTR {emit_addressing addr i.arg 0}\n` + ` movsd {emit_reg dest}, REAL8 PTR {emit_addressing addr i.arg 0}\n` end | Lop(Istore(chunk, addr)) -> begin match chunk with @@ -434,7 +437,7 @@ let emit_instr fallthrough i = ` cvtsd2ss xmm15, {emit_reg i.arg.(0)}\n`; ` movss REAL4 PTR {emit_addressing addr i.arg 1}, xmm15\n` | Double | Double_u -> - ` movlpd REAL8 PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` + ` movsd REAL8 PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` end | Lop(Ialloc n) -> if !fastcode_flag then begin diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 2f6966a24..dcec75ccb 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -262,7 +262,7 @@ let link_shared ppf objfiles output_name = Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; Clflags.ccopts := !lib_ccopts @ !Clflags.ccopts; let objfiles = List.rev (List.map object_file_name objfiles) @ - !Clflags.ccobjs in + (List.rev !Clflags.ccobjs) in let startup = if !Clflags.keep_startup_file diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 11006df8f..8f2a034c2 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -544,7 +544,7 @@ let rec close fenv cenv = function | ((ufunct, _), uargs) -> (Ugeneric_apply(ufunct, uargs, Debuginfo.none), Value_unknown) end - | Lsend(kind, met, obj, args) -> + | Lsend(kind, met, obj, args, _) -> let (umet, _) = close fenv cenv met in let (uobj, _) = close fenv cenv obj in (Usend(kind, umet, uobj, close_list fenv cenv args, Debuginfo.none), diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 40f7650d9..87a77c623 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -580,32 +580,34 @@ let bigarray_word_kind = function | Pbigarray_complex64 -> Double let bigarray_get unsafe elt_kind layout b args dbg = - match elt_kind with - Pbigarray_complex32 | Pbigarray_complex64 -> - let kind = bigarray_word_kind elt_kind in - let sz = bigarray_elt_size elt_kind / 2 in - bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr -> - box_complex - (Cop(Cload kind, [addr])) - (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])]))) - | _ -> - Cop(Cload (bigarray_word_kind elt_kind), - [bigarray_indexing unsafe elt_kind layout b args dbg]) + bind "ba" b (fun b -> + match elt_kind with + Pbigarray_complex32 | Pbigarray_complex64 -> + let kind = bigarray_word_kind elt_kind in + let sz = bigarray_elt_size elt_kind / 2 in + bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr -> + box_complex + (Cop(Cload kind, [addr])) + (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])]))) + | _ -> + Cop(Cload (bigarray_word_kind elt_kind), + [bigarray_indexing unsafe elt_kind layout b args dbg])) let bigarray_set unsafe elt_kind layout b args newval dbg = - match elt_kind with - Pbigarray_complex32 | Pbigarray_complex64 -> - let kind = bigarray_word_kind elt_kind in - let sz = bigarray_elt_size elt_kind / 2 in - bind "newval" newval (fun newv -> - bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr -> - Csequence( - Cop(Cstore kind, [addr; complex_re newv]), - Cop(Cstore kind, - [Cop(Cadda, [addr; Cconst_int sz]); complex_im newv])))) - | _ -> - Cop(Cstore (bigarray_word_kind elt_kind), - [bigarray_indexing unsafe elt_kind layout b args dbg; newval]) + bind "ba" b (fun b -> + match elt_kind with + Pbigarray_complex32 | Pbigarray_complex64 -> + let kind = bigarray_word_kind elt_kind in + let sz = bigarray_elt_size elt_kind / 2 in + bind "newval" newval (fun newv -> + bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr -> + Csequence( + Cop(Cstore kind, [addr; complex_re newv]), + Cop(Cstore kind, + [Cop(Cadda, [addr; Cconst_int sz]); complex_im newv])))) + | _ -> + Cop(Cstore (bigarray_word_kind elt_kind), + [bigarray_indexing unsafe elt_kind layout b args dbg; newval])) (* Simplification of some primitives into C calls *) diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml index 5a862b172..13dbcaffe 100644 --- a/asmcomp/comballoc.ml +++ b/asmcomp/comballoc.ml @@ -38,7 +38,7 @@ let rec combine i allocstate = combine i.next (Pending_alloc(i.res.(0), sz)) in (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, 0) | Pending_alloc(reg, ofs) -> - if ofs + sz < Config.max_young_wosize then begin + if ofs + sz < Config.max_young_wosize * Arch.size_addr then begin let (newnext, newsz) = combine i.next (Pending_alloc(reg, ofs + sz)) in (instr_cons (Iop(Iintop_imm(Iadd, ofs))) [| reg |] i.res newnext, diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index da1606e44..7091b3df8 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -813,7 +813,7 @@ let emit_item = function add_def_symbol s ; `{emit_symbol s} LABEL DWORD\n` | Cdefine_label lbl -> - `{emit_label (100000 + lbl)} ` + `{emit_label (100000 + lbl)} LABEL DWORD\n` | Cint8 n -> ` BYTE {emit_int n}\n` | Cint16 n -> diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index a8979235e..50f949a77 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -824,3 +824,17 @@ method emit_fundecl f = fun_fast = f.Cmm.fun_fast } end + +(* Tail call criterion (estimated). Assumes: +- all arguments are of type "int" (always the case for Caml function calls) +- one extra argument representing the closure environment (conservative). +*) + +let is_tail_call nargs = + assert (Reg.dummy.typ = Int); + let args = Array.make (nargs + 1) Reg.dummy in + let (loc_arg, stack_ofs) = Proc.loc_arguments args in + stack_ofs = 0 + +let _ = + Simplif.is_tail_native_heuristic := is_tail_call diff --git a/asmrun/amd64.S b/asmrun/amd64.S index 97de51839..645c2e616 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -147,44 +147,44 @@ FUNCTION(G(caml_call_gc)) STORE_VAR(%r14, caml_exception_pointer) /* Save floating-point registers */ subq $(16*8), %rsp - movlpd %xmm0, 0*8(%rsp) - movlpd %xmm1, 1*8(%rsp) - movlpd %xmm2, 2*8(%rsp) - movlpd %xmm3, 3*8(%rsp) - movlpd %xmm4, 4*8(%rsp) - movlpd %xmm5, 5*8(%rsp) - movlpd %xmm6, 6*8(%rsp) - movlpd %xmm7, 7*8(%rsp) - movlpd %xmm8, 8*8(%rsp) - movlpd %xmm9, 9*8(%rsp) - movlpd %xmm10, 10*8(%rsp) - movlpd %xmm11, 11*8(%rsp) - movlpd %xmm12, 12*8(%rsp) - movlpd %xmm13, 13*8(%rsp) - movlpd %xmm14, 14*8(%rsp) - movlpd %xmm15, 15*8(%rsp) + movsd %xmm0, 0*8(%rsp) + movsd %xmm1, 1*8(%rsp) + movsd %xmm2, 2*8(%rsp) + movsd %xmm3, 3*8(%rsp) + movsd %xmm4, 4*8(%rsp) + movsd %xmm5, 5*8(%rsp) + movsd %xmm6, 6*8(%rsp) + movsd %xmm7, 7*8(%rsp) + movsd %xmm8, 8*8(%rsp) + movsd %xmm9, 9*8(%rsp) + movsd %xmm10, 10*8(%rsp) + movsd %xmm11, 11*8(%rsp) + movsd %xmm12, 12*8(%rsp) + movsd %xmm13, 13*8(%rsp) + movsd %xmm14, 14*8(%rsp) + movsd %xmm15, 15*8(%rsp) /* Call the garbage collector */ call GCALL(caml_garbage_collection) /* Restore caml_young_ptr, caml_exception_pointer */ LOAD_VAR(caml_young_ptr, %r15) LOAD_VAR(caml_exception_pointer, %r14) /* Restore all regs used by the code generator */ - movlpd 0*8(%rsp), %xmm0 - movlpd 1*8(%rsp), %xmm1 - movlpd 2*8(%rsp), %xmm2 - movlpd 3*8(%rsp), %xmm3 - movlpd 4*8(%rsp), %xmm4 - movlpd 5*8(%rsp), %xmm5 - movlpd 6*8(%rsp), %xmm6 - movlpd 7*8(%rsp), %xmm7 - movlpd 8*8(%rsp), %xmm8 - movlpd 9*8(%rsp), %xmm9 - movlpd 10*8(%rsp), %xmm10 - movlpd 11*8(%rsp), %xmm11 - movlpd 12*8(%rsp), %xmm12 - movlpd 13*8(%rsp), %xmm13 - movlpd 14*8(%rsp), %xmm14 - movlpd 15*8(%rsp), %xmm15 + movsd 0*8(%rsp), %xmm0 + movsd 1*8(%rsp), %xmm1 + movsd 2*8(%rsp), %xmm2 + movsd 3*8(%rsp), %xmm3 + movsd 4*8(%rsp), %xmm4 + movsd 5*8(%rsp), %xmm5 + movsd 6*8(%rsp), %xmm6 + movsd 7*8(%rsp), %xmm7 + movsd 8*8(%rsp), %xmm8 + movsd 9*8(%rsp), %xmm9 + movsd 10*8(%rsp), %xmm10 + movsd 11*8(%rsp), %xmm11 + movsd 12*8(%rsp), %xmm12 + movsd 13*8(%rsp), %xmm13 + movsd 14*8(%rsp), %xmm14 + movsd 15*8(%rsp), %xmm15 addq $(16*8), %rsp popq %rax popq %rbx diff --git a/asmrun/amd64nt.asm b/asmrun/amd64nt.asm index c1d97e05b..4c31bc873 100644 --- a/asmrun/amd64nt.asm +++ b/asmrun/amd64nt.asm @@ -67,43 +67,43 @@ L105: mov caml_gc_regs, rsp ; Save floating-point registers sub rsp, 16*8 - movlpd QWORD PTR [rsp + 0*8], xmm0 - movlpd QWORD PTR [rsp + 1*8], xmm1 - movlpd QWORD PTR [rsp + 2*8], xmm2 - movlpd QWORD PTR [rsp + 3*8], xmm3 - movlpd QWORD PTR [rsp + 4*8], xmm4 - movlpd QWORD PTR [rsp + 5*8], xmm5 - movlpd QWORD PTR [rsp + 6*8], xmm6 - movlpd QWORD PTR [rsp + 7*8], xmm7 - movlpd QWORD PTR [rsp + 8*8], xmm8 - movlpd QWORD PTR [rsp + 9*8], xmm9 - movlpd QWORD PTR [rsp + 10*8], xmm10 - movlpd QWORD PTR [rsp + 11*8], xmm11 - movlpd QWORD PTR [rsp + 12*8], xmm12 - movlpd QWORD PTR [rsp + 13*8], xmm13 - movlpd QWORD PTR [rsp + 14*8], xmm14 - movlpd QWORD PTR [rsp + 15*8], xmm15 + movsd QWORD PTR [rsp + 0*8], xmm0 + movsd QWORD PTR [rsp + 1*8], xmm1 + movsd QWORD PTR [rsp + 2*8], xmm2 + movsd QWORD PTR [rsp + 3*8], xmm3 + movsd QWORD PTR [rsp + 4*8], xmm4 + movsd QWORD PTR [rsp + 5*8], xmm5 + movsd QWORD PTR [rsp + 6*8], xmm6 + movsd QWORD PTR [rsp + 7*8], xmm7 + movsd QWORD PTR [rsp + 8*8], xmm8 + movsd QWORD PTR [rsp + 9*8], xmm9 + movsd QWORD PTR [rsp + 10*8], xmm10 + movsd QWORD PTR [rsp + 11*8], xmm11 + movsd QWORD PTR [rsp + 12*8], xmm12 + movsd QWORD PTR [rsp + 13*8], xmm13 + movsd QWORD PTR [rsp + 14*8], xmm14 + movsd QWORD PTR [rsp + 15*8], xmm15 ; Call the garbage collector sub rsp, 32 ; PR#5008: bottom 32 bytes are reserved for callee call caml_garbage_collection add rsp, 32 ; PR#5008 ; Restore all regs used by the code generator - movlpd xmm0, QWORD PTR [rsp + 0*8] - movlpd xmm1, QWORD PTR [rsp + 1*8] - movlpd xmm2, QWORD PTR [rsp + 2*8] - movlpd xmm3, QWORD PTR [rsp + 3*8] - movlpd xmm4, QWORD PTR [rsp + 4*8] - movlpd xmm5, QWORD PTR [rsp + 5*8] - movlpd xmm6, QWORD PTR [rsp + 6*8] - movlpd xmm7, QWORD PTR [rsp + 7*8] - movlpd xmm8, QWORD PTR [rsp + 8*8] - movlpd xmm9, QWORD PTR [rsp + 9*8] - movlpd xmm10, QWORD PTR [rsp + 10*8] - movlpd xmm11, QWORD PTR [rsp + 11*8] - movlpd xmm12, QWORD PTR [rsp + 12*8] - movlpd xmm13, QWORD PTR [rsp + 13*8] - movlpd xmm14, QWORD PTR [rsp + 14*8] - movlpd xmm15, QWORD PTR [rsp + 15*8] + movsd xmm0, QWORD PTR [rsp + 0*8] + movsd xmm1, QWORD PTR [rsp + 1*8] + movsd xmm2, QWORD PTR [rsp + 2*8] + movsd xmm3, QWORD PTR [rsp + 3*8] + movsd xmm4, QWORD PTR [rsp + 4*8] + movsd xmm5, QWORD PTR [rsp + 5*8] + movsd xmm6, QWORD PTR [rsp + 6*8] + movsd xmm7, QWORD PTR [rsp + 7*8] + movsd xmm8, QWORD PTR [rsp + 8*8] + movsd xmm9, QWORD PTR [rsp + 9*8] + movsd xmm10, QWORD PTR [rsp + 10*8] + movsd xmm11, QWORD PTR [rsp + 11*8] + movsd xmm12, QWORD PTR [rsp + 12*8] + movsd xmm13, QWORD PTR [rsp + 13*8] + movsd xmm14, QWORD PTR [rsp + 14*8] + movsd xmm15, QWORD PTR [rsp + 15*8] add rsp, 16*8 pop rax pop rbx diff --git a/boot/ocamlc b/boot/ocamlc index 96c7c4594..8b5982d7c 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep index 3632a5398..143c6a27c 100755 Binary files a/boot/ocamldep and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index b9e6382ac..50e5cc5f1 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/build/boot.sh b/build/boot.sh index 7329d20b7..3de6006ab 100755 --- a/build/boot.sh +++ b/build/boot.sh @@ -2,7 +2,7 @@ # $Id$ cd `dirname $0`/.. set -ex -TAGLINE='true: -use_stdlib' +TAG_LINE='true: -use_stdlib' ./boot/ocamlrun boot/myocamlbuild.boot \ -tag-line "$TAG_LINE" \ boot/stdlib.cma boot/std_exit.cmo diff --git a/build/camlp4-bootstrap-recipe.txt b/build/camlp4-bootstrap-recipe.txt index 9f1417a2f..264d63551 100644 --- a/build/camlp4-bootstrap-recipe.txt +++ b/build/camlp4-bootstrap-recipe.txt @@ -95,7 +95,8 @@ Then "Generate Camlp4Ast.ml" and build. We get a single warning in Camlp4/Struct/Camlp4Ast2OCamlAst.ml but - don't fix it now. + don't fix it now. Notice that you may need to disable '-warn-error' + in order to be able to successfully compile, despite of the warning. Then I hacked the camlp4/boot/camlp4boot.ml to generate: Ast.ExOpI(_loc, i, e) diff --git a/build/camlp4-byte-only.sh b/build/camlp4-byte-only.sh index ab98ef50f..39b346172 100755 --- a/build/camlp4-byte-only.sh +++ b/build/camlp4-byte-only.sh @@ -8,8 +8,7 @@ # # # Copyright 2008 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file LICENSE. # +# under the terms of the Q Public License version 1.0. # # # ######################################################################### diff --git a/build/camlp4-native-only.sh b/build/camlp4-native-only.sh index d9bdbd1db..629684b7b 100755 --- a/build/camlp4-native-only.sh +++ b/build/camlp4-native-only.sh @@ -8,8 +8,7 @@ # # # Copyright 2008 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file LICENSE. # +# under the terms of the Q Public License version 1.0. # # # ######################################################################### diff --git a/build/fastworld.sh b/build/fastworld.sh index 10ffa812f..826390805 100755 --- a/build/fastworld.sh +++ b/build/fastworld.sh @@ -8,8 +8,7 @@ # # # Copyright 2008 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file LICENSE. # +# under the terms of the Q Public License version 1.0. # # # ######################################################################### @@ -45,3 +44,7 @@ cp _build/myocamlbuild boot/myocamlbuild.native $OCAMLC_NATIVE $TOPLEVEL $OTHERLIBS_BYTE $OTHERLIBS_NATIVE $OCAMLLEX_BYTE \ $OCAMLLEX_NATIVE $TOOLS_BYTE $TOOLS_NATIVE $DEBUGGER \ $OCAMLDOC_BYTE $OCAMLDOC_NATIVE $OCAMLBUILD_BYTE $CAMLP4_BYTE $CAMLP4_NATIVE + +cd tools +make objinfo_helper +cd .. diff --git a/build/install.sh b/build/install.sh index 1a60a87ec..264d59831 100755 --- a/build/install.sh +++ b/build/install.sh @@ -264,6 +264,8 @@ installbin lex/ocamllex.opt$EXE $BINDIR/ocamllex.opt$EXE installbin tools/ocamldep.native$EXE $BINDIR/ocamldep.opt$EXE echo "Installing some tools..." +installbin tools/objinfo.byte$EXE $BINDIR/ocamlobjinfo$EXE +installbin ../tools/objinfo_helper$EXE $LIBDIR/objinfo_helper$EXE installbin tools/ocamlcp.byte$EXE $BINDIR/ocamlcp$EXE installbin tools/ocamldep.byte$EXE $BINDIR/ocamldep$EXE installbin tools/ocamlmklib.byte$EXE $BINDIR/ocamlmklib$EXE diff --git a/build/ocamlbuild-byte-only.sh b/build/ocamlbuild-byte-only.sh index 17f7b87a8..2f226d422 100755 --- a/build/ocamlbuild-byte-only.sh +++ b/build/ocamlbuild-byte-only.sh @@ -8,8 +8,7 @@ # # # Copyright 2008 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file LICENSE. # +# under the terms of the Q Public License version 1.0. # # # ######################################################################### diff --git a/build/ocamlbuild-native-only.sh b/build/ocamlbuild-native-only.sh index ce9641274..c61f6a1ab 100755 --- a/build/ocamlbuild-native-only.sh +++ b/build/ocamlbuild-native-only.sh @@ -8,8 +8,7 @@ # # # Copyright 2008 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file LICENSE. # +# under the terms of the Q Public License version 1.0. # # # ######################################################################### diff --git a/build/ocamlbuildlib-native-only.sh b/build/ocamlbuildlib-native-only.sh index a7a570a92..52bfb8fe2 100755 --- a/build/ocamlbuildlib-native-only.sh +++ b/build/ocamlbuildlib-native-only.sh @@ -8,8 +8,7 @@ # # # Copyright 2008 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file LICENSE. # +# under the terms of the Q Public License version 1.0. # # # ######################################################################### diff --git a/build/otherlibs-targets.sh b/build/otherlibs-targets.sh index 301b75f19..e3d9fedf2 100644 --- a/build/otherlibs-targets.sh +++ b/build/otherlibs-targets.sh @@ -8,8 +8,7 @@ # # # Copyright 2008 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file LICENSE. # +# under the terms of the Q Public License version 1.0. # # # ######################################################################### diff --git a/build/targets.sh b/build/targets.sh index 09e619b62..8d698423f 100644 --- a/build/targets.sh +++ b/build/targets.sh @@ -29,7 +29,8 @@ OCAMLBUILD_BYTE="ocamlbuild/ocamlbuildlib.cma \ ocamlbuild/ocamlbuild.byte$EXE \ ocamlbuild/ocamlbuildlight.byte$EXE" TOPLEVEL=ocaml$EXE -TOOLS_BYTE="tools/ocamldep.byte$EXE tools/profiling.cmo \ +TOOLS_BYTE="tools/objinfo.byte$EXE \ + tools/ocamldep.byte$EXE tools/profiling.cmo \ tools/ocamlprof.byte$EXE tools/ocamlcp.byte$EXE \ tools/ocamlmktop.byte$EXE tools/ocamlmklib$EXE \ tools/scrapelabels.byte tools/addlabels.byte \ diff --git a/build/world.sh b/build/world.sh index 0b9a4b289..534bce545 100755 --- a/build/world.sh +++ b/build/world.sh @@ -8,8 +8,7 @@ # # # Copyright 2008 Institut National de Recherche en Informatique et # # en Automatique. All rights reserved. This file is distributed # -# under the terms of the GNU Library General Public License, with # -# the special exception on linking described in file LICENSE. # +# under the terms of the Q Public License version 1.0. # # # ######################################################################### diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 09c254d4f..b6c8f6fae 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -413,12 +413,10 @@ let rec comp_expr env exp sz cont = | Lapply(func, args, loc) -> let nargs = List.length args in if is_tailcall cont then begin - Stypes.record (Stypes.An_call (loc, Annot.Tail)); comp_args env args sz (Kpush :: comp_expr env func (sz + nargs) (Kappterm(nargs, sz + nargs) :: discard_dead_code cont)) end else begin - Stypes.record (Stypes.An_call (loc, Annot.Stack)); if nargs < 4 then comp_args env args sz (Kpush :: comp_expr env func (sz + nargs) (Kapply nargs :: cont)) @@ -430,7 +428,7 @@ let rec comp_expr env exp sz cont = (Kapply nargs :: cont1)) end end - | Lsend(kind, met, obj, args) -> + | Lsend(kind, met, obj, args, _) -> let args = if kind = Cached then List.tl args else args in let nargs = List.length args + 1 in let getmethod, args' = @@ -746,9 +744,9 @@ let rec comp_expr env exp sz cont = | Lev_after ty -> let info = match lam with - Lapply(_, args, _) -> Event_return (List.length args) - | Lsend(_, _, _, args) -> Event_return (List.length args + 1) - | _ -> Event_other + Lapply(_, args, _) -> Event_return (List.length args) + | Lsend(_, _, _, args, _) -> Event_return (List.length args + 1) + | _ -> Event_other in let ev = event (Event_after ty) info in let cont1 = add_event ev cont in diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index b4accdc9e..15c6f7f58 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -407,15 +407,15 @@ let link_bytecode_as_c tolink outfile = begin try (* The bytecode *) output_string outchan "\ -#ifdef __cplusplus\n\ -extern \"C\" {\n\ -#endif\n\ -#include \n\ -CAMLextern void caml_startup_code(\n\ - code_t code, asize_t code_size,\n\ - char *data, asize_t data_size,\n\ - char *section_table, asize_t section_table_size,\n\ - char **argv);\n"; +#ifdef __cplusplus\ +\nextern \"C\" {\ +\n#endif\ +\n#include \ +\nCAMLextern void caml_startup_code(\ +\n code_t code, asize_t code_size,\ +\n char *data, asize_t data_size,\ +\n char *section_table, asize_t section_table_size,\ +\n char **argv);\n"; output_string outchan "static int caml_code[] = {\n"; Symtable.init(); Consistbl.clear crc_interfaces; @@ -444,17 +444,17 @@ CAMLextern void caml_startup_code(\n\ (* The table of primitives *) Symtable.output_primitive_table outchan; (* The entry point *) - output_string outchan "\n\ -void caml_startup(char ** argv)\n\ -{\n\ - caml_startup_code(caml_code, sizeof(caml_code),\n\ - caml_data, sizeof(caml_data),\n\ - caml_sections, sizeof(caml_sections),\n\ - argv);\n\ -}\n\ -#ifdef __cplusplus\n\ -}\n\ -#endif\n"; + output_string outchan "\ +\nvoid caml_startup(char ** argv)\ +\n{\ +\n caml_startup_code(caml_code, sizeof(caml_code),\ +\n caml_data, sizeof(caml_data),\ +\n caml_sections, sizeof(caml_sections),\ +\n argv);\ +\n}\ +\n#ifdef __cplusplus\ +\n}\ +\n#endif\n"; close_out outchan with x -> close_out outchan; diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 6649aa3d5..e2b6ff54b 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -39,7 +39,7 @@ let force_link = ref false SETGLOBAL relocations that correspond to one of the units being consolidated. *) -let rename_relocation objfile mapping defined base (rel, ofs) = +let rename_relocation packagename objfile mapping defined base (rel, ofs) = let rel' = match rel with Reloc_getglobal id -> @@ -49,7 +49,14 @@ let rename_relocation objfile mapping defined base (rel, ofs) = then Reloc_getglobal id' else raise(Error(Forward_reference(objfile, id))) with Not_found -> - rel + (* PR#5276: unique-ize dotted global names, which appear + if one of the units being consolidated is itself a packed + module. *) + let name = Ident.name id in + if String.contains name '.' then + Reloc_getglobal (Ident.create_persistent (packagename ^ "." ^ name)) + else + rel end | Reloc_setglobal id -> begin try @@ -58,7 +65,12 @@ let rename_relocation objfile mapping defined base (rel, ofs) = then raise(Error(Multiple_definition(objfile, id))) else Reloc_setglobal id' with Not_found -> - rel + (* PR#5276, as above *) + let name = Ident.name id in + if String.contains name '.' then + Reloc_setglobal (Ident.create_persistent (packagename ^ "." ^ name)) + else + rel end | _ -> rel in @@ -112,12 +124,12 @@ let read_member_info file = Accumulate relocs, debug info, etc. Return size of bytecode. *) -let rename_append_bytecode oc mapping defined ofs prefix subst objfile compunit = +let rename_append_bytecode packagename oc mapping defined ofs prefix subst objfile compunit = let ic = open_in_bin objfile in try Bytelink.check_consistency objfile compunit; List.iter - (rename_relocation objfile mapping defined ofs) + (rename_relocation packagename objfile mapping defined ofs) compunit.cu_reloc; primitives := compunit.cu_primitives @ !primitives; if compunit.cu_force_link then force_link := true; @@ -136,20 +148,20 @@ let rename_append_bytecode oc mapping defined ofs prefix subst objfile compunit (* Same, for a list of .cmo and .cmi files. Return total size of bytecode. *) -let rec rename_append_bytecode_list oc mapping defined ofs prefix subst = function +let rec rename_append_bytecode_list packagename oc mapping defined ofs prefix subst = function [] -> ofs | m :: rem -> match m.pm_kind with | PM_intf -> - rename_append_bytecode_list oc mapping defined ofs prefix subst rem + rename_append_bytecode_list packagename oc mapping defined ofs prefix subst rem | PM_impl compunit -> let size = - rename_append_bytecode oc mapping defined ofs prefix subst + rename_append_bytecode packagename oc mapping defined ofs prefix subst m.pm_file compunit in let id = Ident.create_persistent m.pm_name in let root = Path.Pident (Ident.create_persistent prefix) in - rename_append_bytecode_list + rename_append_bytecode_list packagename oc mapping (id :: defined) (ofs + size) prefix (Subst.add_module id (Path.Pdot (root, Ident.name id, Path.nopos)) subst) rem @@ -191,7 +203,7 @@ let package_object_files files targetfile targetname coercion = let pos_depl = pos_out oc in output_binary_int oc 0; let pos_code = pos_out oc in - let ofs = rename_append_bytecode_list oc mapping [] 0 targetname Subst.identity members in + let ofs = rename_append_bytecode_list targetname oc mapping [] 0 targetname Subst.identity members in build_global_target oc targetname members mapping ofs coercion; let pos_debug = pos_out oc in if !Clflags.debug && !events <> [] then diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index ff94a6d9c..06523ebcc 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -140,7 +140,7 @@ type lambda = | Lwhile of lambda * lambda | Lfor of Ident.t * lambda * lambda * direction_flag * lambda | Lassign of Ident.t * lambda - | Lsend of meth_kind * lambda * lambda * lambda list + | Lsend of meth_kind * lambda * lambda * lambda list * Location.t | Levent of lambda * lambda_event | Lifused of Ident.t * lambda @@ -201,7 +201,7 @@ let rec same l1 l2 = same b1 b2 && df1 = df2 && same c1 c2 | Lassign(id1, a1), Lassign(id2, a2) -> Ident.same id1 id2 && same a1 a2 - | Lsend(k1, a1, b1, cl1), Lsend(k2, a2, b2, cl2) -> + | 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_loc = ev2.lev_loc @@ -277,7 +277,7 @@ let rec iter f = function f e1; f e2; f e3 | Lassign(id, e) -> f e - | Lsend (k, met, obj, args) -> + | Lsend (k, met, obj, args, _) -> List.iter f (met::obj::args) | Levent (lam, evt) -> f lam @@ -320,7 +320,7 @@ let free_variables l = free_ids (function Lvar id -> [id] | _ -> []) l let free_methods l = - free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) l + free_ids (function Lsend(Self, Lvar meth, obj, _, _) -> [meth] | _ -> []) l (* Check if an action has a "when" guard *) let raise_count = ref 0 @@ -398,8 +398,8 @@ let subst_lambda s lam = | Lwhile(e1, e2) -> Lwhile(subst e1, subst e2) | 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) + | Lsend (k, met, obj, args, loc) -> + Lsend (k, subst met, subst obj, List.map subst args, loc) | Levent (lam, evt) -> Levent (subst lam, evt) | Lifused (v, e) -> Lifused (v, subst e) and subst_decl (id, exp) = (id, subst exp) diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index 8c34ac94a..e671b8915 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -149,7 +149,7 @@ type lambda = | Lwhile of lambda * lambda | Lfor of Ident.t * lambda * lambda * direction_flag * lambda | Lassign of Ident.t * lambda - | Lsend of meth_kind * lambda * lambda * lambda list + | Lsend of meth_kind * lambda * lambda * lambda list * Location.t | Levent of lambda * lambda_event | Lifused of Ident.t * lambda diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 0d6e19148..9bfa099e1 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -285,7 +285,7 @@ let rec lam ppf = function lam hi lam body | Lassign(id, expr) -> fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr - | Lsend (k, met, obj, largs) -> + | Lsend (k, met, obj, largs, _) -> let args ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in let kind = diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index fc2559f66..1f1d32b2c 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -75,9 +75,9 @@ let rec eliminate_ref id = function dir, eliminate_ref id e3) | Lassign(v, e) -> Lassign(v, eliminate_ref id e) - | Lsend(k, m, o, el) -> + | Lsend(k, m, o, el, loc) -> Lsend(k, eliminate_ref id m, eliminate_ref id o, - List.map (eliminate_ref id) el) + List.map (eliminate_ref id) el, loc) | Levent(l, ev) -> Levent(eliminate_ref id l, ev) | Lifused(v, e) -> @@ -144,7 +144,7 @@ let simplify_exits lam = (* Lalias-bound variables are never assigned, so don't increase v's refcount *) count l - | Lsend(k, m, o, ll) -> List.iter count (m::o::ll) + | Lsend(k, m, o, ll, _) -> List.iter count (m::o::ll) | Levent(l, _) -> count l | Lifused(v, l) -> count l @@ -250,7 +250,7 @@ let simplify_exits lam = | Lfor(v, l1, l2, dir, l3) -> Lfor(v, simplif l1, simplif l2, dir, simplif l3) | Lassign(v, l) -> Lassign(v, simplif l) - | Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll) + | Lsend(k, m, o, ll, loc) -> Lsend(k, simplif m, simplif o, List.map simplif ll, loc) | Levent(l, ev) -> Levent(simplif l, ev) | Lifused(v, l) -> Lifused (v,simplif l) in @@ -336,7 +336,7 @@ let simplify_lets lam = (* Lalias-bound variables are never assigned, so don't increase v's refcount *) count bv l - | Lsend(_, m, o, ll) -> List.iter (count bv) (m::o::ll) + | Lsend(_, m, o, ll, _) -> List.iter (count bv) (m::o::ll) | Levent(l, _) -> count bv l | Lifused(v, l) -> if count_var v > 0 then count bv l @@ -434,11 +434,93 @@ let simplify_lets lam = | Lfor(v, l1, l2, dir, l3) -> Lfor(v, simplif l1, simplif l2, dir, simplif l3) | Lassign(v, l) -> Lassign(v, simplif l) - | Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll) + | Lsend(k, m, o, ll, loc) -> Lsend(k, simplif m, simplif o, List.map simplif ll, loc) | Levent(l, ev) -> Levent(simplif l, ev) | Lifused(v, l) -> if count_var v > 0 then simplif l else lambda_unit in simplif lam -let simplify_lambda lam = simplify_lets (simplify_exits lam) +(* Tail call info in annotation files *) + +let is_tail_native_heuristic : (int -> bool) ref = + ref (fun n -> true) + +let rec emit_tail_infos is_tail lambda = + let call_kind args = + if is_tail + && ((not !Clflags.native_code) + || (!is_tail_native_heuristic (List.length args))) + then Annot.Tail + else Annot.Stack in + match lambda with + | Lvar _ -> () + | Lconst _ -> () + | Lapply (func, l, loc) -> + list_emit_tail_infos false l; + Stypes.record (Stypes.An_call (loc, call_kind l)) + | Lfunction (_, _, lam) -> + emit_tail_infos true lam + | Llet (_, _, lam, body) -> + emit_tail_infos false lam; + emit_tail_infos is_tail body + | Lletrec (bindings, body) -> + List.iter (fun (_, lam) -> emit_tail_infos false lam) bindings; + emit_tail_infos is_tail body + | Lprim (Pidentity, [arg]) -> + emit_tail_infos is_tail arg + | Lprim (Psequand, [arg1; arg2]) + | Lprim (Psequor, [arg1; arg2]) -> + emit_tail_infos false arg1; + emit_tail_infos is_tail arg2 + | Lprim (_, l) -> + list_emit_tail_infos false l + | Lswitch (lam, sw) -> + emit_tail_infos false lam; + list_emit_tail_infos_fun snd is_tail sw.sw_consts; + list_emit_tail_infos_fun snd is_tail sw.sw_blocks + | Lstaticraise (_, l) -> + list_emit_tail_infos false l + | Lstaticcatch (body, _, handler) -> + emit_tail_infos is_tail body; + emit_tail_infos is_tail handler + | Ltrywith (body, _, handler) -> + emit_tail_infos false body; + emit_tail_infos is_tail handler + | Lifthenelse (cond, ifso, ifno) -> + emit_tail_infos false cond; + emit_tail_infos is_tail ifso; + emit_tail_infos is_tail ifno + | Lsequence (lam1, lam2) -> + emit_tail_infos false lam1; + emit_tail_infos is_tail lam2 + | Lwhile (cond, body) -> + emit_tail_infos false cond; + emit_tail_infos false body + | Lfor (_, low, high, _, body) -> + emit_tail_infos false low; + emit_tail_infos false high; + emit_tail_infos false body + | Lassign (_, lam) -> + emit_tail_infos false lam + | Lsend (_, meth, obj, args, loc) -> + emit_tail_infos false meth; + emit_tail_infos false obj; + list_emit_tail_infos false args; + Stypes.record (Stypes.An_call (loc, call_kind (obj :: args))) + | Levent (lam, _) -> + emit_tail_infos is_tail lam + | Lifused (_, lam) -> + emit_tail_infos is_tail lam +and list_emit_tail_infos_fun f is_tail = + List.iter (fun x -> emit_tail_infos is_tail (f x)) +and list_emit_tail_infos is_tail = + List.iter (emit_tail_infos is_tail) + +(* The entry point: + simplification + emission of tailcall annotations, if needed. *) + +let simplify_lambda lam = + let res = simplify_lets (simplify_exits lam) in + if !Clflags.annotations then emit_tail_infos true res; + res diff --git a/bytecomp/simplif.mli b/bytecomp/simplif.mli index 5e5217ff1..2d9b352bb 100644 --- a/bytecomp/simplif.mli +++ b/bytecomp/simplif.mli @@ -12,8 +12,15 @@ (* $Id$ *) -(* Elimination of useless Llet(Alias) bindings *) +(* Elimination of useless Llet(Alias) bindings. + Transformation of let-bound references into variables. + Simplification over staticraise/staticcatch constructs. + Generation of tail-call annotations if -annot is set. *) open Lambda val simplify_lambda: lambda -> lambda + +(* To be filled by asmcomp/selectgen.ml *) +val is_tail_native_heuristic: (int -> bool) ref + (* # arguments -> can tailcall *) diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index cf5783a97..e18a13ba6 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -495,7 +495,7 @@ let rec builtin_meths self env env2 body = "var", [Lvar n] | Lprim(Pfield n, [Lvar e]) when Ident.same e env -> "env", [Lvar env2; Lconst(Const_pointer n)] - | Lsend(Self, met, Lvar s, []) when List.mem s self -> + | Lsend(Self, met, Lvar s, [], _) when List.mem s self -> "meth", [met] | _ -> raise Not_found in @@ -510,15 +510,15 @@ let rec builtin_meths self env env2 body = | Lapply(f, [p; arg], _) when const_path f && const_path p -> let s, args = conv arg in ("app_const_"^s, f :: p :: args) - | Lsend(Self, Lvar n, Lvar s, [arg]) when List.mem s self -> + | Lsend(Self, Lvar n, Lvar s, [arg], _) when List.mem s self -> let s, args = conv arg in ("meth_app_"^s, Lvar n :: args) - | Lsend(Self, met, Lvar s, []) when List.mem s self -> + | Lsend(Self, met, Lvar s, [], _) when List.mem s self -> ("get_meth", [met]) - | Lsend(Public, met, arg, []) -> + | Lsend(Public, met, arg, [], _) -> let s, args = conv arg in ("send_"^s, met :: args) - | Lsend(Cached, met, arg, [_;_]) -> + | Lsend(Cached, met, arg, [_;_], _) -> let s, args = conv arg in ("send_"^s, met :: args) | Lfunction (Curried, [x], body) -> diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 5fcd8eeb9..3b0b0b0d5 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -571,12 +571,12 @@ and transl_exp0 e = if public_send || p.prim_name = "%sendself" then let kind = if public_send then Public else Self in let obj = Ident.create "obj" and meth = Ident.create "meth" in - Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [])) + Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc)) else if p.prim_name = "%sendcache" then let obj = Ident.create "obj" and meth = Ident.create "meth" in let cache = Ident.create "cache" and pos = Ident.create "pos" in Lfunction(Curried, [obj; meth; cache; pos], - Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos])) + Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc)) else transl_primitive p | Texp_ident(path, {val_kind = Val_anc _}) -> @@ -614,10 +614,10 @@ and transl_exp0 e = if public_send || p.prim_name = "%sendself" then let kind = if public_send then Public else Self in let obj = List.hd argl in - wrap (Lsend (kind, List.nth argl 1, obj, [])) + wrap (Lsend (kind, List.nth argl 1, obj, [], e.exp_loc)) else if p.prim_name = "%sendcache" then match argl with [obj; meth; cache; pos] -> - wrap (Lsend(Cached, meth, obj, [cache; pos])) + wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc)) | _ -> assert false else begin let prim = transl_prim p args in @@ -737,11 +737,11 @@ and transl_exp0 e = let obj = transl_exp expr in let lam = match met with - Tmeth_val id -> Lsend (Self, Lvar id, obj, []) + Tmeth_val id -> Lsend (Self, Lvar id, obj, [], e.exp_loc) | Tmeth_name nm -> let (tag, cache) = Translobj.meth obj nm in let kind = if cache = [] then Public else Cached in - Lsend (kind, tag, obj, cache) + Lsend (kind, tag, obj, cache, e.exp_loc) in event_after e lam | Texp_new (cl, _) -> @@ -840,10 +840,10 @@ and transl_tupled_cases patl_expr_list = and transl_apply lam sargs loc = let lapply funct args = match funct with - Lsend(k, lmet, lobj, largs) -> - Lsend(k, lmet, lobj, largs @ args) - | Levent(Lsend(k, lmet, lobj, largs), _) -> - Lsend(k, lmet, lobj, largs @ args) + Lsend(k, lmet, lobj, largs, loc) -> + Lsend(k, lmet, lobj, largs @ args, loc) + | Levent(Lsend(k, lmet, lobj, largs, loc), _) -> + Lsend(k, lmet, lobj, largs @ args, loc) | Lapply(lexp, largs, _) -> Lapply(lexp, largs @ args, loc) | lexp -> diff --git a/byterun/compare.c b/byterun/compare.c index 35a7f66ce..751630757 100644 --- a/byterun/compare.c +++ b/byterun/compare.c @@ -104,18 +104,44 @@ static intnat compare_val(value v1, value v2, int total) if (Is_long(v2)) return Long_val(v1) - Long_val(v2); /* Subtraction above cannot overflow and cannot result in UNORDERED */ - if (Is_in_value_area(v2) && - Tag_val(v2) == Forward_tag) { - v2 = Forward_val(v2); - continue; + if (Is_in_value_area(v2)) { + switch (Tag_val(v2)) { + case Forward_tag: + v2 = Forward_val(v2); + continue; + case Custom_tag: { + int res; + int (*compare)(value v1, value v2) = Custom_ops_val(v2)->compare_ext; + if (compare == NULL) break; /* for backward compatibility */ + caml_compare_unordered = 0; + res = compare(v1, v2); + if (caml_compare_unordered && !total) return UNORDERED; + if (res != 0) return res; + goto next_item; + } + default: /*fallthrough*/; + } } return LESS; /* v1 long < v2 block */ } if (Is_long(v2)) { - if (Is_in_value_area(v1) && - Tag_val(v1) == Forward_tag) { - v1 = Forward_val(v1); - continue; + if (Is_in_value_area(v1)) { + switch (Tag_val(v1)) { + case Forward_tag: + v1 = Forward_val(v1); + continue; + case Custom_tag: { + int res; + int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare_ext; + if (compare == NULL) break; /* for backward compatibility */ + caml_compare_unordered = 0; + res = compare(v1, v2); + if (caml_compare_unordered && !total) return UNORDERED; + if (res != 0) return res; + goto next_item; + } + default: /*fallthrough*/; + } } return GREATER; /* v1 block > v2 long */ } @@ -134,17 +160,14 @@ static intnat compare_val(value v1, value v2, int total) if (t1 != t2) return (intnat)t1 - (intnat)t2; switch(t1) { case String_tag: { - mlsize_t len1, len2, len; - unsigned char * p1, * p2; + mlsize_t len1, len2; + int res; if (v1 == v2) break; len1 = caml_string_length(v1); len2 = caml_string_length(v2); - for (len = (len1 <= len2 ? len1 : len2), - p1 = (unsigned char *) String_val(v1), - p2 = (unsigned char *) String_val(v2); - len > 0; - len--, p1++, p2++) - if (*p1 != *p2) return (intnat)*p1 - (intnat)*p2; + res = memcmp(String_val(v1), String_val(v2), len1 <= len2 ? len1 : len2); + if (res < 0) return LESS; + if (res > 0) return GREATER; if (len1 != len2) return len1 - len2; break; } @@ -198,12 +221,18 @@ static intnat compare_val(value v1, value v2, int total) case Custom_tag: { int res; int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare; + /* Hardening against comparisons between different types */ + if (compare != Custom_ops_val(v2)->compare) { + return strcmp(Custom_ops_val(v1)->identifier, + Custom_ops_val(v2)->identifier) < 0 + ? LESS : GREATER; + } if (compare == NULL) { compare_free_stack(); caml_invalid_argument("equal: abstract value"); } caml_compare_unordered = 0; - res = Custom_ops_val(v1)->compare(v1, v2); + res = compare(v1, v2); if (caml_compare_unordered && !total) return UNORDERED; if (res != 0) return res; break; diff --git a/byterun/custom.h b/byterun/custom.h index a706857ae..51fabed9d 100644 --- a/byterun/custom.h +++ b/byterun/custom.h @@ -31,6 +31,7 @@ struct custom_operations { /*out*/ uintnat * wsize_32 /*size in bytes*/, /*out*/ uintnat * wsize_64 /*size in bytes*/); uintnat (*deserialize)(void * dst); + int (*compare_ext)(value v1, value v2); }; #define custom_finalize_default NULL @@ -38,6 +39,7 @@ struct custom_operations { #define custom_hash_default NULL #define custom_serialize_default NULL #define custom_deserialize_default NULL +#define custom_compare_ext_default NULL #define Custom_ops_val(v) (*((struct custom_operations **) (v))) diff --git a/byterun/fail.c b/byterun/fail.c index b1a08c611..aceb253b9 100644 --- a/byterun/fail.c +++ b/byterun/fail.c @@ -15,6 +15,8 @@ /* Raising exceptions from C. */ +#include +#include #include "alloc.h" #include "fail.h" #include "io.h" @@ -85,13 +87,24 @@ CAMLexport void caml_raise_with_string(value tag, char const *msg) CAMLnoreturn; } +/* PR#5115: Failure and Invalid_argument can be triggered by + input_value while reading the initial value of [caml_global_data]. */ + CAMLexport void caml_failwith (char const *msg) { + if (caml_global_data == 0) { + fprintf(stderr, "Fatal error: exception Failure(\"%s\")\n", msg); + exit(2); + } caml_raise_with_string(Field(caml_global_data, FAILURE_EXN), msg); } CAMLexport void caml_invalid_argument (char const *msg) { + if (caml_global_data == 0) { + fprintf(stderr, "Fatal error: exception Invalid_argument(\"%s\")\n", msg); + exit(2); + } caml_raise_with_string(Field(caml_global_data, INVALID_EXN), msg); } diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index 0fe221515..9a2e0b08c 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -467,8 +467,11 @@ CAMLprim value caml_gc_major_slice (value v) CAMLprim value caml_gc_compaction(value v) { Assert (v == Val_unit); + caml_gc_message (0x10, "Heap compaction requested\n", 0); caml_empty_minor_heap (); caml_finish_major_cycle (); + caml_final_do_calls (); + caml_empty_minor_heap (); caml_finish_major_cycle (); caml_compact_heap (); caml_final_do_calls (); @@ -481,7 +484,9 @@ void caml_init_gc (uintnat minor_size, uintnat major_size, { uintnat major_heap_size = Bsize_wsize (norm_heapincr (major_size)); - caml_page_table_initialize(Bsize_wsize(minor_size) + major_heap_size); + if (caml_page_table_initialize(Bsize_wsize(minor_size) + major_heap_size)){ + caml_fatal_error ("OCaml runtime error: cannot initialize page table\n"); + } caml_set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size))); caml_major_heap_increment = Bsize_wsize (norm_heapincr (major_incr)); caml_percent_free = norm_pfree (percent_fr); diff --git a/byterun/ints.c b/byterun/ints.c index 74f4098cf..b15de09ec 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -625,7 +625,7 @@ static void nativeint_serialize(value v, uintnat * wsize_32, { intnat l = Nativeint_val(v); #ifdef ARCH_SIXTYFOUR - if (l <= 0x7FFFFFFFL && l >= -0x80000000L) { + if (l >= -((intnat)1 << 31) && l < ((intnat)1 << 31)) { caml_serialize_int_1(1); caml_serialize_int_4((int32) l); } else { diff --git a/byterun/major_gc.h b/byterun/major_gc.h index 5e48e3431..12f880670 100644 --- a/byterun/major_gc.h +++ b/byterun/major_gc.h @@ -54,7 +54,7 @@ extern char *caml_gc_sweep_hp; 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 *); -intnat caml_major_collection_slice (long); +intnat caml_major_collection_slice (intnat); void major_collection (void); void caml_finish_major_cycle (void); diff --git a/byterun/stacks.c b/byterun/stacks.c index f2de29f09..ed06f9534 100644 --- a/byterun/stacks.c +++ b/byterun/stacks.c @@ -28,7 +28,7 @@ CAMLexport value * caml_stack_threshold; CAMLexport value * caml_extern_sp; CAMLexport value * caml_trapsp; CAMLexport value * caml_trap_barrier; -value caml_global_data; +value caml_global_data = 0; uintnat caml_max_stack_size; /* also used in gc_ctrl.c */ diff --git a/byterun/startup.c b/byterun/startup.c index b69c04f22..20e61e7d2 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -288,7 +288,7 @@ static int parse_command_line(char **argv) static void scanmult (char *opt, uintnat *var) { char mult = ' '; - int val; + unsigned int val; sscanf (opt, "=%u%c", &val, &mult); sscanf (opt, "=0x%x%c", &val, &mult); switch (mult) { diff --git a/byterun/sys.c b/byterun/sys.c index bbc0e605f..9928910f7 100644 --- a/byterun/sys.c +++ b/byterun/sys.c @@ -138,12 +138,14 @@ CAMLprim value caml_sys_open(value path, value vflags, value vperm) /* open on a named FIFO can block (PR#1533) */ caml_enter_blocking_section(); fd = open(p, flags, perm); + /* fcntl on a fd can block (PR#5069)*/ +#if defined(F_SETFD) && defined(FD_CLOEXEC) + if (fd != -1) + fcntl(fd, F_SETFD, FD_CLOEXEC); +#endif caml_leave_blocking_section(); caml_stat_free(p); if (fd == -1) caml_sys_error(path); -#if defined(F_SETFD) && defined(FD_CLOEXEC) - fcntl(fd, F_SETFD, FD_CLOEXEC); -#endif CAMLreturn(Val_long(fd)); } diff --git a/camlp4/Camlp4/Camlp4Ast.partial.ml b/camlp4/Camlp4/Camlp4Ast.partial.ml index ce5ed3efc..624ab86db 100644 --- a/camlp4/Camlp4/Camlp4Ast.partial.ml +++ b/camlp4/Camlp4/Camlp4Ast.partial.ml @@ -198,6 +198,8 @@ | MtSig of loc and sig_item (* mt with wc *) | MtWit of loc and module_type and with_constr + (* module type of m *) + | MtOf of loc and module_expr | MtAnt of loc and string (* $s$ *) ] and sig_item = [ SgNil of loc diff --git a/camlp4/Camlp4/Printers/OCaml.ml b/camlp4/Camlp4/Printers/OCaml.ml index 345be1a18..18da100ed 100644 --- a/camlp4/Camlp4/Printers/OCaml.ml +++ b/camlp4/Camlp4/Printers/OCaml.ml @@ -169,6 +169,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct method reset = {< pipe = False; semi = False >}; value semisep : sep = ";;"; + value no_semisep : sep = ""; (* used to mark where ";;" should not occur *) value mode = if comments then `comments else `no_comments; value curry_constr = init_curry_constr; value var_conversion = False; @@ -878,6 +879,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct let () = o#node f mt Ast.loc_of_module_type in match mt with [ <:module_type<>> -> assert False + | <:module_type< module type of $me$ >> -> pp f "@[<2>module type of@ %a@]" o#module_expr me | <:module_type< $id:i$ >> -> o#ident f i | <:module_type< $anti:s$ >> -> o#anti f s | <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> -> @@ -1006,21 +1008,21 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:class_sig_item< $csg1$; $csg2$ >> -> do { o#class_sig_item f csg1; cut f; o#class_sig_item f csg2 } | <:class_sig_item< constraint $t1$ = $t2$ >> -> - pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 semisep + pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep | <:class_sig_item< inherit $ct$ >> -> - pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct semisep + pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct no_semisep | <:class_sig_item< method $private:pr$ $s$ : $t$ >> -> pp f "@[<2>method %a%a :@ %a%(%)@]" o#private_flag pr o#var s - o#ctyp t semisep + o#ctyp t no_semisep | <:class_sig_item< method virtual $private:pr$ $s$ : $t$ >> -> pp f "@[<2>method virtual %a%a :@ %a%(%)@]" - o#private_flag pr o#var s o#ctyp t semisep + o#private_flag pr o#var s o#ctyp t no_semisep | <:class_sig_item< value $mutable:mu$ $virtual:vi$ $s$ : $t$ >> -> pp f "@[<2>%s %a%a%a :@ %a%(%)@]" o#value_val o#mutable_flag mu o#virtual_flag vi o#var s o#ctyp t - semisep + no_semisep | <:class_sig_item< $anti:s$ >> -> - pp f "%a%(%)" o#anti s semisep ]; + pp f "%a%(%)" o#anti s no_semisep ]; method class_str_item f cst = let () = o#node f cst Ast.loc_of_class_str_item in @@ -1032,30 +1034,30 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:class_str_item< $cst1$; $cst2$ >> -> do { o#class_str_item f cst1; cut f; o#class_str_item f cst2 } | <:class_str_item< constraint $t1$ = $t2$ >> -> - pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 semisep + pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep | <:class_str_item< inherit $override:ov$ $ce$ >> -> - pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov o#class_expr ce semisep + pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov o#class_expr ce no_semisep | <:class_str_item< inherit $override:ov$ $ce$ as $lid:s$ >> -> - pp f "@[<2>inherit%a@ %a as@ %a%(%)@]" o#override_flag ov o#class_expr ce o#var s semisep + pp f "@[<2>inherit%a@ %a as@ %a%(%)@]" o#override_flag ov o#class_expr ce o#var s no_semisep | <:class_str_item< initializer $e$ >> -> - pp f "@[<2>initializer@ %a%(%)@]" o#expr e semisep + pp f "@[<2>initializer@ %a%(%)@]" o#expr e no_semisep | <:class_str_item< method $override:ov$ $private:pr$ $s$ = $e$ >> -> pp f "@[<2>method%a %a%a =@ %a%(%)@]" - o#override_flag ov o#private_flag pr o#var s o#expr e semisep + o#override_flag ov o#private_flag pr o#var s o#expr e no_semisep | <:class_str_item< method $override:ov$ $private:pr$ $s$ : $t$ = $e$ >> -> pp f "@[<2>method%a %a%a :@ %a =@ %a%(%)@]" - o#override_flag ov o#private_flag pr o#var s o#ctyp t o#expr e semisep + o#override_flag ov o#private_flag pr o#var s o#ctyp t o#expr e no_semisep | <:class_str_item< method virtual $private:pr$ $s$ : $t$ >> -> pp f "@[<2>method virtual@ %a%a :@ %a%(%)@]" - o#private_flag pr o#var s o#ctyp t semisep + o#private_flag pr o#var s o#ctyp t no_semisep | <:class_str_item< value virtual $mutable:mu$ $s$ : $t$ >> -> pp f "@[<2>%s virtual %a%a :@ %a%(%)@]" - o#value_val o#mutable_flag mu o#var s o#ctyp t semisep + o#value_val o#mutable_flag mu o#var s o#ctyp t no_semisep | <:class_str_item< value $override:ov$ $mutable:mu$ $s$ = $e$ >> -> pp f "@[<2>%s%a %a%a =@ %a%(%)@]" - o#value_val o#override_flag ov o#mutable_flag mu o#var s o#expr e semisep + o#value_val o#override_flag ov o#mutable_flag mu o#var s o#expr e no_semisep | <:class_str_item< $anti:s$ >> -> - pp f "%a%(%)" o#anti s semisep ]; + pp f "%a%(%)" o#anti s no_semisep ]; method implem f st = match st with diff --git a/camlp4/Camlp4/Printers/OCaml.mli b/camlp4/Camlp4/Printers/OCaml.mli index c09261b96..1ec7120b9 100644 --- a/camlp4/Camlp4/Printers/OCaml.mli +++ b/camlp4/Camlp4/Printers/OCaml.mli @@ -68,6 +68,7 @@ module Make (Syntax : Sig.Camlp4Syntax) : sig value pipe : bool; value semi : bool; value semisep : sep; + value no_semisep : sep; method value_val : string; method value_let : string; method andsep : sep; diff --git a/camlp4/Camlp4/Printers/OCamlr.ml b/camlp4/Camlp4/Printers/OCamlr.ml index 52590ae7b..199458792 100644 --- a/camlp4/Camlp4/Printers/OCamlr.ml +++ b/camlp4/Camlp4/Printers/OCamlr.ml @@ -44,6 +44,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct inherit PP_o.printer ~curry_constr:init_curry_constr ~comments () as super; value! semisep : sep = ";"; + value! no_semisep : sep = ";"; value mode = if comments then `comments else `no_comments; value curry_constr = init_curry_constr; value first_match_case = True; @@ -267,7 +268,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:class_expr< virtual $lid:i$ >> -> pp f "@[<2>virtual@ %a@]" o#var i | <:class_expr< virtual $lid:i$ [ $t$ ] >> -> - pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#var i o#ctyp t + pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#var i o#class_params t | ce -> super#class_expr f ce ]; end; diff --git a/camlp4/Camlp4/Register.ml b/camlp4/Camlp4/Register.ml index 4b6819368..e286eafb9 100644 --- a/camlp4/Camlp4/Register.ml +++ b/camlp4/Camlp4/Register.ml @@ -51,11 +51,13 @@ value register_str_item_parser f = str_item_parser.val := f; value register_sig_item_parser f = sig_item_parser.val := f; value register_parser f g = do { str_item_parser.val := f; sig_item_parser.val := g }; +value current_parser () = (str_item_parser.val, sig_item_parser.val); value register_str_item_printer f = str_item_printer.val := f; value register_sig_item_printer f = sig_item_printer.val := f; value register_printer f g = do { str_item_printer.val := f; sig_item_printer.val := g }; +value current_printer () = (str_item_printer.val, sig_item_printer.val); module Plugin (Id : Sig.Id) (Maker : functor (Unit : sig end) -> sig end) = struct declare_dyn_module Id.name (fun _ -> let module M = Maker (struct end) in ()); diff --git a/camlp4/Camlp4/Register.mli b/camlp4/Camlp4/Register.mli index 513114397..bd8e13a1e 100644 --- a/camlp4/Camlp4/Register.mli +++ b/camlp4/Camlp4/Register.mli @@ -40,6 +40,7 @@ type parser_fun 'a = value register_str_item_parser : parser_fun PreCast.Ast.str_item -> unit; value register_sig_item_parser : parser_fun PreCast.Ast.sig_item -> unit; value register_parser : parser_fun PreCast.Ast.str_item -> parser_fun PreCast.Ast.sig_item -> unit; +value current_parser : unit -> (parser_fun PreCast.Ast.str_item * parser_fun PreCast.Ast.sig_item); module Parser (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> (Sig.Parser Ast).S) : sig end; @@ -58,6 +59,7 @@ type printer_fun 'a = value register_str_item_printer : printer_fun PreCast.Ast.str_item -> unit; value register_sig_item_printer : printer_fun PreCast.Ast.sig_item -> unit; value register_printer : printer_fun PreCast.Ast.str_item -> printer_fun PreCast.Ast.sig_item -> unit; +value current_printer : unit -> (printer_fun PreCast.Ast.str_item * printer_fun PreCast.Ast.sig_item); module Printer (Id : Sig.Id) diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml index 39990bf8e..d6a9c5aff 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -858,6 +858,8 @@ module Make (Ast : Sig.Camlp4Ast) = struct mkmty loc (Pmty_signature (sig_item sl [])) | <:module_type@loc< $mt$ with $wc$ >> -> mkmty loc (Pmty_with (module_type mt) (mkwithc wc [])) + | <:module_type@loc< module type of $me$ >> -> + mkmty loc (Pmty_typeof (module_expr me)) | <:module_type< $anti:_$ >> -> assert False ] and sig_item s l = match s with diff --git a/camlp4/Camlp4/Struct/Grammar/Structure.ml b/camlp4/Camlp4/Struct/Grammar/Structure.ml index c2afdd639..67b99feb9 100644 --- a/camlp4/Camlp4/Struct/Grammar/Structure.ml +++ b/camlp4/Camlp4/Struct/Grammar/Structure.ml @@ -36,6 +36,7 @@ module type S = sig type token_info = { prev_loc : Loc.t ; cur_loc : Loc.t + ; prev_loc_only : bool }; type token_stream = Stream.t (Token.t * token_info); @@ -126,6 +127,7 @@ module Make (Lexer : Sig.Lexer) = struct type token_info = { prev_loc : Loc.t ; cur_loc : Loc.t + ; prev_loc_only : bool }; type token_stream = Stream.t (Token.t * token_info); diff --git a/camlp4/Camlp4/Struct/Grammar/Tools.ml b/camlp4/Camlp4/Struct/Grammar/Tools.ml index 4dae7e713..cb63478ad 100644 --- a/camlp4/Camlp4/Struct/Grammar/Tools.ml +++ b/camlp4/Camlp4/Struct/Grammar/Tools.ml @@ -17,16 +17,8 @@ * - Nicolas Pouillard: refactoring *) -(* BEGIN ugly hack. See 15 lines down. FIXME *) - -type prev_locs = { - pl_strm : mutable Obj.t; - pl_locs : mutable list (int * Obj.t) -}; - -value prev_locs = ref ([] : list prev_locs); - -(* END ugly hack FIXME *) +(* PR#5090: don't do lookahead on get_prev_loc. *) +value get_prev_loc_only = ref False; module Make (Structure : Structure.S) = struct open Structure; @@ -38,71 +30,20 @@ module Make (Structure : Structure.S) = struct [ [: ` x; strm :] -> [: ` (f x); stream_map f strm :] | [: :] -> [: :] ]; -(* ******************************************************************* *) -(* Ugly hack to prevent PR#5090. See how to do this properly after - the 3.12.0 release. FIXME. -*) - -value keep_prev_loc strm = - match Stream.peek strm with - [ None -> [: :] - | Some (_, init_loc) -> - let myrecord = { pl_strm = Obj.repr [: :]; - pl_locs = [(0, Obj.repr init_loc)] } - in - let rec go prev_loc = parser - [ [: `(tok, cur_loc); strm :] -> do { - myrecord.pl_locs := myrecord.pl_locs - @ [ (Stream.count strm, Obj.repr cur_loc) ]; - [: `(tok, {prev_loc; cur_loc}); go cur_loc strm :] } - | [: :] -> do { - prev_locs.val := List.filter ((!=) myrecord) prev_locs.val; - [: :] } ] - in - let result = go init_loc strm in - do { - prev_locs.val := [myrecord :: prev_locs.val]; - myrecord.pl_strm := Obj.repr result; - result } ]; - -value drop_prev_loc strm = stream_map (fun (tok,r) -> (tok,r)) strm; - -value get_cur_loc strm = - match Stream.peek strm with - [ Some (_,r) -> r.cur_loc - | None -> Loc.ghost ]; - -value get_prev_loc strm = - let c = Stream.count strm in - let rec drop l = - match l with - [ [] -> [] - | [(i, _) :: ll] -> if i < c then drop ll else l ] - in - let rec find l = - match l with - [ [] -> None - | [h::t] -> if h.pl_strm == Obj.repr strm then Some h else find t ] - in - match find prev_locs.val with - [ None -> Loc.ghost - | Some r -> do { - r.pl_locs := drop r.pl_locs; - match r.pl_locs with - [ [] -> Loc.ghost - | [(i, loc) :: _] -> - if i = c then (Obj.obj loc : Loc.t) else Loc.ghost ] } ]; - -(* ******************************************************************* *) -(* END of ugly hack. This is the previous code. - value keep_prev_loc strm = match Stream.peek strm with [ None -> [: :] - | Some (_,init_loc) -> - let rec go prev_loc = parser - [ [: `(tok,cur_loc); strm :] -> [: `(tok,{prev_loc;cur_loc}); go cur_loc strm :] - | [: :] -> [: :] ] + | Some (tok0,init_loc) -> + let rec go prev_loc strm1 = + if get_prev_loc_only.val then + [: `(tok0, {prev_loc; cur_loc = prev_loc; prev_loc_only = True}); + go prev_loc strm1 :] + else + match strm1 with parser + [ [: `(tok,cur_loc); strm :] -> + [: `(tok, {prev_loc; cur_loc; prev_loc_only = False}); + go cur_loc strm :] + | [: :] -> [: :] ] in go init_loc strm ]; value drop_prev_loc strm = stream_map (fun (tok,r) -> (tok,r.cur_loc)) strm; @@ -113,11 +54,16 @@ value get_prev_loc strm = | None -> Loc.ghost ]; value get_prev_loc strm = - match Stream.peek strm with - [ Some (_,r) -> r.prev_loc - | None -> Loc.ghost ]; -*) - + begin + get_prev_loc_only.val := True; + let result = match Stream.peek strm with + [ Some (_, {prev_loc; prev_loc_only = True}) -> + begin Stream.junk strm; prev_loc end + | Some (_, {prev_loc; prev_loc_only = False}) -> prev_loc + | None -> Loc.ghost ]; + get_prev_loc_only.val := False; + result + end; value is_level_labelled n lev = match lev.lname with diff --git a/camlp4/Camlp4/Struct/Lexer.mll b/camlp4/Camlp4/Struct/Lexer.mll index b8e97efef..1823ae0af 100644 --- a/camlp4/Camlp4/Struct/Lexer.mll +++ b/camlp4/Camlp4/Struct/Lexer.mll @@ -180,6 +180,18 @@ module Make (Token : Sig.Camlp4Token) pos_lnum = if absolute then line else pos.pos_lnum + line; pos_bol = pos.pos_cnum - chars; } + + (* To convert integer literals, copied from "../parsing/lexer.mll" *) + + let cvt_int_literal s = + - int_of_string ("-" ^ s) + let cvt_int32_literal s = + Int32.neg (Int32.of_string ("-" ^ s)) + let cvt_int64_literal s = + Int64.neg (Int64.of_string ("-" ^ s)) + let cvt_nativeint_literal s = + Nativeint.neg (Nativeint.of_string ("-" ^ s)) + let err error loc = raise(Loc.Exc_located(loc, Error.E error)) @@ -263,19 +275,19 @@ module Make (Token : Sig.Camlp4Token) | lowercase identchar * as x { LIDENT x } | uppercase identchar * as x { UIDENT x } | int_literal as i - { try INT(int_of_string i, i) + { try INT(cvt_int_literal i, i) with Failure _ -> err (Literal_overflow "int") (Loc.of_lexbuf lexbuf) } | float_literal as f { try FLOAT(float_of_string f, f) with Failure _ -> err (Literal_overflow "float") (Loc.of_lexbuf lexbuf) } | (int_literal as i) "l" - { try INT32(Int32.of_string i, i) + { try INT32(cvt_int32_literal i, i) with Failure _ -> err (Literal_overflow "int32") (Loc.of_lexbuf lexbuf) } | (int_literal as i) "L" - { try INT64(Int64.of_string i, i) + { try INT64(cvt_int64_literal i, i) with Failure _ -> err (Literal_overflow "int64") (Loc.of_lexbuf lexbuf) } | (int_literal as i) "n" - { try NATIVEINT(Nativeint.of_string i, i) + { try NATIVEINT(cvt_nativeint_literal i, i) with Failure _ -> err (Literal_overflow "nativeint") (Loc.of_lexbuf lexbuf) } | '"' { with_curr_loc string c; diff --git a/camlp4/Camlp4Bin.ml b/camlp4/Camlp4Bin.ml index 78fd27348..a123cc12f 100644 --- a/camlp4/Camlp4Bin.ml +++ b/camlp4/Camlp4Bin.ml @@ -71,7 +71,7 @@ value rewrite_and_load n x = [ ("Parsers"|"", "pa_r.cmo" | "r" | "ocamlr" | "ocamlrevised" | "camlp4ocamlrevisedparser.cmo") -> load [pa_r] | ("Parsers"|"", "rr" | "reloaded" | "ocamlreloaded" | "camlp4ocamlreloadedparser.cmo") -> load [pa_rr] | ("Parsers"|"", "pa_o.cmo" | "o" | "ocaml" | "camlp4ocamlparser.cmo") -> load [pa_r; pa_o] - | ("Parsers"|"", "pa_rp.cmo" | "rp" | "rparser" | "camlp4ocamlrevisedparserparser.cmo") -> load [pa_r; pa_o; pa_rp] + | ("Parsers"|"", "pa_rp.cmo" | "rp" | "rparser" | "camlp4ocamlrevisedparserparser.cmo") -> load [pa_r; pa_rp] | ("Parsers"|"", "pa_op.cmo" | "op" | "parser" | "camlp4ocamlparserparser.cmo") -> load [pa_r; pa_o; pa_rp; pa_op] | ("Parsers"|"", "pa_extend.cmo" | "pa_extend_m.cmo" | "g" | "grammar" | "camlp4grammarparser.cmo") -> load [pa_g] | ("Parsers"|"", "pa_macro.cmo" | "m" | "macro" | "camlp4macroparser.cmo") -> load [pa_m] @@ -79,7 +79,7 @@ value rewrite_and_load n x = | ("Parsers"|"", "q_mlast.cmo" | "rq" | "camlp4ocamlrevisedquotationexpander.cmo") -> load [pa_qb; pa_rq] | ("Parsers"|"", "oq" | "camlp4ocamloriginalquotationexpander.cmo") -> load [pa_r; pa_o; pa_qb; pa_oq] | ("Parsers"|"", "rf") -> load [pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m] - | ("Parsers"|"", "of") -> load [pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_rq; pa_g; pa_l; pa_m] + | ("Parsers"|"", "of") -> load [pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_q; pa_g; pa_l; pa_m] | ("Parsers"|"", "comp" | "camlp4listcomprehension.cmo") -> load [pa_l] | ("Filters"|"", "lift" | "camlp4astlifter.cmo") -> load ["Camlp4AstLifter"] | ("Filters"|"", "exn" | "camlp4exceptiontracer.cmo") -> load ["Camlp4ExceptionTracer"] diff --git a/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml b/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml index 874426b10..f5878fb98 100644 --- a/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml +++ b/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml @@ -20,7 +20,7 @@ open Camlp4; (* -*- camlp4r -*- *) module Id = struct - value name = "Camlp4ListComprenhsion"; + value name = "Camlp4ListComprehension"; value version = Sys.ocaml_version; end; diff --git a/camlp4/Camlp4Parsers/Camlp4MacroParser.ml b/camlp4/Camlp4Parsers/Camlp4MacroParser.ml index 57f660daf..0cb81be94 100644 --- a/camlp4/Camlp4Parsers/Camlp4MacroParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4MacroParser.ml @@ -405,6 +405,18 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct uident: [ [ i = UIDENT -> i ] ] ; + (* dirty hack to allow polymorphic variants using the introduced keywords. *) + expr: BEFORE "simple" + [ [ "`"; kwd = [ "IFDEF" | "IFNDEF" | "THEN" | "ELSE" | "END" | "ENDIF" + | "DEFINE" | "IN" ] -> <:expr< `$uid:kwd$ >> + | "`"; s = a_ident -> <:expr< ` $s$ >> ] ] + ; + (* idem *) + patt: BEFORE "simple" + [ [ "`"; kwd = [ "IFDEF" | "IFNDEF" | "THEN" | "ELSE" | "END" | "ENDIF" ] -> + <:patt< `$uid:kwd$ >> + | "`"; s = a_ident -> <:patt< ` $s$ >> ] ] + ; END; Options.add "-D" (Arg.String parse_def) diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml index 32c5b1573..ec5351c40 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml @@ -73,6 +73,49 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct [ Some (KEYWORD ("."|"("),_) -> raise Stream.Failure | _ -> () ]); + (* horrible hacks to be able to parse class_types *) + + value test_ctyp_minusgreater = + Gram.Entry.of_parser "test_ctyp_minusgreater" + (fun strm -> + let rec skip_simple_ctyp n = + match stream_peek_nth n strm with + [ Some (KEYWORD "->") -> n + | Some (KEYWORD ("[" | "[<")) -> + skip_simple_ctyp (ignore_upto "]" (n + 1) + 1) + | Some (KEYWORD "(") -> skip_simple_ctyp (ignore_upto ")" (n + 1) + 1) + | Some + (KEYWORD + ("as" | "'" | ":" | "*" | "." | "#" | "<" | ">" | ".." | ";" | + "_" | "?")) -> + skip_simple_ctyp (n + 1) + | Some (LIDENT _ | UIDENT _) -> + skip_simple_ctyp (n + 1) + | Some _ | None -> raise Stream.Failure ] + and ignore_upto end_kwd n = + match stream_peek_nth n strm with + [ Some (KEYWORD prm) when prm = end_kwd -> n + | Some (KEYWORD ("[" | "[<")) -> + ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1) + | Some (KEYWORD "(") -> ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1) + | Some _ -> ignore_upto end_kwd (n + 1) + | None -> raise Stream.Failure ] + in + match Stream.peek strm with + [ Some ((KEYWORD "[" | LIDENT _ | UIDENT _), _) -> skip_simple_ctyp 1 + | Some (KEYWORD "object", _) -> raise Stream.Failure + | _ -> 1 ]) + ; + + value lident_colon = + Gram.Entry.of_parser "lident_colon" + (fun strm -> + match Stream.npeek 2 strm with + [ [(LIDENT i, _); (KEYWORD ":", _)] -> + do { Stream.junk strm; Stream.junk strm; i } + | _ -> raise Stream.Failure ]) + ; + value rec is_ident_constr_call = fun [ <:ident< $uid:_$ >> -> True @@ -402,15 +445,15 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | t = ctyp -> t ] ] ; class_type_plus: - [ [ i = TRY [i = a_LIDENT; ":" -> i]; t = ctyp LEVEL "star"; "->"; ct = SELF -> + [ [ i = lident_colon; t = ctyp LEVEL "star"; "->"; ct = SELF -> <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >> | "?"; i = a_LIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF -> <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> | i = OPTLABEL (* FIXME inline a_OPTLABEL *); t = ctyp LEVEL "star"; "->"; ct = SELF -> <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> - | t = TRY [t = ctyp LEVEL "star"; "->" -> t]; ct = SELF -> + | test_ctyp_minusgreater; t = ctyp LEVEL "star"; "->"; ct = SELF -> <:class_type< [ $t$ ] -> $ct$ >> - | ct = TRY class_type -> ct ] ] + | ct = class_type -> ct ] ] ; class_type_longident_and_param: [ [ "["; t = comma_ctyp; "]"; i = class_type_longident -> @@ -540,6 +583,13 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | "{"; t = label_declaration_list; "}" -> <:ctyp< { $t$ } >> ] ] ; + ctyp_quot: + [ [ "private"; t = ctyp_quot -> <:ctyp< private $t$ >> + | "|"; t = constructor_declarations -> <:ctyp< [ $t$ ] >> + | x = more_ctyp; "="; y = ctyp_quot -> <:ctyp< $x$ == $y$ >> + | "{"; t = label_declaration_list; "}" -> <:ctyp< { $t$ } >> + ] ] + ; module_expr: LEVEL "apply" [ [ i = SELF; "("; j = SELF; ")" -> <:module_expr< $i$ $j$ >> ] ] ; @@ -587,6 +637,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct <:patt< ~ $i$ : ($lid:i$ : $t$) >> | i = a_OPTLABEL; j = a_LIDENT -> (* ?a:b <> ?a : b *) <:patt< ? $i$ : ($lid:j$) >> + | i = a_OPTLABEL; "_" -> + <:patt< ? $i$ : (_) >> | i = a_OPTLABEL; "("; p = patt; ")" -> <:patt< ? $i$ : ($p$) >> | i = a_OPTLABEL; "("; p = patt; "="; e = expr; ")" -> diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml index fb467d836..a1dd59d8b 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml @@ -33,19 +33,19 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct value help_sequences () = do { Printf.eprintf "\ -New syntax:\n\ - (e1; e2; ... ; en) OR begin e1; e2; ... ; en end\n\ - while e do e1; e2; ... ; en done\n\ - for v = v1 to/downto v2 do e1; e2; ... ; en done\n\ -Old syntax (still supported):\n\ - do {e1; e2; ... ; en}\n\ - while e do {e1; e2; ... ; en}\n\ - for v = v1 to/downto v2 do {e1; e2; ... ; en}\n\ -Very old (no more supported) syntax:\n\ - do e1; e2; ... ; en-1; return en\n\ - while e do e1; e2; ... ; en; done\n\ - for v = v1 to/downto v2 do e1; e2; ... ; en; done\n\ - "; +New syntax:\ +\n (e1; e2; ... ; en) OR begin e1; e2; ... ; en end\ +\n while e do e1; e2; ... ; en done\ +\n for v = v1 to/downto v2 do e1; e2; ... ; en done\ +\nOld syntax (still supported):\ +\n do {e1; e2; ... ; en}\ +\n while e do {e1; e2; ... ; en}\ +\n for v = v1 to/downto v2 do {e1; e2; ... ; en}\ +\nVery old (no more supported) syntax:\ +\n do e1; e2; ... ; en-1; return en\ +\n while e do e1; e2; ... ; en; done\ +\n for v = v1 to/downto v2 do e1; e2; ... ; en; done\ +\n"; flush stderr; exit 1 } @@ -462,7 +462,7 @@ Very old (no more supported) syntax:\n\ <:str_item< module $i$ = $mb$ >> | "module"; "rec"; mb = module_binding -> <:str_item< module rec $mb$ >> - | "module"; "type"; i = a_UIDENT; "="; mt = module_type -> + | "module"; "type"; i = a_ident; "="; mt = module_type -> <:str_item< module type $i$ = $mt$ >> | "open"; i = module_longident -> <:str_item< open $i$ >> | "type"; td = type_declaration -> @@ -520,7 +520,8 @@ Very old (no more supported) syntax:\n\ | `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.module_type_tag | i = module_longident_with_app -> <:module_type< $id:i$ >> | "'"; i = a_ident -> <:module_type< ' $i$ >> - | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ] + | "("; mt = SELF; ")" -> <:module_type< $mt$ >> + | "module"; "type"; "of"; me = module_expr -> <:module_type< module type of $me$ >> ] ] ; sig_item: [ "top" @@ -536,9 +537,9 @@ Very old (no more supported) syntax:\n\ <:sig_item< module $i$ : $mt$ >> | "module"; "rec"; mb = module_rec_declaration -> <:sig_item< module rec $mb$ >> - | "module"; "type"; i = a_UIDENT; "="; mt = module_type -> + | "module"; "type"; i = a_ident; "="; mt = module_type -> <:sig_item< module type $i$ = $mt$ >> - | "module"; "type"; i = a_UIDENT -> + | "module"; "type"; i = a_ident -> <:sig_item< module type $i$ >> | "open"; i = module_longident -> <:sig_item< open $i$ >> | "type"; t = type_declaration -> @@ -1455,7 +1456,7 @@ Very old (no more supported) syntax:\n\ <:rec_binding< $anti:mk_anti ~c:"rec_binding" n s$ >> | `ANTIQUOT ("list" as n) s -> <:rec_binding< $anti:mk_anti ~c:"rec_binding" n s$ >> - | l = label; "="; e = expr -> <:rec_binding< $lid:l$ = $e$ >> ] ] + | l = label; "="; e = expr LEVEL "top" -> <:rec_binding< $lid:l$ = $e$ >> ] ] ; meth_list: [ [ m = meth_decl; ";"; (ml, v) = SELF -> (<:ctyp< $m$; $ml$ >>, v) @@ -1740,7 +1741,7 @@ Very old (no more supported) syntax:\n\ more_ctyp: [ [ "mutable"; x = SELF -> <:ctyp< mutable $x$ >> | "`"; x = a_ident -> <:ctyp< `$x$ >> - | x = type_kind -> x + | x = ctyp -> x | x = type_parameter -> x ] ] ; diff --git a/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml b/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml index c8025d75d..76e67f412 100644 --- a/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml +++ b/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml @@ -90,7 +90,7 @@ module Make (Syntax : Sig.Camlp4Syntax) | "`int32" -> <:expr< Int32.to_string $e$ >> | "`int64" -> <:expr< Int64.to_string $e$ >> | "`nativeint" -> <:expr< Nativeint.to_string $e$ >> - | "`flo" -> <:expr< string_of_float $e$ >> + | "`flo" -> <:expr< Camlp4_import.Oprint.float_repres $e$ >> | "`str" -> <:expr< Ast.safe_string_escaped $e$ >> | "`chr" -> <:expr< Char.escaped $e$ >> | "`bool" -> <:expr< Ast.IdUid $mloc _loc$ (if $e$ then "True" else "False") >> diff --git a/camlp4/Camlp4Top/Rprint.ml b/camlp4/Camlp4Top/Rprint.ml index 978397d89..ce772d1db 100644 --- a/camlp4/Camlp4Top/Rprint.ml +++ b/camlp4/Camlp4Top/Rprint.ml @@ -229,8 +229,20 @@ and print_simple_out_type ppf = fprintf ppf "@[{ %a }@]" (print_list print_out_label (fun ppf -> fprintf ppf ";@ ")) lbls | Otyp_abstract -> fprintf ppf "" + | Otyp_module (p, n, tyl) -> + do { + fprintf ppf "@[<1>(module %s" p; + let first = ref True in + List.iter2 + (fun s t -> + let sep = if first.val then do { first.val := False; "with" } else "and" in + fprintf ppf " %s type %s = %a" sep s print_out_type t + ) + n tyl; + fprintf ppf ")@]" + } | Otyp_alias _ _ | Otyp_poly _ _ - | Otyp_arrow _ _ _ | Otyp_constr _ [_ :: _] | Otyp_module _ as ty -> + | Otyp_arrow _ _ _ | Otyp_constr _ [_ :: _] as ty -> fprintf ppf "@[<1>(%a)@]" print_out_type ty ] in print_tkind ppf @@ -281,7 +293,7 @@ and print_typargs ppf = | tyl -> fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl ] and print_ty_label ppf lab = - if lab <> "" then fprintf ppf "~%s:" lab else () + if lab <> "" then fprintf ppf "%s%s:" (if lab.[0] = '?' then "" else "~") lab else () ; value type_parameter ppf (ty, (co, cn)) = @@ -348,12 +360,24 @@ value rec print_out_module_type ppf = fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name print_out_module_type mty_arg print_out_module_type mty_res | Omty_abstract -> () ] +and needs_semi = + fun + [ Osig_class _ _ _ _ rs + | Osig_class_type _ _ _ _ rs + | Osig_module _ _ rs + | Osig_type _ rs -> rs <> Orec_next + | Osig_exception _ _ + | Osig_modtype _ _ + | Osig_value _ _ _ -> True ] and print_out_signature ppf = fun [ [] -> () | [item] -> fprintf ppf "%a;" Toploop.print_out_sig_item.val item | [item :: items] -> - fprintf ppf "%a;@ %a" Toploop.print_out_sig_item.val item + let sep = match items with + [ [hd :: _] -> if needs_semi hd then ";" else "" + | [] -> ";" ] in + fprintf ppf "%a%s@ %a" Toploop.print_out_sig_item.val item sep print_out_signature items ] and print_out_sig_item ppf = fun diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml index 8d65f3446..105ee6d5e 100644 --- a/camlp4/boot/Camlp4.ml +++ b/camlp4/boot/Camlp4.ml @@ -671,145 +671,83 @@ module Sig = class map : object ('self_type) method string : string -> string - method list : 'a 'b. ('self_type -> 'a -> 'b) -> 'a list -> 'b list - method meta_bool : meta_bool -> meta_bool - method meta_option : 'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_option -> 'b meta_option - method meta_list : 'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_list -> 'b meta_list - method loc : loc -> loc - method expr : expr -> expr - method patt : patt -> patt - method ctyp : ctyp -> ctyp - method str_item : str_item -> str_item - method sig_item : sig_item -> sig_item - method module_expr : module_expr -> module_expr - method module_type : module_type -> module_type - method class_expr : class_expr -> class_expr - method class_type : class_type -> class_type - method class_sig_item : class_sig_item -> class_sig_item - method class_str_item : class_str_item -> class_str_item - method with_constr : with_constr -> with_constr - method binding : binding -> binding - method rec_binding : rec_binding -> rec_binding - method module_binding : module_binding -> module_binding - method match_case : match_case -> match_case - method ident : ident -> ident - method override_flag : override_flag -> override_flag - method mutable_flag : mutable_flag -> mutable_flag - method private_flag : private_flag -> private_flag - method virtual_flag : virtual_flag -> virtual_flag - method direction_flag : direction_flag -> direction_flag - method rec_flag : rec_flag -> rec_flag - method row_var_flag : row_var_flag -> row_var_flag - method unknown : 'a. 'a -> 'a - end (** Fold style traversal *) class fold : object ('self_type) method string : string -> 'self_type - method list : 'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type - method meta_bool : meta_bool -> 'self_type - method meta_option : 'a. ('self_type -> 'a -> 'self_type) -> 'a meta_option -> 'self_type - method meta_list : 'a. ('self_type -> 'a -> 'self_type) -> 'a meta_list -> 'self_type - method loc : loc -> 'self_type - method expr : expr -> 'self_type - method patt : patt -> 'self_type - method ctyp : ctyp -> 'self_type - method str_item : str_item -> 'self_type - method sig_item : sig_item -> 'self_type - method module_expr : module_expr -> 'self_type - method module_type : module_type -> 'self_type - method class_expr : class_expr -> 'self_type - method class_type : class_type -> 'self_type - method class_sig_item : class_sig_item -> 'self_type - method class_str_item : class_str_item -> 'self_type - method with_constr : with_constr -> 'self_type - method binding : binding -> 'self_type - method rec_binding : rec_binding -> 'self_type - method module_binding : module_binding -> 'self_type - method match_case : match_case -> 'self_type - method ident : ident -> 'self_type - method rec_flag : rec_flag -> 'self_type - method direction_flag : direction_flag -> 'self_type - method mutable_flag : mutable_flag -> 'self_type - method private_flag : private_flag -> 'self_type - method virtual_flag : virtual_flag -> 'self_type - method row_var_flag : row_var_flag -> 'self_type - method override_flag : override_flag -> 'self_type - method unknown : 'a. 'a -> 'self_type - end end @@ -1126,6 +1064,8 @@ module Sig = MtSig of loc * sig_item | (* mt with wc *) MtWit of loc * module_type * with_constr + | (* module type of m *) + MtOf of loc * module_expr | MtAnt of loc * string and (* $s$ *) sig_item = @@ -1537,144 +1477,82 @@ module Sig = class map : object ('self_type) method string : string -> string - method list : 'a 'b. ('self_type -> 'a -> 'b) -> 'a list -> 'b list - method meta_bool : meta_bool -> meta_bool - method meta_option : 'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_option -> 'b meta_option - method meta_list : 'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_list -> 'b meta_list - method loc : loc -> loc - method expr : expr -> expr - method patt : patt -> patt - method ctyp : ctyp -> ctyp - method str_item : str_item -> str_item - method sig_item : sig_item -> sig_item - method module_expr : module_expr -> module_expr - method module_type : module_type -> module_type - method class_expr : class_expr -> class_expr - method class_type : class_type -> class_type - method class_sig_item : class_sig_item -> class_sig_item - method class_str_item : class_str_item -> class_str_item - method with_constr : with_constr -> with_constr - method binding : binding -> binding - method rec_binding : rec_binding -> rec_binding - method module_binding : module_binding -> module_binding - method match_case : match_case -> match_case - method ident : ident -> ident - method mutable_flag : mutable_flag -> mutable_flag - method private_flag : private_flag -> private_flag - method virtual_flag : virtual_flag -> virtual_flag - method direction_flag : direction_flag -> direction_flag - method rec_flag : rec_flag -> rec_flag - method row_var_flag : row_var_flag -> row_var_flag - method override_flag : override_flag -> override_flag - method unknown : 'a. 'a -> 'a - end class fold : object ('self_type) method string : string -> 'self_type - method list : 'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type - method meta_bool : meta_bool -> 'self_type - method meta_option : 'a. ('self_type -> 'a -> 'self_type) -> 'a meta_option -> 'self_type - method meta_list : 'a. ('self_type -> 'a -> 'self_type) -> 'a meta_list -> 'self_type - method loc : loc -> 'self_type - method expr : expr -> 'self_type - method patt : patt -> 'self_type - method ctyp : ctyp -> 'self_type - method str_item : str_item -> 'self_type - method sig_item : sig_item -> 'self_type - method module_expr : module_expr -> 'self_type - method module_type : module_type -> 'self_type - method class_expr : class_expr -> 'self_type - method class_type : class_type -> 'self_type - method class_sig_item : class_sig_item -> 'self_type - method class_str_item : class_str_item -> 'self_type - method with_constr : with_constr -> 'self_type - method binding : binding -> 'self_type - method rec_binding : rec_binding -> 'self_type - method module_binding : module_binding -> 'self_type - method match_case : match_case -> 'self_type - method ident : ident -> 'self_type - method rec_flag : rec_flag -> 'self_type - method direction_flag : direction_flag -> 'self_type - method mutable_flag : mutable_flag -> 'self_type - method private_flag : private_flag -> 'self_type - method virtual_flag : virtual_flag -> 'self_type - method row_var_flag : row_var_flag -> 'self_type - method override_flag : override_flag -> 'self_type - method unknown : 'a. 'a -> 'self_type - end val map_expr : (expr -> expr) -> map @@ -1984,6 +1862,7 @@ module Sig = | MtQuo of loc * string | MtSig of loc * sig_item | MtWit of loc * module_type * with_constr + | MtOf of loc * module_expr | MtAnt of loc * string and sig_item = | SgNil of loc @@ -3880,6 +3759,15 @@ module Struct = pos_bol = pos.pos_cnum - chars; } + let cvt_int_literal s = - (int_of_string ("-" ^ s)) + + let cvt_int32_literal s = Int32.neg (Int32.of_string ("-" ^ s)) + + let cvt_int64_literal s = Int64.neg (Int64.of_string ("-" ^ s)) + + let cvt_nativeint_literal s = + Nativeint.neg (Nativeint.of_string ("-" ^ s)) + let err error loc = raise (Loc.Exc_located (loc, (Error.E error))) @@ -6473,7 +6361,7 @@ module Struct = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_curr_pos in - (try INT ((int_of_string i), i) + (try INT ((cvt_int_literal i), i) with | Failure _ -> err (Literal_overflow "int") (Loc.of_lexbuf lexbuf)) @@ -6492,7 +6380,7 @@ module Struct = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_curr_pos + (-1)) in - (try INT32 ((Int32.of_string i), i) + (try INT32 ((cvt_int32_literal i), i) with | Failure _ -> err (Literal_overflow "int32") @@ -6502,7 +6390,7 @@ module Struct = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_curr_pos + (-1)) in - (try INT64 ((Int64.of_string i), i) + (try INT64 ((cvt_int64_literal i), i) with | Failure _ -> err (Literal_overflow "int64") @@ -6512,7 +6400,7 @@ module Struct = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_curr_pos + (-1)) in - (try NATIVEINT ((Nativeint.of_string i), i) + (try NATIVEINT ((cvt_nativeint_literal i), i) with | Failure _ -> err (Literal_overflow "nativeint") @@ -9003,6 +8891,15 @@ module Struct = and meta_module_type _loc = function | Ast.MtAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.MtOf (x0, x1) -> + Ast.ExApp (_loc, + (Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "MtOf")))))), + (meta_loc _loc x0))), + (meta_module_expr _loc x1)) | Ast.MtWit (x0, x1, x2) -> Ast.ExApp (_loc, (Ast.ExApp (_loc, @@ -11298,6 +11195,15 @@ module Struct = and meta_module_type _loc = function | Ast.MtAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.MtOf (x0, x1) -> + Ast.PaApp (_loc, + (Ast.PaApp (_loc, + (Ast.PaId (_loc, + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Ast")), + (Ast.IdUid (_loc, "MtOf")))))), + (meta_loc _loc x0))), + (meta_module_expr _loc x1)) | Ast.MtWit (x0, x1, x2) -> Ast.PaApp (_loc, (Ast.PaApp (_loc, @@ -12097,7 +12003,6 @@ module Struct = class map = object ((o : 'self_type)) method string : string -> string = o#unknown - method list : 'a 'a_out. ('self_type -> 'a -> 'a_out) -> 'a list -> 'a_out list = @@ -12107,7 +12012,6 @@ module Struct = | _x :: _x_i1 -> let _x = _f_a o _x in let _x_i1 = o#list _f_a _x_i1 in _x :: _x_i1 - method with_constr : with_constr -> with_constr = function | WcNil _x -> let _x = o#loc _x in WcNil _x @@ -12135,13 +12039,11 @@ module Struct = | WcAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in WcAnt (_x, _x_i1) - method virtual_flag : virtual_flag -> virtual_flag = function | ViVirtual -> ViVirtual | ViNil -> ViNil | ViAnt _x -> let _x = o#string _x in ViAnt _x - method str_item : str_item -> str_item = function | StNil _x -> let _x = o#loc _x in StNil _x @@ -12204,7 +12106,6 @@ module Struct = | StAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in StAnt (_x, _x_i1) - method sig_item : sig_item -> sig_item = function | SgNil _x -> let _x = o#loc _x in SgNil _x @@ -12262,19 +12163,16 @@ module Struct = | SgAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in SgAnt (_x, _x_i1) - method row_var_flag : row_var_flag -> row_var_flag = function | RvRowVar -> RvRowVar | RvNil -> RvNil | RvAnt _x -> let _x = o#string _x in RvAnt _x - method rec_flag : rec_flag -> rec_flag = function | ReRecursive -> ReRecursive | ReNil -> ReNil | ReAnt _x -> let _x = o#string _x in ReAnt _x - method rec_binding : rec_binding -> rec_binding = function | RbNil _x -> let _x = o#loc _x in RbNil _x @@ -12290,13 +12188,11 @@ module Struct = | RbAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in RbAnt (_x, _x_i1) - method private_flag : private_flag -> private_flag = function | PrPrivate -> PrPrivate | PrNil -> PrNil | PrAnt _x -> let _x = o#string _x in PrAnt _x - method patt : patt -> patt = function | PaNil _x -> let _x = o#loc _x in PaNil _x @@ -12395,19 +12291,16 @@ module Struct = | PaMod (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaMod (_x, _x_i1) - method override_flag : override_flag -> override_flag = function | OvOverride -> OvOverride | OvNil -> OvNil | OvAnt _x -> let _x = o#string _x in OvAnt _x - method mutable_flag : mutable_flag -> mutable_flag = function | MuMutable -> MuMutable | MuNil -> MuNil | MuAnt _x -> let _x = o#string _x in MuAnt _x - method module_type : module_type -> module_type = function | MtNil _x -> let _x = o#loc _x in MtNil _x @@ -12431,10 +12324,12 @@ module Struct = let _x_i1 = o#module_type _x_i1 in let _x_i2 = o#with_constr _x_i2 in MtWit (_x, _x_i1, _x_i2) + | MtOf (_x, _x_i1) -> + let _x = o#loc _x in + let _x_i1 = o#module_expr _x_i1 in MtOf (_x, _x_i1) | MtAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MtAnt (_x, _x_i1) - method module_expr : module_expr -> module_expr = function | MeNil _x -> let _x = o#loc _x in MeNil _x @@ -12466,7 +12361,6 @@ module Struct = | MeAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MeAnt (_x, _x_i1) - method module_binding : module_binding -> module_binding = function | MbNil _x -> let _x = o#loc _x in MbNil _x @@ -12489,7 +12383,6 @@ module Struct = | MbAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MbAnt (_x, _x_i1) - method meta_option : 'a 'a_out. ('self_type -> 'a -> 'a_out) -> @@ -12499,7 +12392,6 @@ module Struct = | ONone -> ONone | OSome _x -> let _x = _f_a o _x in OSome _x | OAnt _x -> let _x = o#string _x in OAnt _x - method meta_list : 'a 'a_out. ('self_type -> 'a -> 'a_out) -> @@ -12512,13 +12404,11 @@ module Struct = let _x_i1 = o#meta_list _f_a _x_i1 in LCons (_x, _x_i1) | LAnt _x -> let _x = o#string _x in LAnt _x - method meta_bool : meta_bool -> meta_bool = function | BTrue -> BTrue | BFalse -> BFalse | BAnt _x -> let _x = o#string _x in BAnt _x - method match_case : match_case -> match_case = function | McNil _x -> let _x = o#loc _x in McNil _x @@ -12536,9 +12426,7 @@ module Struct = | McAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in McAnt (_x, _x_i1) - method loc : loc -> loc = o#unknown - method ident : ident -> ident = function | IdAcc (_x, _x_i1, _x_i2) -> @@ -12558,7 +12446,6 @@ module Struct = | IdAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in IdAnt (_x, _x_i1) - method expr : expr -> expr = function | ExNil _x -> let _x = o#loc _x in ExNil _x @@ -12727,13 +12614,11 @@ module Struct = | ExPkg (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#module_expr _x_i1 in ExPkg (_x, _x_i1) - method direction_flag : direction_flag -> direction_flag = function | DiTo -> DiTo | DiDownto -> DiDownto | DiAnt _x -> let _x = o#string _x in DiAnt _x - method ctyp : ctyp -> ctyp = function | TyNil _x -> let _x = o#loc _x in TyNil _x @@ -12872,7 +12757,6 @@ module Struct = | TyAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in TyAnt (_x, _x_i1) - method class_type : class_type -> class_type = function | CtNil _x -> let _x = o#loc _x in CtNil _x @@ -12910,7 +12794,6 @@ module Struct = | CtAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CtAnt (_x, _x_i1) - method class_str_item : class_str_item -> class_str_item = function | CrNil _x -> let _x = o#loc _x in CrNil _x @@ -12962,7 +12845,6 @@ module Struct = | CrAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CrAnt (_x, _x_i1) - method class_sig_item : class_sig_item -> class_sig_item = function | CgNil _x -> let _x = o#loc _x in CgNil _x @@ -13000,7 +12882,6 @@ module Struct = | CgAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CgAnt (_x, _x_i1) - method class_expr : class_expr -> class_expr = function | CeNil _x -> let _x = o#loc _x in CeNil _x @@ -13048,7 +12929,6 @@ module Struct = | CeAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in CeAnt (_x, _x_i1) - method binding : binding -> binding = function | BiNil _x -> let _x = o#loc _x in BiNil _x @@ -13063,15 +12943,12 @@ module Struct = | BiAnt (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in BiAnt (_x, _x_i1) - method unknown : 'a. 'a -> 'a = fun x -> x - end class fold = object ((o : 'self_type)) method string : string -> 'self_type = o#unknown - method list : 'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type = @@ -13080,7 +12957,6 @@ module Struct = | [] -> o | _x :: _x_i1 -> let o = _f_a o _x in let o = o#list _f_a _x_i1 in o - method with_constr : with_constr -> 'self_type = function | WcNil _x -> let o = o#loc _x in o @@ -13102,13 +12978,11 @@ module Struct = let o = o#with_constr _x_i2 in o | WcAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method virtual_flag : virtual_flag -> 'self_type = function | ViVirtual -> o | ViNil -> o | ViAnt _x -> let o = o#string _x in o - method str_item : str_item -> 'self_type = function | StNil _x -> let o = o#loc _x in o @@ -13156,7 +13030,6 @@ module Struct = let o = o#binding _x_i2 in o | StAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method sig_item : sig_item -> 'self_type = function | SgNil _x -> let o = o#loc _x in o @@ -13199,19 +13072,16 @@ module Struct = let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o | SgAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method row_var_flag : row_var_flag -> 'self_type = function | RvRowVar -> o | RvNil -> o | RvAnt _x -> let o = o#string _x in o - method rec_flag : rec_flag -> 'self_type = function | ReRecursive -> o | ReNil -> o | ReAnt _x -> let o = o#string _x in o - method rec_binding : rec_binding -> 'self_type = function | RbNil _x -> let o = o#loc _x in o @@ -13224,13 +13094,11 @@ module Struct = let o = o#ident _x_i1 in let o = o#expr _x_i2 in o | RbAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method private_flag : private_flag -> 'self_type = function | PrPrivate -> o | PrNil -> o | PrAnt _x -> let o = o#string _x in o - method patt : patt -> 'self_type = function | PaNil _x -> let o = o#loc _x in o @@ -13301,19 +13169,16 @@ module Struct = let o = o#loc _x in let o = o#patt _x_i1 in o | PaMod (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method override_flag : override_flag -> 'self_type = function | OvOverride -> o | OvNil -> o | OvAnt _x -> let o = o#string _x in o - method mutable_flag : mutable_flag -> 'self_type = function | MuMutable -> o | MuNil -> o | MuAnt _x -> let o = o#string _x in o - method module_type : module_type -> 'self_type = function | MtNil _x -> let o = o#loc _x in o @@ -13332,9 +13197,10 @@ module Struct = let o = o#loc _x in let o = o#module_type _x_i1 in let o = o#with_constr _x_i2 in o + | MtOf (_x, _x_i1) -> + let o = o#loc _x in let o = o#module_expr _x_i1 in o | MtAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method module_expr : module_expr -> 'self_type = function | MeNil _x -> let o = o#loc _x in o @@ -13359,7 +13225,6 @@ module Struct = let o = o#loc _x in let o = o#expr _x_i1 in o | MeAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method module_binding : module_binding -> 'self_type = function | MbNil _x -> let o = o#loc _x in o @@ -13378,7 +13243,6 @@ module Struct = let o = o#module_type _x_i2 in o | MbAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method meta_option : 'a. ('self_type -> 'a -> 'self_type) -> @@ -13388,7 +13252,6 @@ module Struct = | ONone -> o | OSome _x -> let o = _f_a o _x in o | OAnt _x -> let o = o#string _x in o - method meta_list : 'a. ('self_type -> 'a -> 'self_type) -> @@ -13400,13 +13263,11 @@ module Struct = let o = _f_a o _x in let o = o#meta_list _f_a _x_i1 in o | LAnt _x -> let o = o#string _x in o - method meta_bool : meta_bool -> 'self_type = function | BTrue -> o | BFalse -> o | BAnt _x -> let o = o#string _x in o - method match_case : match_case -> 'self_type = function | McNil _x -> let o = o#loc _x in o @@ -13420,9 +13281,7 @@ module Struct = let o = o#expr _x_i2 in let o = o#expr _x_i3 in o | McAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method loc : loc -> 'self_type = o#unknown - method ident : ident -> 'self_type = function | IdAcc (_x, _x_i1, _x_i2) -> @@ -13437,7 +13296,6 @@ module Struct = let o = o#loc _x in let o = o#string _x_i1 in o | IdAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method expr : expr -> 'self_type = function | ExNil _x -> let o = o#loc _x in o @@ -13560,13 +13418,11 @@ module Struct = let o = o#string _x_i1 in let o = o#expr _x_i2 in o | ExPkg (_x, _x_i1) -> let o = o#loc _x in let o = o#module_expr _x_i1 in o - method direction_flag : direction_flag -> 'self_type = function | DiTo -> o | DiDownto -> o | DiAnt _x -> let o = o#string _x in o - method ctyp : ctyp -> 'self_type = function | TyNil _x -> let o = o#loc _x in o @@ -13669,7 +13525,6 @@ module Struct = let o = o#loc _x in let o = o#module_type _x_i1 in o | TyAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method class_type : class_type -> 'self_type = function | CtNil _x -> let o = o#loc _x in o @@ -13698,7 +13553,6 @@ module Struct = let o = o#class_type _x_i2 in o | CtAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method class_str_item : class_str_item -> 'self_type = function | CrNil _x -> let o = o#loc _x in o @@ -13740,7 +13594,6 @@ module Struct = let o = o#ctyp _x_i3 in o | CrAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method class_sig_item : class_sig_item -> 'self_type = function | CgNil _x -> let o = o#loc _x in o @@ -13771,7 +13624,6 @@ module Struct = let o = o#ctyp _x_i3 in o | CgAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method class_expr : class_expr -> 'self_type = function | CeNil _x -> let o = o#loc _x in o @@ -13808,7 +13660,6 @@ module Struct = let o = o#class_expr _x_i2 in o | CeAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method binding : binding -> 'self_type = function | BiNil _x -> let o = o#loc _x in o @@ -13820,57 +13671,43 @@ module Struct = let o = o#patt _x_i1 in let o = o#expr _x_i2 in o | BiAnt (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o - method unknown : 'a. 'a -> 'self_type = fun _ -> o - end let map_expr f = object inherit map as super - method expr = fun x -> f (super#expr x) - end let map_patt f = object inherit map as super - method patt = fun x -> f (super#patt x) - end let map_ctyp f = object inherit map as super - method ctyp = fun x -> f (super#ctyp x) - end let map_str_item f = object inherit map as super - method str_item = fun x -> f (super#str_item x) - end let map_sig_item f = object inherit map as super - method sig_item = fun x -> f (super#sig_item x) - end let map_loc f = object inherit map as super - method loc = fun x -> f (super#loc x) - end end @@ -15216,6 +15053,8 @@ module Struct = mkmty loc (Pmty_signature (sig_item sl [])) | Ast.MtWit (loc, mt, wc) -> mkmty loc (Pmty_with ((module_type mt), (mkwithc wc []))) + | Ast.MtOf (loc, me) -> + mkmty loc (Pmty_typeof (module_expr me)) | Ast.MtAnt (_, _) -> assert false and sig_item s l = match s with @@ -15338,6 +15177,9 @@ module Struct = (Ast.OSome i)) -> (mkstr loc (Pstr_exn_rebind ((conv_con s), (ident i)))) :: l + | Ast.StExc (loc, + (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, _)))), _)), + (Ast.OSome _)) -> error loc "type in exception alias" | StExc (_, _, _) -> assert false | StExp (loc, e) -> (mkstr loc (Pstr_eval (expr e))) :: l | StExt (loc, n, t, sl) -> @@ -15562,14 +15404,12 @@ module Struct = struct class clean_ast = object inherit Ast.map as super - method with_constr = fun wc -> match super#with_constr wc with | Ast.WcAnd (_, (Ast.WcNil _), wc) | Ast.WcAnd (_, wc, (Ast.WcNil _)) -> wc | wc -> wc - method expr = fun e -> match super#expr e with @@ -15580,7 +15420,6 @@ module Struct = Ast.ExSem (_, (Ast.ExNil _), e) | Ast.ExSem (_, e, (Ast.ExNil _)) -> e | e -> e - method patt = fun p -> match super#patt p with @@ -15592,35 +15431,30 @@ module Struct = Ast.PaSem (_, (Ast.PaNil _), p) | Ast.PaSem (_, p, (Ast.PaNil _)) -> p | p -> p - method match_case = fun mc -> match super#match_case mc with | Ast.McOr (_, (Ast.McNil _), mc) | Ast.McOr (_, mc, (Ast.McNil _)) -> mc | mc -> mc - method binding = fun bi -> match super#binding bi with | Ast.BiAnd (_, (Ast.BiNil _), bi) | Ast.BiAnd (_, bi, (Ast.BiNil _)) -> bi | bi -> bi - method rec_binding = fun rb -> match super#rec_binding rb with | Ast.RbSem (_, (Ast.RbNil _), bi) | Ast.RbSem (_, bi, (Ast.RbNil _)) -> bi | bi -> bi - method module_binding = fun mb -> match super#module_binding mb with | Ast.MbAnd (_, (Ast.MbNil _), mb) | Ast.MbAnd (_, mb, (Ast.MbNil _)) -> mb | mb -> mb - method ctyp = fun t -> match super#ctyp t with @@ -15643,7 +15477,6 @@ module Struct = Ast.TySta (_, (Ast.TyNil _), t) | Ast.TySta (_, t, (Ast.TyNil _)) -> t | t -> t - method sig_item = fun sg -> match super#sig_item sg with @@ -15651,7 +15484,6 @@ module Struct = Ast.SgSem (_, sg, (Ast.SgNil _)) -> sg | Ast.SgTyp (loc, (Ast.TyNil _)) -> Ast.SgNil loc | sg -> sg - method str_item = fun st -> match super#str_item st with @@ -15660,41 +15492,35 @@ module Struct = | Ast.StTyp (loc, (Ast.TyNil _)) -> Ast.StNil loc | Ast.StVal (loc, _, (Ast.BiNil _)) -> Ast.StNil loc | st -> st - method module_type = fun mt -> match super#module_type mt with | Ast.MtWit (_, mt, (Ast.WcNil _)) -> mt | mt -> mt - method class_expr = fun ce -> match super#class_expr ce with | Ast.CeAnd (_, (Ast.CeNil _), ce) | Ast.CeAnd (_, ce, (Ast.CeNil _)) -> ce | ce -> ce - method class_type = fun ct -> match super#class_type ct with | Ast.CtAnd (_, (Ast.CtNil _), ct) | Ast.CtAnd (_, ct, (Ast.CtNil _)) -> ct | ct -> ct - method class_sig_item = fun csg -> match super#class_sig_item csg with | Ast.CgSem (_, (Ast.CgNil _), csg) | Ast.CgSem (_, csg, (Ast.CgNil _)) -> csg | csg -> csg - method class_str_item = fun cst -> match super#class_str_item cst with | Ast.CrSem (_, (Ast.CrNil _), cst) | Ast.CrSem (_, cst, (Ast.CrNil _)) -> cst | cst -> cst - end end @@ -15889,10 +15715,7 @@ module Struct = class ['accu] c_fold_pattern_vars : (string -> 'accu -> 'accu) -> 'accu -> - object inherit Ast.fold - val acc : 'accu - method acc : 'accu - + object inherit Ast.fold val acc : 'accu method acc : 'accu end val fold_pattern_vars : @@ -15904,21 +15727,13 @@ module Struct = 'accu -> object ('self_type) inherit Ast.fold - val free : 'accu - val env : S.t - method free : 'accu - method set_env : S.t -> 'self_type - method add_atom : string -> 'self_type - method add_patt : Ast.patt -> 'self_type - method add_binding : Ast.binding -> 'self_type - end val free_vars : S.t -> Ast.expr -> S.t @@ -15933,18 +15748,14 @@ module Struct = class ['accu] c_fold_pattern_vars f init = object inherit Ast.fold as super - val acc = init - method acc : 'accu = acc - method patt = function | Ast.PaId (_, (Ast.IdLid (_, s))) | Ast.PaLab (_, s, (Ast.PaNil _)) | Ast.PaOlb (_, s, (Ast.PaNil _)) -> {< acc = f s acc; >} | p -> super#patt p - end let fold_pattern_vars f p init = @@ -15962,23 +15773,15 @@ module Struct = ?(env_init = S.empty) free_init = object (o) inherit Ast.fold as super - val free = (free_init : 'accu) - val env = (env_init : S.t) - method free = free - method set_env = fun env -> {< env = env; >} - method add_atom = fun s -> {< env = S.add s env; >} - method add_patt = fun p -> {< env = fold_pattern_vars S.add p env; >} - method add_binding = fun bi -> {< env = fold_binding_vars S.add bi env; >} - method expr = function | Ast.ExId (_, (Ast.IdLid (_, s))) | @@ -15996,13 +15799,11 @@ module Struct = | Ast.ExObj (_, p, cst) -> ((o#add_patt p)#class_str_item cst)#set_env env | e -> super#expr e - method match_case = function | Ast.McArr (_, p, e1, e2) -> (((o#add_patt p)#expr e1)#expr e2)#set_env env | m -> super#match_case m - method str_item = function | Ast.StExt (_, s, t, _) -> (o#ctyp t)#add_atom s @@ -16011,7 +15812,6 @@ module Struct = | Ast.StVal (_, Ast.ReRecursive, bi) -> (o#add_binding bi)#binding bi | st -> super#str_item st - method class_expr = function | Ast.CeFun (_, p, ce) -> @@ -16025,7 +15825,6 @@ module Struct = | Ast.CeStr (_, p, cst) -> ((o#add_patt p)#class_str_item cst)#set_env env | ce -> super#class_expr ce - method class_str_item = function | (Ast.CrInh (_, _, _, "") as cst) -> @@ -16034,12 +15833,10 @@ module Struct = | Ast.CrVal (_, s, _, _, e) -> (o#expr e)#add_atom s | Ast.CrVvr (_, s, _, t) -> (o#ctyp t)#add_atom s | cst -> super#class_str_item cst - method module_expr = function | Ast.MeStr (_, st) -> (o#str_item st)#set_env env | me -> super#module_expr me - end let free_vars env_init e = @@ -16075,7 +15872,9 @@ module Struct = warning_verbose : bool ref; error_verbose : bool ref } - type token_info = { prev_loc : Loc.t; cur_loc : Loc.t } + type token_info = + { prev_loc : Loc.t; cur_loc : Loc.t; prev_loc_only : bool + } type token_stream = (Token.t * token_info) Stream.t @@ -16177,7 +15976,9 @@ module Struct = warning_verbose : bool ref; error_verbose : bool ref } - type token_info = { prev_loc : Loc.t; cur_loc : Loc.t } + type token_info = + { prev_loc : Loc.t; cur_loc : Loc.t; prev_loc_only : bool + } type token_stream = (Token.t * token_info) Stream.t @@ -16370,11 +16171,7 @@ module Struct = module Tools = struct - type prev_locs = - { mutable pl_strm : Obj.t; mutable pl_locs : (int * Obj.t) list - } - - let prev_locs = ref ([] : prev_locs list) + let get_prev_loc_only = ref false module Make (Structure : Structure.S) = struct @@ -16396,43 +16193,42 @@ module Struct = let keep_prev_loc strm = match Stream.peek strm with | None -> Stream.sempty - | Some ((_, init_loc)) -> - let myrecord = - { - pl_strm = Obj.repr Stream.sempty; - pl_locs = [ (0, (Obj.repr init_loc)) ]; - } in - let rec go prev_loc (__strm : _ Stream.t) = - (match Stream.peek __strm with - | Some ((tok, cur_loc)) -> - (Stream.junk __strm; - let strm = __strm - in - (myrecord.pl_locs <- - myrecord.pl_locs @ - [ ((Stream.count strm), - (Obj.repr cur_loc)) ]; - Stream.lcons - (fun _ -> - (tok, - { - prev_loc = prev_loc; - cur_loc = cur_loc; - })) - (Stream.slazy (fun _ -> go cur_loc strm)))) - | _ -> - (prev_locs := - List.filter (( != ) myrecord) !prev_locs; - Stream. - sempty)) in - let result = go init_loc strm - in - (prev_locs := myrecord :: !prev_locs; - myrecord.pl_strm <- Obj.repr result; - result) + | Some ((tok0, init_loc)) -> + let rec go prev_loc strm1 = + if !get_prev_loc_only + then + Stream.lcons + (fun _ -> + (tok0, + { + prev_loc = prev_loc; + cur_loc = prev_loc; + prev_loc_only = true; + })) + (Stream.slazy (fun _ -> go prev_loc strm1)) + else + (let (__strm : _ Stream.t) = strm1 + in + match Stream.peek __strm with + | Some ((tok, cur_loc)) -> + (Stream.junk __strm; + let strm = __strm + in + Stream.lcons + (fun _ -> + (tok, + { + prev_loc = prev_loc; + cur_loc = cur_loc; + prev_loc_only = false; + })) + (Stream.slazy + (fun _ -> go cur_loc strm))) + | _ -> Stream.sempty) + in go init_loc strm let drop_prev_loc strm = - stream_map (fun (tok, r) -> (tok, r)) strm + stream_map (fun (tok, r) -> (tok, (r.cur_loc))) strm let get_cur_loc strm = match Stream.peek strm with @@ -16440,29 +16236,17 @@ module Struct = | None -> Loc.ghost let get_prev_loc strm = - let c = Stream.count strm in - let rec drop l = - match l with - | [] -> [] - | (i, _) :: ll -> if i < c then drop ll else l in - let rec find l = - match l with - | [] -> None - | h :: t -> - if h.pl_strm == (Obj.repr strm) - then Some h - else find t - in - match find !prev_locs with - | None -> Loc.ghost - | Some r -> - (r.pl_locs <- drop r.pl_locs; - (match r.pl_locs with - | [] -> Loc.ghost - | (i, loc) :: _ -> - if i = c - then (Obj.obj loc : Loc.t) - else Loc.ghost)) + (get_prev_loc_only := true; + let result = + match Stream.peek strm with + | Some + ((_, { prev_loc = prev_loc; prev_loc_only = true })) + -> (Stream.junk strm; prev_loc) + | Some + ((_, { prev_loc = prev_loc; prev_loc_only = false })) + -> prev_loc + | None -> Loc.ghost + in (get_prev_loc_only := false; result)) let is_level_labelled n lev = match lev.lname with | Some n1 -> n = n1 | None -> false @@ -18657,191 +18441,113 @@ module Printers = unit -> object ('a) method interf : formatter -> Ast.sig_item -> unit - method implem : formatter -> Ast.str_item -> unit - method sig_item : formatter -> Ast.sig_item -> unit - method str_item : formatter -> Ast.str_item -> unit - val pipe : bool - val semi : bool - val semisep : sep - + val no_semisep : sep method value_val : string - method value_let : string - method andsep : sep - method anti : formatter -> string -> unit - method class_declaration : formatter -> Ast.class_expr -> unit - method class_expr : formatter -> Ast.class_expr -> unit - method class_sig_item : formatter -> Ast.class_sig_item -> unit - method class_str_item : formatter -> Ast.class_str_item -> unit - method class_type : formatter -> Ast.class_type -> unit - method constrain : formatter -> (Ast.ctyp * Ast.ctyp) -> unit - method ctyp : formatter -> Ast.ctyp -> unit - method ctyp1 : formatter -> Ast.ctyp -> unit - method constructor_type : formatter -> Ast.ctyp -> unit - method dot_expr : formatter -> Ast.expr -> unit - method apply_expr : formatter -> Ast.expr -> unit - method expr : formatter -> Ast.expr -> unit - method expr_list : formatter -> Ast.expr list -> unit - method expr_list_cons : bool -> formatter -> Ast.expr -> unit - method fun_binding : formatter -> fun_binding -> unit - method functor_arg : formatter -> (string * Ast.module_type) -> unit - method functor_args : formatter -> (string * Ast.module_type) list -> unit - method ident : formatter -> Ast.ident -> unit - method numeric : formatter -> string -> string -> unit - method binding : formatter -> Ast.binding -> unit - method record_binding : formatter -> Ast.rec_binding -> unit - method match_case : formatter -> Ast.match_case -> unit - method match_case_aux : formatter -> Ast.match_case -> unit - method mk_expr_list : Ast.expr -> ((Ast.expr list) * (Ast.expr option)) - method mk_patt_list : Ast.patt -> ((Ast.patt list) * (Ast.patt option)) - method simple_module_expr : formatter -> Ast.module_expr -> unit - method module_expr : formatter -> Ast.module_expr -> unit - method module_expr_get_functor_args : (string * Ast.module_type) list -> Ast.module_expr -> (((string * Ast.module_type) list) * Ast. module_expr * (Ast.module_type option)) - method module_rec_binding : formatter -> Ast.module_binding -> unit - method module_type : formatter -> Ast.module_type -> unit - method override_flag : formatter -> Ast.override_flag -> unit - method mutable_flag : formatter -> Ast.mutable_flag -> unit - method direction_flag : formatter -> Ast.direction_flag -> unit - method rec_flag : formatter -> Ast.rec_flag -> unit - method node : formatter -> 'b -> ('b -> Loc.t) -> unit - method patt : formatter -> Ast.patt -> unit - method patt1 : formatter -> Ast.patt -> unit - method patt2 : formatter -> Ast.patt -> unit - method patt3 : formatter -> Ast.patt -> unit - method patt4 : formatter -> Ast.patt -> unit - method patt5 : formatter -> Ast.patt -> unit - method patt_tycon : formatter -> Ast.patt -> unit - method patt_expr_fun_args : formatter -> (fun_binding * Ast.expr) -> unit - method patt_class_expr_fun_args : formatter -> (Ast.patt * Ast.class_expr) -> unit - method print_comments_before : Loc.t -> formatter -> unit - method private_flag : formatter -> Ast.private_flag -> unit - method virtual_flag : formatter -> Ast.virtual_flag -> unit - method quoted_string : formatter -> string -> unit - method raise_match_failure : formatter -> Loc.t -> unit - method reset : 'a - method reset_semi : 'a - method semisep : sep - method set_comments : bool -> 'a - method set_curry_constr : bool -> 'a - method set_loc_and_comments : 'a - method set_semisep : sep -> 'a - method simple_ctyp : formatter -> Ast.ctyp -> unit - method simple_expr : formatter -> Ast.expr -> unit - method simple_patt : formatter -> Ast.patt -> unit - method seq : formatter -> Ast.expr -> unit - method string : formatter -> string -> unit - method sum_type : formatter -> Ast.ctyp -> unit - method type_params : formatter -> Ast.ctyp list -> unit - method class_params : formatter -> Ast.ctyp -> unit - method under_pipe : 'a - method under_semi : 'a - method var : formatter -> string -> unit - method with_constraint : formatter -> Ast.with_constr -> unit - end val with_outfile : @@ -19032,43 +18738,26 @@ module Printers = ?(comments = true) () = object (o) val pipe = false - val semi = false - method under_pipe = {< pipe = true; >} - method under_semi = {< semi = true; >} - method reset_semi = {< semi = false; >} - method reset = {< pipe = false; semi = false; >} - val semisep = (";;" : sep) - + val no_semisep = ("" : sep) val mode = if comments then `comments else `no_comments - val curry_constr = init_curry_constr - val var_conversion = false - method andsep : sep = "@]@ @[<2>and@ " - method value_val = "val" - method value_let = "let" - method semisep = semisep - method set_semisep = fun s -> {< semisep = s; >} - method set_comments = fun b -> {< mode = if b then `comments else `no_comments; >} - method set_loc_and_comments = {< mode = `loc_and_comments; >} - method set_curry_constr = fun b -> {< curry_constr = b; >} - method print_comments_before = fun loc f -> match mode with @@ -19083,7 +18772,6 @@ module Printers = (fun s -> pp f "%s(*comm_loc: %a*)@ " s Loc.dump) (CommentFilter.take_stream comment_filter) | _ -> () - method var = fun f -> function @@ -19111,14 +18799,12 @@ module Printers = (sprintf "Bad token used as an identifier: %s" (Token.to_string tok)))) - method type_params = fun f -> function | [] -> () | [ x ] -> pp f "%a@ " o#ctyp x | l -> pp f "@[<1>(%a)@]@ " (list o#ctyp ",@ ") l - method class_params = fun f -> function @@ -19126,44 +18812,37 @@ module Printers = pp f "@[<1>%a,@ %a@]" o#class_params t1 o#class_params t2 | x -> o#ctyp f x - method override_flag = fun f -> function | Ast.OvOverride -> pp f "!" | Ast.OvNil -> () | Ast.OvAnt s -> o#anti f s - method mutable_flag = fun f -> function | Ast.MuMutable -> pp f "mutable@ " | Ast.MuNil -> () | Ast.MuAnt s -> o#anti f s - method rec_flag = fun f -> function | Ast.ReRecursive -> pp f "rec@ " | Ast.ReNil -> () | Ast.ReAnt s -> o#anti f s - method virtual_flag = fun f -> function | Ast.ViVirtual -> pp f "virtual@ " | Ast.ViNil -> () | Ast.ViAnt s -> o#anti f s - method private_flag = fun f -> function | Ast.PrPrivate -> pp f "private@ " | Ast.PrNil -> () | Ast.PrAnt s -> o#anti f s - method anti = fun f s -> pp f "$%s$" s - method seq = fun f -> function @@ -19171,14 +18850,12 @@ module Printers = pp f "%a;@ %a" o#under_semi#seq e1 o#seq e2 | Ast.ExSeq (_, e) -> o#seq f e | e -> o#expr f e - method match_case = fun f -> function | Ast.McNil _loc -> pp f "@[<2>@ _ ->@ %a@]" o#raise_match_failure _loc | a -> o#match_case_aux f a - method match_case_aux = fun f -> function @@ -19192,13 +18869,11 @@ module Printers = | Ast.McArr (_, p, w, e) -> pp f "@ | @[<2>%a@ when@ %a@ ->@ %a@]" o#patt p o#under_pipe#expr w o#under_pipe#expr e - method fun_binding = fun f -> function | `patt p -> o#simple_patt f p | `newtype i -> pp f "(type %s)" i - method binding = fun f bi -> let () = o#node f bi Ast.loc_of_binding @@ -19223,7 +18898,6 @@ module Printers = pp f "%a @[<0>%a=@]@ %a" o#simple_patt p (list' o#fun_binding "" "@ ") pl o#expr e) | Ast.BiAnt (_, s) -> o#anti f s - method record_binding = fun f bi -> let () = o#node f bi Ast.loc_of_rec_binding @@ -19236,7 +18910,6 @@ module Printers = (o#under_semi#record_binding f b1; o#under_semi#record_binding f b2) | Ast.RbAnt (_, s) -> o#anti f s - method mk_patt_list = function | Ast.PaApp (_, @@ -19246,7 +18919,6 @@ module Printers = let (pl, c) = o#mk_patt_list p2 in ((p1 :: pl), c) | Ast.PaId (_, (Ast.IdUid (_, "[]"))) -> ([], None) | p -> ([], (Some p)) - method mk_expr_list = function | Ast.ExApp (_, @@ -19256,7 +18928,6 @@ module Printers = let (el, c) = o#mk_expr_list e2 in ((e1 :: el), c) | Ast.ExId (_, (Ast.IdUid (_, "[]"))) -> ([], None) | e -> ([], (Some e)) - method expr_list = fun f -> function @@ -19265,7 +18936,6 @@ module Printers = | el -> pp f "@[<2>[ %a@] ]" (list o#under_semi#expr ";@ ") el - method expr_list_cons = fun simple f e -> let (el, c) = o#mk_expr_list e @@ -19277,41 +18947,33 @@ module Printers = then pp f "@[<2>(%a)@]" else pp f "@[<2>%a@]") (list o#under_semi#dot_expr " ::@ ") (el @ [ x ]) - method patt_expr_fun_args = fun f (p, e) -> let (pl, e) = expr_fun_args e in pp f "%a@ ->@ %a" (list o#fun_binding "@ ") (p :: pl) o#expr e - method patt_class_expr_fun_args = fun f (p, ce) -> let (pl, ce) = class_expr_fun_args ce in pp f "%a =@]@ %a" (list o#simple_patt "@ ") (p :: pl) o#class_expr ce - method constrain = fun f (t1, t2) -> pp f "@[<2>constraint@ %a =@ %a@]" o#ctyp t1 o#ctyp t2 - method sum_type = fun f t -> match Ast.list_of_ctyp t [] with | [] -> () | ts -> pp f "@[| %a@]" (list o#ctyp "@ | ") ts - method string = fun f -> pp f "%s" - method quoted_string = fun f -> pp f "%S" - method numeric = fun f num suff -> if num.[0] = '-' then pp f "(%s%s)" num suff else pp f "%s%s" num suff - method module_expr_get_functor_args = fun accu -> function @@ -19320,13 +18982,10 @@ module Printers = | Ast.MeTyc (_, me, mt) -> ((List.rev accu), me, (Some mt)) | me -> ((List.rev accu), me, None) - method functor_args = fun f -> list o#functor_arg "@ " f - method functor_arg = fun f (s, mt) -> pp f "@[<2>(%a :@ %a)@]" o#var s o#module_type mt - method module_rec_binding = fun f -> function @@ -19341,14 +19000,12 @@ module Printers = pp f o#andsep; o#module_rec_binding f mb2) | Ast.MbAnt (_, s) -> o#anti f s - method class_declaration = fun f -> function | Ast.CeTyc (_, ce, ct) -> pp f "%a :@ %a" o#class_expr ce o#class_type ct | ce -> o#class_expr f ce - method raise_match_failure = fun f _loc -> let n = Loc.file_name _loc in @@ -19367,11 +19024,9 @@ module Printers = (Ast.safe_string_escaped n))))), (Ast.ExInt (_loc, (string_of_int l))))), (Ast.ExInt (_loc, (string_of_int c))))))) - method node : 'a. formatter -> 'a -> ('a -> Loc.t) -> unit = fun f node loc_of_node -> o#print_comments_before (loc_of_node node) f - method ident = fun f i -> let () = o#node f i Ast.loc_of_ident @@ -19383,9 +19038,7 @@ module Printers = pp f "%a@,(%a)" o#ident i1 o#ident i2 | Ast.IdAnt (_, s) -> o#anti f s | Ast.IdLid (_, s) | Ast.IdUid (_, s) -> o#var f s - method private var_ident = {< var_conversion = true; >}#ident - method expr = fun f e -> let () = o#node f e Ast.loc_of_expr @@ -19495,7 +19148,6 @@ module Printers = "@[@[object @[<2>(%a)@]@ %a@]@ end@]" o#patt p o#class_str_item cst | e -> o#apply_expr f e - method apply_expr = fun f e -> let () = o#node f e Ast.loc_of_expr @@ -19503,7 +19155,6 @@ module Printers = match e with | Ast.ExNew (_, i) -> pp f "@[<2>new@ %a@]" o#ident i | e -> o#dot_expr f e - method dot_expr = fun f e -> let () = o#node f e Ast.loc_of_expr @@ -19521,7 +19172,6 @@ module Printers = | Ast.ExSnd (_, e, s) -> pp f "@[<2>%a#@,%s@]" o#dot_expr e s | e -> o#simple_expr f e - method simple_expr = fun f e -> let () = o#node f e Ast.loc_of_expr @@ -19595,14 +19245,12 @@ module Printers = Ast.ExAsr (_, _) | Ast.ExAsf _ | Ast.ExLaz (_, _) | Ast.ExNew (_, _) | Ast.ExObj (_, _, _) -> pp f "(%a)" o#reset#expr e - method direction_flag = fun f b -> match b with | Ast.DiTo -> pp_print_string f "to" | Ast.DiDownto -> pp_print_string f "downto" | Ast.DiAnt s -> o#anti f s - method patt = fun f p -> let () = o#node f p Ast.loc_of_patt @@ -19615,16 +19263,13 @@ module Printers = | Ast.PaSem (_, p1, p2) -> pp f "%a;@ %a" o#patt p1 o#patt p2 | p -> o#patt1 f p - method patt1 = fun f -> function | Ast.PaOrp (_, p1, p2) -> pp f "@[<2>%a@ |@ %a@]" o#patt1 p1 o#patt2 p2 | p -> o#patt2 f p - method patt2 = fun f p -> o#patt3 f p - method patt3 = fun f -> function @@ -19633,7 +19278,6 @@ module Printers = | Ast.PaCom (_, p1, p2) -> pp f "%a,@ %a" o#patt3 p1 o#patt3 p2 | p -> o#patt4 f p - method patt4 = fun f -> function @@ -19651,7 +19295,6 @@ module Printers = pp f "@[<2>%a@]" (list o#patt5 " ::@ ") (pl @ [ x ])) | p -> o#patt5 f p - method patt5 = fun f -> function @@ -19686,7 +19329,6 @@ module Printers = pp f "@[<2>%a@ (%a)@]" o#patt5 a (list o#simple_patt ",@ ") al) | p -> o#simple_patt f p - method simple_patt = fun f p -> let () = o#node f p Ast.loc_of_patt @@ -19729,14 +19371,12 @@ module Printers = Ast.PaCom (_, _, _) | Ast.PaSem (_, _, _) | Ast.PaEq (_, _, _) | Ast.PaLaz (_, _) as p) -> pp f "@[<1>(%a)@]" o#patt p - method patt_tycon = fun f -> function | Ast.PaTyc (_, p, t) -> pp f "%a :@ %a" o#patt p o#ctyp t | p -> o#patt f p - method simple_ctyp = fun f t -> let () = o#node f t Ast.loc_of_ctyp @@ -19779,7 +19419,6 @@ module Printers = pp f "%a *@ %a" o#simple_ctyp t1 o#simple_ctyp t2 | Ast.TyNil _ -> assert false | t -> pp f "@[<1>(%a)@]" o#ctyp t - method ctyp = fun f t -> let () = o#node f t Ast.loc_of_ctyp @@ -19824,7 +19463,6 @@ module Printers = then pp f "@ %a" (list o#constrain "@ ") cl else ()) | t -> o#ctyp1 f t - method ctyp1 = fun f -> function @@ -19844,7 +19482,6 @@ module Printers = | Ast.TyPrv (_, t) -> pp f "@[private@ %a@]" o#simple_ctyp t | t -> o#simple_ctyp f t - method constructor_type = fun f t -> match t with @@ -19855,7 +19492,6 @@ module Printers = o#constructor_type t2 | Ast.TyArr (_, _, _) -> pp f "(%a)" o#ctyp t | t -> o#ctyp f t - method sig_item = fun f sg -> let () = o#node f sg Ast.loc_of_sig_item @@ -19912,7 +19548,6 @@ module Printers = o#module_rec_binding mb semisep | Ast.SgDir (_, _, _) -> () | Ast.SgAnt (_, s) -> pp f "%a%(%)" o#anti s semisep - method str_item = fun f st -> let () = o#node f st Ast.loc_of_str_item @@ -19979,13 +19614,14 @@ module Printers = | Ast.StDir (_, _, _) -> () | Ast.StAnt (_, s) -> pp f "%a%(%)" o#anti s semisep | Ast.StExc (_, _, (Ast.OAnt _)) -> assert false - method module_type = fun f mt -> let () = o#node f mt Ast.loc_of_module_type in match mt with | Ast.MtNil _ -> assert false + | Ast.MtOf (_, me) -> + pp f "@[<2>module type of@ %a@]" o#module_expr me | Ast.MtId (_, i) -> o#ident f i | Ast.MtAnt (_, s) -> o#anti f s | Ast.MtFun (_, s, mt1, mt2) -> @@ -19997,7 +19633,6 @@ module Printers = | Ast.MtWit (_, mt, wc) -> pp f "@[<2>%a@ with@ %a@]" o#module_type mt o#with_constraint wc - method with_constraint = fun f wc -> let () = o#node f wc Ast.loc_of_with_constr @@ -20019,7 +19654,6 @@ module Printers = pp f o#andsep; o#with_constraint f wc2) | Ast.WcAnt (_, s) -> o#anti f s - method module_expr = fun f me -> let () = o#node f me Ast.loc_of_module_expr @@ -20032,7 +19666,6 @@ module Printers = "@[<2>@[struct@ %a@]@ end :@ @[sig@ %a@]@ end@]" o#str_item st o#sig_item sg | _ -> o#simple_module_expr f me - method simple_module_expr = fun f me -> let () = o#node f me Ast.loc_of_module_expr @@ -20059,7 +19692,6 @@ module Printers = o#module_type mt | Ast.MePkg (_, e) -> pp f "@[<1>(%s %a)@]" o#value_val o#expr e - method class_expr = fun f ce -> let () = o#node f ce Ast.loc_of_class_expr @@ -20107,7 +19739,6 @@ module Printers = pp f "@[<2>%a =@]@ %a" o#class_expr ce1 o#class_expr ce2 | _ -> assert false - method class_type = fun f ct -> let () = o#node f ct Ast.loc_of_class_type @@ -20144,7 +19775,6 @@ module Printers = | Ast.CtEq (_, ct1, ct2) -> pp f "%a =@ %a" o#class_type ct1 o#class_type ct2 | _ -> assert false - method class_sig_item = fun f csg -> let () = o#node f csg Ast.loc_of_class_sig_item @@ -20160,22 +19790,21 @@ module Printers = o#class_sig_item f csg2) | Ast.CgCtr (_, t1, t2) -> pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1 - o#ctyp t2 semisep + o#ctyp t2 no_semisep | Ast.CgInh (_, ct) -> pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct - semisep + no_semisep | Ast.CgMth (_, s, pr, t) -> pp f "@[<2>method %a%a :@ %a%(%)@]" o#private_flag - pr o#var s o#ctyp t semisep + pr o#var s o#ctyp t no_semisep | Ast.CgVir (_, s, pr, t) -> pp f "@[<2>method virtual %a%a :@ %a%(%)@]" - o#private_flag pr o#var s o#ctyp t semisep + o#private_flag pr o#var s o#ctyp t no_semisep | Ast.CgVal (_, s, mu, vi, t) -> pp f "@[<2>%s %a%a%a :@ %a%(%)@]" o#value_val o#mutable_flag mu o#virtual_flag vi o#var s - o#ctyp t semisep - | Ast.CgAnt (_, s) -> pp f "%a%(%)" o#anti s semisep - + o#ctyp t no_semisep + | Ast.CgAnt (_, s) -> pp f "%a%(%)" o#anti s no_semisep method class_str_item = fun f cst -> let () = o#node f cst Ast.loc_of_class_str_item @@ -20191,45 +19820,43 @@ module Printers = o#class_str_item f cst2) | Ast.CrCtr (_, t1, t2) -> pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 - o#ctyp t2 semisep + o#ctyp t2 no_semisep | Ast.CrInh (_, ov, ce, "") -> pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov - o#class_expr ce semisep + o#class_expr ce no_semisep | Ast.CrInh (_, ov, ce, s) -> pp f "@[<2>inherit%a@ %a as@ %a%(%)@]" o#override_flag ov o#class_expr ce o#var s - semisep + no_semisep | Ast.CrIni (_, e) -> - pp f "@[<2>initializer@ %a%(%)@]" o#expr e semisep + pp f "@[<2>initializer@ %a%(%)@]" o#expr e + no_semisep | Ast.CrMth (_, s, ov, pr, e, (Ast.TyNil _)) -> pp f "@[<2>method%a %a%a =@ %a%(%)@]" o#override_flag ov o#private_flag pr o#var s - o#expr e semisep + o#expr e no_semisep | Ast.CrMth (_, s, ov, pr, e, t) -> pp f "@[<2>method%a %a%a :@ %a =@ %a%(%)@]" o#override_flag ov o#private_flag pr o#var s - o#ctyp t o#expr e semisep + o#ctyp t o#expr e no_semisep | Ast.CrVir (_, s, pr, t) -> pp f "@[<2>method virtual@ %a%a :@ %a%(%)@]" - o#private_flag pr o#var s o#ctyp t semisep + o#private_flag pr o#var s o#ctyp t no_semisep | Ast.CrVvr (_, s, mu, t) -> pp f "@[<2>%s virtual %a%a :@ %a%(%)@]" o#value_val - o#mutable_flag mu o#var s o#ctyp t semisep + o#mutable_flag mu o#var s o#ctyp t no_semisep | Ast.CrVal (_, s, ov, mu, e) -> pp f "@[<2>%s%a %a%a =@ %a%(%)@]" o#value_val o#override_flag ov o#mutable_flag mu o#var s - o#expr e semisep - | Ast.CrAnt (_, s) -> pp f "%a%(%)" o#anti s semisep - + o#expr e no_semisep + | Ast.CrAnt (_, s) -> pp f "%a%(%)" o#anti s no_semisep method implem = fun f st -> match st with | Ast.StExp (_, e) -> pp f "@[<0>%a%(%)@]@." o#expr e semisep | st -> pp f "@[%a@]@." o#str_item st - method interf = fun f sg -> pp f "@[%a@]@." o#sig_item sg - end let with_outfile output_file fct arg = @@ -20341,8 +19968,7 @@ module Printers = class printer : ?curry_constr: bool -> ?comments: bool -> - unit -> object ('a) inherit OCaml.Make(Syntax).printer - end + unit -> object ('a) inherit OCaml.Make(Syntax).printer end val with_outfile : string option -> (formatter -> 'a -> unit) -> 'a -> unit @@ -20394,35 +20020,22 @@ module Printers = inherit PP_o.printer ~curry_constr: init_curry_constr ~comments () as super - val! semisep = (";" : sep) - + val! no_semisep = (";" : sep) val mode = if comments then `comments else `no_comments - val curry_constr = init_curry_constr - val first_match_case = true - method andsep : sep = "@]@ @[<2>and@ " - method value_val = "value" - method value_let = "value" - method under_pipe = o - method under_semi = o - method reset_semi = o - method reset = o - method private unset_first_match_case = {< first_match_case = false; >} - method private set_first_match_case = {< first_match_case = true; >} - method seq = fun f e -> let rec self right f e = @@ -20446,7 +20059,6 @@ module Printers = | _ -> go_right f e2)) | e -> o#expr f e in self true f e - method var = fun f -> function @@ -20466,14 +20078,12 @@ module Printers = failwith (sprintf "Bad token used as an identifier: %s" (Token.to_string tok))) - method type_params = fun f -> function | [] -> () | [ x ] -> pp f "@ %a" o#ctyp x | l -> pp f "@ @[<1>%a@]" (list o#ctyp "@ ") l - method match_case = fun f -> function @@ -20481,7 +20091,6 @@ module Printers = | m -> pp f "@ [ %a ]" o#set_first_match_case#match_case_aux m - method match_case_aux = fun f -> function @@ -20500,13 +20109,11 @@ module Printers = in pp f "@[<2>%a@ when@ %a@ ->@ %a@]" o#patt p o#under_pipe#expr w o#under_pipe#expr e - method sum_type = fun f -> function | Ast.TyNil _ -> pp f "[]" | t -> pp f "@[[ %a ]@]" o#ctyp t - method ident = fun f i -> let () = o#node f i Ast.loc_of_ident @@ -20515,7 +20122,6 @@ module Printers = | Ast.IdApp (_, i1, i2) -> pp f "%a@ %a" o#dot_ident i1 o#dot_ident i2 | i -> o#dot_ident f i - method private dot_ident = fun f i -> let () = o#node f i Ast.loc_of_ident @@ -20526,7 +20132,6 @@ module Printers = | Ast.IdAnt (_, s) -> o#anti f s | Ast.IdLid (_, s) | Ast.IdUid (_, s) -> o#var f s | i -> pp f "(%a)" o#ident i - method patt4 = fun f -> function @@ -20544,7 +20149,6 @@ module Printers = pp f "@[<2>[ %a ::@ %a ]@]" (list o#patt ";@ ") pl o#patt x) | p -> super#patt4 f p - method expr_list_cons = fun _ f e -> let (el, c) = o#mk_expr_list e @@ -20554,7 +20158,6 @@ module Printers = | Some x -> pp f "@[<2>[ %a ::@ %a ]@]" (list o#expr ";@ ") el o#expr x - method expr = fun f e -> let () = o#node f e Ast.loc_of_expr @@ -20573,7 +20176,6 @@ module Printers = pp f "@[fun%a@]" o#match_case a | Ast.ExAsf _ -> pp f "@[<2>assert@ False@]" | e -> super#expr f e - method dot_expr = fun f e -> let () = o#node f e Ast.loc_of_expr @@ -20583,7 +20185,6 @@ module Printers = (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> pp f "@[<2>%a.@,val@]" o#simple_expr e | e -> super#dot_expr f e - method ctyp = fun f t -> let () = o#node f t Ast.loc_of_ctyp @@ -20600,7 +20201,6 @@ module Printers = | Ast.TyCol (_, t1, (Ast.TyMut (_, t2))) -> pp f "@[%a :@ mutable %a@]" o#ctyp t1 o#ctyp t2 | t -> super#ctyp f t - method simple_ctyp = fun f t -> let () = o#node f t Ast.loc_of_ctyp @@ -20620,7 +20220,6 @@ module Printers = | Ast.TyLab (_, s, t) -> pp f "@[<2>~%s:@ %a@]" s o#simple_ctyp t | t -> super#simple_ctyp f t - method ctyp1 = fun f -> function @@ -20638,7 +20237,6 @@ module Printers = pp f "@[<2>! %a.@ %a@]" (list o#ctyp "@ ") (a :: al) o#ctyp t2 | t -> super#ctyp1 f t - method constructor_type = fun f t -> match t with @@ -20648,14 +20246,12 @@ module Printers = pp f "%a@ and %a" o#constructor_type t1 o#constructor_type t2 | t -> o#ctyp f t - method str_item = fun f st -> match st with | Ast.StExp (_, e) -> pp f "@[<2>%a%(%)@]" o#expr e semisep | st -> super#str_item f st - method module_expr = fun f me -> let () = o#node f me Ast.loc_of_module_expr @@ -20665,7 +20261,6 @@ module Printers = pp f "@[<2>%a@ %a@]" o#module_expr me1 o#simple_module_expr me2 | me -> super#module_expr f me - method simple_module_expr = fun f me -> let () = o#node f me Ast.loc_of_module_expr @@ -20673,9 +20268,7 @@ module Printers = match me with | Ast.MeApp (_, _, _) -> pp f "(%a)" o#module_expr me | _ -> super#simple_module_expr f me - method implem = fun f st -> pp f "@[%a@]@." o#str_item st - method class_type = fun f ct -> let () = o#node f ct Ast.loc_of_class_type @@ -20696,7 +20289,6 @@ module Printers = pp f "@[<2>virtual@ %a@ [@,%a@]@,]" o#var i o#class_params t | ct -> super#class_type f ct - method class_expr = fun f ce -> let () = o#node f ce Ast.loc_of_class_expr @@ -20712,9 +20304,8 @@ module Printers = | Ast.CeCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), t) -> pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#var i - o#ctyp t + o#class_params t | ce -> super#class_expr f ce - end let with_outfile = with_outfile @@ -21443,6 +21034,11 @@ module Register : PreCast.Ast.str_item parser_fun -> PreCast.Ast.sig_item parser_fun -> unit + val current_parser : + unit -> + ((PreCast.Ast.str_item parser_fun) * + (PreCast.Ast.sig_item parser_fun)) + module Parser (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> Sig.Parser(Ast).S) : sig end @@ -21466,6 +21062,11 @@ module Register : PreCast.Ast.str_item printer_fun -> PreCast.Ast.sig_item printer_fun -> unit + val current_printer : + unit -> + ((PreCast.Ast.str_item printer_fun) * + (PreCast.Ast.sig_item printer_fun)) + module Printer (Id : Sig.Id) (Maker : functor (Syn : Sig.Syntax) -> Sig.Printer(Syn.Ast).S) : @@ -21551,12 +21152,16 @@ module Register : let register_parser f g = (str_item_parser := f; sig_item_parser := g) + let current_parser () = ((!str_item_parser), (!sig_item_parser)) + let register_str_item_printer f = str_item_printer := f let register_sig_item_printer f = sig_item_printer := f let register_printer f g = (str_item_printer := f; sig_item_printer := g) + let current_printer () = ((!str_item_printer), (!sig_item_printer)) + module Plugin (Id : Sig.Id) (Maker : functor (Unit : sig end) -> sig end) = struct diff --git a/camlp4/boot/Camlp4Ast.ml b/camlp4/boot/Camlp4Ast.ml index e4c2b0192..cab41221e 100644 --- a/camlp4/boot/Camlp4Ast.ml +++ b/camlp4/boot/Camlp4Ast.ml @@ -1826,6 +1826,14 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = and meta_module_type _loc = fun [ Ast.MtAnt x0 x1 -> Ast.ExAnt x0 x1 + | Ast.MtOf x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MtOf"))) + (meta_loc _loc x0)) + (meta_module_expr _loc x1) | Ast.MtWit x0 x1 x2 -> Ast.ExApp _loc (Ast.ExApp _loc @@ -3902,6 +3910,14 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = and meta_module_type _loc = fun [ Ast.MtAnt x0 x1 -> Ast.PaAnt x0 x1 + | Ast.MtOf x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MtOf"))) + (meta_loc _loc x0)) + (meta_module_expr _loc x1) | Ast.MtWit x0 x1 x2 -> Ast.PaApp _loc (Ast.PaApp _loc @@ -4922,6 +4938,9 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = let _x = o#loc _x in let _x_i1 = o#module_type _x_i1 in let _x_i2 = o#with_constr _x_i2 in MtWit _x _x_i1 _x_i2 + | MtOf _x _x_i1 -> + let _x = o#loc _x in + let _x_i1 = o#module_expr _x_i1 in MtOf _x _x_i1 | MtAnt _x _x_i1 -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in MtAnt _x _x_i1 ]; @@ -5698,6 +5717,8 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = | MtWit _x _x_i1 _x_i2 -> let o = o#loc _x in let o = o#module_type _x_i1 in let o = o#with_constr _x_i2 in o + | MtOf _x _x_i1 -> + let o = o#loc _x in let o = o#module_expr _x_i1 in o | MtAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; method module_expr : module_expr -> 'self_type = fun diff --git a/camlp4/boot/camlp4boot.ml b/camlp4/boot/camlp4boot.ml index 20482abcb..e7a26e71a 100644 --- a/camlp4/boot/camlp4boot.ml +++ b/camlp4/boot/camlp4boot.ml @@ -40,19 +40,19 @@ module R = let help_sequences () = (Printf.eprintf "\ -New syntax:\n\ - (e1; e2; ... ; en) OR begin e1; e2; ... ; en end\n\ - while e do e1; e2; ... ; en done\n\ - for v = v1 to/downto v2 do e1; e2; ... ; en done\n\ -Old syntax (still supported):\n\ - do {e1; e2; ... ; en}\n\ - while e do {e1; e2; ... ; en}\n\ - for v = v1 to/downto v2 do {e1; e2; ... ; en}\n\ -Very old (no more supported) syntax:\n\ - do e1; e2; ... ; en-1; return en\n\ - while e do e1; e2; ... ; en; done\n\ - for v = v1 to/downto v2 do e1; e2; ... ; en; done\n\ - "; +New syntax:\ +\n (e1; e2; ... ; en) OR begin e1; e2; ... ; en end\ +\n while e do e1; e2; ... ; en done\ +\n for v = v1 to/downto v2 do e1; e2; ... ; en done\ +\nOld syntax (still supported):\ +\n do {e1; e2; ... ; en}\ +\n while e do {e1; e2; ... ; en}\ +\n for v = v1 to/downto v2 do {e1; e2; ... ; en}\ +\nVery old (no more supported) syntax:\ +\n do e1; e2; ... ; en-1; return en\ +\n while e do e1; e2; ... ; en; done\ +\n for v = v1 to/downto v2 do e1; e2; ... ; en; done\ +\n"; flush stderr; exit 1) @@ -1148,13 +1148,13 @@ Very old (no more supported) syntax:\n\ ([ Gram.Skeyword "module"; Gram.Skeyword "type"; Gram.Snterm (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + (a_ident : 'a_ident Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)) ], (Gram.Action.mk - (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _ + (fun (mt : 'module_type) _ (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> (Ast.StMty (_loc, i, mt) : 'str_item)))); ([ Gram.Skeyword "module"; Gram.Skeyword "rec"; @@ -1406,7 +1406,16 @@ Very old (no more supported) syntax:\n\ (fun _ (sg : 'sig_items) _ (_loc : Gram.Loc.t) -> (Ast.MtSig (_loc, sg) : 'module_type)))) ]); ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], + [ ([ Gram.Skeyword "module"; Gram.Skeyword "type"; + Gram.Skeyword "of"; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (me : 'module_expr) _ _ _ + (_loc : Gram.Loc.t) -> + (Ast.MtOf (_loc, me) : 'module_type)))); + ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], (Gram.Action.mk (fun _ (mt : 'module_type) _ (_loc : Gram.Loc.t) -> (mt : 'module_type)))); @@ -1511,21 +1520,21 @@ Very old (no more supported) syntax:\n\ ([ Gram.Skeyword "module"; Gram.Skeyword "type"; Gram.Snterm (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (a_ident : 'a_ident Gram.Entry.t)) ], (Gram.Action.mk - (fun (i : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> + (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> (Ast.SgMty (_loc, i, (Ast.MtNil _loc)) : 'sig_item)))); ([ Gram.Skeyword "module"; Gram.Skeyword "type"; Gram.Snterm (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + (a_ident : 'a_ident Gram.Entry.t)); Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (module_type : 'module_type Gram.Entry.t)) ], (Gram.Action.mk - (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _ + (fun (mt : 'module_type) _ (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> (Ast.SgMty (_loc, i, mt) : 'sig_item)))); ([ Gram.Skeyword "module"; Gram.Skeyword "rec"; @@ -6873,8 +6882,9 @@ Very old (no more supported) syntax:\n\ [ ([ Gram.Snterm (Gram.Entry.obj (label : 'label Gram.Entry.t)); Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + Gram.Snterml + ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), + "top") ], (Gram.Action.mk (fun (e : 'expr) _ (l : 'label) (_loc : Gram.Loc.t) -> @@ -8529,10 +8539,9 @@ Very old (no more supported) syntax:\n\ (fun (x : 'type_parameter) (_loc : Gram.Loc.t) -> (x : 'more_ctyp)))); ([ Gram.Snterm - (Gram.Entry.obj - (type_kind : 'type_kind Gram.Entry.t)) ], + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk - (fun (x : 'type_kind) (_loc : Gram.Loc.t) -> + (fun (x : 'ctyp) (_loc : Gram.Loc.t) -> (x : 'more_ctyp)))); ([ Gram.Skeyword "`"; Gram.Snterm @@ -9292,7 +9301,6 @@ module Camlp4QuotationCommon = let antiquot_expander = object inherit Ast.map as super - method patt = function | (Ast.PaAnt (_loc, s) | Ast.PaStr (_loc, s) as p) -> @@ -9457,7 +9465,6 @@ module Camlp4QuotationCommon = p) | _ -> p) | p -> super#patt p - method expr = function | (Ast.ExAnt (_loc, s) | Ast.ExStr (_loc, s) as e) -> @@ -9496,7 +9503,11 @@ module Camlp4QuotationCommon = | "`flo" -> Ast.ExApp (_loc, (Ast.ExId (_loc, - (Ast.IdLid (_loc, "string_of_float")))), + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Camlp4_import")), + (Ast.IdAcc (_loc, + (Ast.IdUid (_loc, "Oprint")), + (Ast.IdLid (_loc, "float_repres")))))))), e) | "`str" -> Ast.ExApp (_loc, @@ -9853,7 +9864,6 @@ module Camlp4QuotationCommon = e) | _ -> e) | e -> super#expr e - end let add_quotation name entry mexpr mpatt = @@ -11846,12 +11856,10 @@ module G = class subst gmod = object inherit Ast.map as super - method ident = function | Ast.IdUid (_, x) when x = gm -> gmod | x -> super#ident x - end let subst_gmod ast gmod = (new subst gmod)#expr ast @@ -11905,13 +11913,11 @@ module G = let wildcarder = object (self) inherit Ast.map as super - method patt = function | Ast.PaId (_loc, (Ast.IdLid (_, _))) -> Ast.PaAny _loc | Ast.PaAli (_, p, _) -> self#patt p | p -> super#patt p - end let mk_tok _loc p t = @@ -13599,14 +13605,11 @@ Added statements: in loop class reloc _loc = - object inherit Ast.map as super - method loc = fun _ -> _loc - end + object inherit Ast.map as super method loc = fun _ -> _loc end (* method _Loc_t _ = _loc; *) class subst _loc env = object inherit reloc _loc as super - method expr = function | (Ast.ExId (_, (Ast.IdLid (_, x))) | @@ -13614,7 +13617,6 @@ Added statements: as e) -> (try List.assoc x env with | Not_found -> super#expr e) | e -> super#expr e - method patt = function | (Ast.PaId (_, (Ast.IdLid (_, x))) | @@ -13623,7 +13625,6 @@ Added statements: (try substp _loc [] (List.assoc x env) with | Not_found -> super#patt p) | p -> super#patt p - end let incorrect_number loc l1 l2 = @@ -14481,6 +14482,112 @@ Added statements: (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> (let i = Gram.Token.extract_string i in i : 'uident)))) ]) ])) + ()); + Gram.extend + (* dirty hack to allow polymorphic variants using the introduced keywords. *) + (expr : 'expr Gram.Entry.t) + ((fun () -> + ((Some (Camlp4.Sig.Grammar.Before "simple")), + [ (None, None, + [ ([ Gram.Skeyword "`"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> + (Ast.ExVrn (_loc, s) : 'expr)))); + ([ Gram.Skeyword "`"; + Gram.srules expr + [ ([ Gram.Skeyword "IN" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__30)))); + ([ Gram.Skeyword "DEFINE" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__30)))); + ([ Gram.Skeyword "ENDIF" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__30)))); + ([ Gram.Skeyword "END" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__30)))); + ([ Gram.Skeyword "ELSE" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__30)))); + ([ Gram.Skeyword "THEN" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__30)))); + ([ Gram.Skeyword "IFNDEF" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__30)))); + ([ Gram.Skeyword "IFDEF" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__30)))) ] ], + (Gram.Action.mk + (fun (kwd : 'e__30) _ (_loc : Gram.Loc.t) -> + (Ast.ExVrn (_loc, kwd) : 'expr)))) ]) ])) + ()); + Gram.extend (* idem *) (patt : 'patt Gram.Entry.t) + ((fun () -> + ((Some (Camlp4.Sig.Grammar.Before "simple")), + [ (None, None, + [ ([ Gram.Skeyword "`"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> + (Ast.PaVrn (_loc, s) : 'patt)))); + ([ Gram.Skeyword "`"; + Gram.srules patt + [ ([ Gram.Skeyword "ENDIF" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__31)))); + ([ Gram.Skeyword "END" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__31)))); + ([ Gram.Skeyword "ELSE" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__31)))); + ([ Gram.Skeyword "THEN" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__31)))); + ([ Gram.Skeyword "IFNDEF" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__31)))); + ([ Gram.Skeyword "IFDEF" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) + (_loc : Gram.Loc.t) -> + (Gram.Token.extract_string x : 'e__31)))) ] ], + (Gram.Action.mk + (fun (kwd : 'e__31) _ (_loc : Gram.Loc.t) -> + (Ast.PaVrn (_loc, kwd) : 'patt)))) ]) ])) ())) let _ = @@ -14740,7 +14847,7 @@ module L = *) module Id = struct - let name = "Camlp4ListComprenhsion" + let name = "Camlp4ListComprehension" let version = Sys.ocaml_version @@ -15022,12 +15129,12 @@ module L = Gram.Skeyword "<-" ], (Gram.Action.mk (fun _ (p : 'patt) (_loc : Gram.Loc.t) - -> (p : 'e__30)))) ]); + -> (p : 'e__32)))) ]); Gram.Snterml ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), "top") ], (Gram.Action.mk - (fun (e : 'expr) (p : 'e__30) + (fun (e : 'expr) (p : 'e__32) (_loc : Gram.Loc.t) -> (`gen ((p, e)) : 'item)))) ]) ])) ())) @@ -15217,7 +15324,7 @@ module B = | (("Parsers" | ""), ("pa_rp.cmo" | "rp" | "rparser" | "camlp4ocamlrevisedparserparser.cmo")) - -> load [ pa_r; pa_o; pa_rp ] + -> load [ pa_r; pa_rp ] | (("Parsers" | ""), ("pa_op.cmo" | "op" | "parser" | "camlp4ocamlparserparser.cmo")) -> load [ pa_r; pa_o; pa_rp; pa_op ] @@ -15241,7 +15348,7 @@ module B = load [ pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m ] | (("Parsers" | ""), "of") -> load - [ pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_rq; pa_g; pa_l; pa_m ] + [ pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_q; pa_g; pa_l; pa_m ] | (("Parsers" | ""), ("comp" | "camlp4listcomprehension.cmo")) -> load [ pa_l ] | (("Filters" | ""), ("lift" | "camlp4astlifter.cmo")) -> @@ -15250,7 +15357,8 @@ module B = load [ "Camlp4ExceptionTracer" ] | (("Filters" | ""), ("prof" | "camlp4profiler.cmo")) -> load [ "Camlp4Profiler" ] - | (("Filters" | ""), ("map" | "camlp4mapgenerator.cmo")) -> + | (* map is now an alias of fold since fold handles map too *) + (("Filters" | ""), ("map" | "camlp4mapgenerator.cmo")) -> load [ "Camlp4FoldGenerator" ] | (("Filters" | ""), ("fold" | "camlp4foldgenerator.cmo")) -> load [ "Camlp4FoldGenerator" ] @@ -15278,7 +15386,6 @@ module B = in real_load (try find_in_path y with | Not_found -> x)); !rcall_callback ()) - (* map is now an alias of fold since fold handles map too *) let print_warning = eprintf "%a:\n%s@." Loc.print let rec parse_file dyn_loader name pa getdir = @@ -15354,17 +15461,17 @@ Options:\n\ .%s Load this module inside the Camlp4 core@." (if DynLoader.is_native then "cmxs " else "(cmo|cma)"); Options.print_usage_list ini_sl; + (* loop (ini_sl @ ext_sl) where rec loop = + fun + [ [(y, _, _) :: _] when y = "-help" -> () + | [_ :: sl] -> loop sl + | [] -> eprintf " -help Display this list of options.@." ]; *) if ext_sl <> [] then (eprintf "Options added by loaded object files:@."; Options.print_usage_list ext_sl) else ()) - (* loop (ini_sl @ ext_sl) where rec loop = - fun - [ [(y, _, _) :: _] when y = "-help" -> () - | [_ :: sl] -> loop sl - | [] -> eprintf " -help Display this list of options.@." ]; *) let warn_noassert () = eprintf "\ diff --git a/camlp4/mkcamlp4.ml b/camlp4/mkcamlp4.ml index 6c6b4b245..8c911b12d 100644 --- a/camlp4/mkcamlp4.ml +++ b/camlp4/mkcamlp4.ml @@ -63,7 +63,7 @@ try do { close_out cout }; - run (["ocamlc"; "-I"; camlp4_standard_library; "camlp4lib.cma"; crc_ml] + run (["ocamlc"; "-I"; camlp4_standard_library; "dynlink.cma"; "camlp4lib.cma"; crc_ml] @ includes @ options @ ["Camlp4Bin.cmo"; "-linkall"]); clean(); } diff --git a/config/auto-aux/expm1.c b/config/auto-aux/expm1.c new file mode 100644 index 000000000..ec315871f --- /dev/null +++ b/config/auto-aux/expm1.c @@ -0,0 +1,26 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2011 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: longlong.c 4833 2002-05-25 08:33:26Z xleroy $ */ + +#include + +volatile double x; + +int main(int argc, char **argv) +{ + x = 3.1415; + x = expm1(x); + x = log1p(x); + return 0; +} diff --git a/configure b/configure index 019272552..4b7fabbdd 100755 --- a/configure +++ b/configure @@ -436,11 +436,12 @@ esac # Determine alignment constraints case "$host" in - sparc*-*-*|hppa*-*-*|arm*-*-*) + sparc*-*-*|hppa*-*-*|arm*-*-*|mips*-*-*) # On Sparc V9 with certain versions of gcc, determination of double # alignment is not reliable (PR#1521), hence force it. # Same goes for hppa. # PR#5088 suggests same problem on ARM. + # PR#5280 reports same problem on MIPS. # But there's a knack (PR#2572): # if we're in 64-bit mode (sizeof(long) == 8), # we must not doubleword-align floats... @@ -468,8 +469,8 @@ esac if $int64_native; then case "$host" in - # PR#5088: autodetection is unreliable on ARM - sparc*-*-*|hppa*-*-*|arm*-*-*) + # PR#5088: autodetection is unreliable on ARM. PR#5280: also on MIPS. + sparc*-*-*|hppa*-*-*|arm*-*-*|mips*-*-*) if test $2 = 8; then echo "64-bit integers can be word-aligned." echo "#undef ARCH_ALIGN_INT64" >> m.h @@ -1539,6 +1540,10 @@ if test $has_tk = true; then fi fi +case "$host" in + *-*-cygwin*) tk_libs="$tk_libs -lws2_32";; +esac + if test $has_tk = true; then if sh ./hasgot $tk_libs $tk_x11_libs $tkauxlibs Tk_SetGrid; then echo "Tcl/Tk libraries found." diff --git a/debugger/command_line.ml b/debugger/command_line.ml index babb65bbe..944efa864 100644 --- a/debugger/command_line.ml +++ b/debugger/command_line.ml @@ -1008,10 +1008,10 @@ Argument N means do this N times (or till program stops for another reason)." }; (* Breakpoints *) { instr_name = "break"; instr_prio = false; instr_action = instr_break; instr_repeat = false; instr_help = -"Set breakpoint at specified line or function.\n\ -Syntax: break function-name\n\ - break @ [module] linenum\n\ - break @ [module] # characternum" }; +"Set breakpoint at specified line or function.\ +\nSyntax: break function-name\ +\n break @ [module] linenum\ +\n break @ [module] # characternum" }; { instr_name = "delete"; instr_prio = false; instr_action = instr_delete; instr_repeat = false; instr_help = "delete some breakpoints.\n\ diff --git a/emacs/Makefile b/emacs/Makefile index 9519b396a..077770c64 100644 --- a/emacs/Makefile +++ b/emacs/Makefile @@ -72,5 +72,9 @@ ocamltags: ocamltags.in install-ocamltags: ocamltags cp ocamltags $(SCRIPTDIR)/ocamltags +# This is for testing purposes +compile-only: + $(EMACS) --batch --eval '$(COMPILECMD)' + clean: - rm -f ocamltags *~ #*# + rm -f ocamltags *~ #*# *.elc diff --git a/emacs/caml-emacs.el b/emacs/caml-emacs.el index d034ff304..d0a2c86ee 100644 --- a/emacs/caml-emacs.el +++ b/emacs/caml-emacs.el @@ -39,5 +39,8 @@ (or (member 'drag modifiers) (member 'click modifiers))))) +(if (fboundp 'string-to-number) + (defalias 'caml-string-to-int 'string-to-number) + (defalias 'caml-string-to-int 'string-to-int)) (provide 'caml-emacs) diff --git a/emacs/caml-font.el b/emacs/caml-font.el index f287ffa04..956225466 100644 --- a/emacs/caml-font.el +++ b/emacs/caml-font.el @@ -59,7 +59,7 @@ . font-lock-builtin-face) ;control (,(concat "[|#&]\\|->\\|" - (regexp-opt '("do" "done" "dowto" "else" "for" "if" "ignore" + (regexp-opt '("do" "done" "downto" "else" "for" "if" "ignore" "lazy" "match" "new" "or" "then" "to" "try" "when" "while" "with") 'words)) diff --git a/emacs/caml-types.el b/emacs/caml-types.el index 05b1a2c0a..3c7433a81 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -264,13 +264,13 @@ See `caml-types-location-re' for annotation file format. ((string-match def-re kind) (let ((var-name (match-string 1 kind)) (l-file (file-name-nondirectory (match-string 2 kind))) - (l-line (string-to-int (match-string 4 kind))) - (l-bol (string-to-int (match-string 5 kind))) - (l-cnum (string-to-int (match-string 6 kind))) + (l-line (caml-string-to-int (match-string 4 kind))) + (l-bol (caml-string-to-int (match-string 5 kind))) + (l-cnum (caml-string-to-int (match-string 6 kind))) (r-file (file-name-nondirectory (match-string 7 kind))) - (r-line (string-to-int (match-string 9 kind))) - (r-bol (string-to-int (match-string 10 kind))) - (r-cnum (string-to-int (match-string 11 kind)))) + (r-line (caml-string-to-int (match-string 9 kind))) + (r-bol (caml-string-to-int (match-string 10 kind))) + (r-cnum (caml-string-to-int (match-string 11 kind)))) (let* ((lpos (vector l-file l-line l-bol l-cnum)) (rpos (vector r-file r-line r-bol r-cnum)) (left (caml-types-get-pos target-buf lpos)) @@ -280,9 +280,9 @@ See `caml-types-location-re' for annotation file format. ((string-match def-end-re kind) (let ((var-name (match-string 1 kind)) (l-file (file-name-nondirectory (match-string 2 kind))) - (l-line (string-to-int (match-string 4 kind))) - (l-bol (string-to-int (match-string 5 kind))) - (l-cnum (string-to-int (match-string 6 kind)))) + (l-line (caml-string-to-int (match-string 4 kind))) + (l-bol (caml-string-to-int (match-string 5 kind))) + (l-cnum (caml-string-to-int (match-string 6 kind)))) (let* ((lpos (vector l-file l-line l-bol l-cnum)) (left (caml-types-get-pos target-buf lpos)) (right (buffer-size target-buf))) @@ -291,13 +291,13 @@ See `caml-types-location-re' for annotation file format. ((string-match internal-re kind) (let ((var-name (match-string 1 kind)) (l-file (file-name-nondirectory (match-string 2 kind))) - (l-line (string-to-int (match-string 4 kind))) - (l-bol (string-to-int (match-string 5 kind))) - (l-cnum (string-to-int (match-string 6 kind))) + (l-line (caml-string-to-int (match-string 4 kind))) + (l-bol (caml-string-to-int (match-string 5 kind))) + (l-cnum (caml-string-to-int (match-string 6 kind))) (r-file (file-name-nondirectory (match-string 7 kind))) - (r-line (string-to-int (match-string 9 kind))) - (r-bol (string-to-int (match-string 10 kind))) - (r-cnum (string-to-int (match-string 11 kind)))) + (r-line (caml-string-to-int (match-string 9 kind))) + (r-bol (caml-string-to-int (match-string 10 kind))) + (r-cnum (caml-string-to-int (match-string 11 kind)))) (let* ((lpos (vector l-file l-line l-bol l-cnum)) (rpos (vector r-file r-line r-bol r-cnum)) (left (caml-types-get-pos target-buf lpos)) @@ -345,11 +345,12 @@ See `caml-types-location-re' for annotation file format. (message "done")) ))) +(defun caml-types-parent-dir (d) (file-name-directory (directory-file-name d))) + (defun caml-types-locate-type-file (target-path) (let ((sibling (concat (file-name-sans-extension target-path) ".annot"))) (if (file-exists-p sibling) sibling - (defun parent-dir (d) (file-name-directory (directory-file-name d))) (let ((project-dir (file-name-directory sibling)) type-path) (while (not (file-exists-p @@ -357,10 +358,10 @@ See `caml-types-location-re' for annotation file format. (expand-file-name (file-relative-name sibling project-dir) (expand-file-name "_build" project-dir))))) - (if (equal project-dir (parent-dir project-dir)) + (if (equal project-dir (caml-types-parent-dir project-dir)) (error (concat "No annotation file. " "You should compile with option \"-annot\"."))) - (setq project-dir (parent-dir project-dir))) + (setq project-dir (caml-types-parent-dir project-dir))) type-path)))) (defun caml-types-date< (date1 date2) @@ -400,13 +401,13 @@ See `caml-types-location-re' for annotation file format. (annotation ())) (while (re-search-forward caml-types-location-re () t) (let ((l-file (file-name-nondirectory (match-string 1))) - (l-line (string-to-int (match-string 3))) - (l-bol (string-to-int (match-string 4))) - (l-cnum (string-to-int (match-string 5))) + (l-line (caml-string-to-int (match-string 3))) + (l-bol (caml-string-to-int (match-string 4))) + (l-cnum (caml-string-to-int (match-string 5))) (r-file (file-name-nondirectory (match-string 6))) - (r-line (string-to-int (match-string 8))) - (r-bol (string-to-int (match-string 9))) - (r-cnum (string-to-int (match-string 10)))) + (r-line (caml-string-to-int (match-string 8))) + (r-bol (caml-string-to-int (match-string 9))) + (r-cnum (caml-string-to-int (match-string 10)))) (unless (caml-types-not-in-file l-file r-file target-file) (setq annotation ()) (while (next-annotation) diff --git a/emacs/caml-xemacs.el b/emacs/caml-xemacs.el index fe141c5ce..45d670c7a 100644 --- a/emacs/caml-xemacs.el +++ b/emacs/caml-xemacs.el @@ -50,4 +50,8 @@ (and (button-release-event-p event) (equal (event-button original) (event-button event)))) +(if (fboundp 'string-to-number) + (defalias 'caml-string-to-int 'string-to-number) + (defalias 'caml-string-to-int 'string-to-int)) + (provide 'caml-xemacs) diff --git a/emacs/caml.el b/emacs/caml.el index 4f03b5a58..2e37bff52 100644 --- a/emacs/caml.el +++ b/emacs/caml.el @@ -813,8 +813,9 @@ from an error message produced by camlc.") (defvar caml-error-overlay nil) (defvar caml-next-error-skip-warnings-flag nil) -(defun caml-string-to-int (x) - (if (fboundp 'string-to-number) (string-to-number x) (string-to-int x))) +(if (fboundp 'string-to-number) + (defalias 'caml-string-to-int 'string-to-number) + (defalias 'caml-string-to-int 'string-to-int)) ;;itz 04-21-96 somebody didn't get the documentation for next-error ;;right. When the optional argument is a number n, it should move @@ -1160,7 +1161,7 @@ Used to distinguish it from toplevel let construct.") (defconst caml-matching-kw-regexp (concat - "\\<\\(and\\|do\\(ne\\)?\\|e\\(lse\\|nd\\)\\|in\\|t\\(hen\\|o\\)" + "\\<\\(and\\|do\\(ne\\|wnto\\)?\\|e\\(lse\\|nd\\)\\|in\\|t\\(hen\\|o\\)" "\\|with\\)\\>\\|[^[|]|") "Regexp used in caml mode for skipping back over nested blocks.") @@ -1175,6 +1176,7 @@ Used to distinguish it from toplevel let construct.") ("else" . caml-find-else-match) ("then" . caml-find-then-match) ("to" . caml-find-done-match) + ("downto" . caml-find-done-match) ("do" . caml-find-done-match) ("and" . caml-find-and-match)) @@ -1581,7 +1583,7 @@ Does not preserve point." (defconst caml-leading-kwops-regexp (concat - "\\<\\(and\\|do\\(ne\\)?\\|e\\(lse\\|nd\\)\\|in" + "\\<\\(and\\|do\\(ne\\|wnto\\)?\\|e\\(lse\\|nd\\)\\|in" "\\|t\\(hen\\|o\\)\\|with\\)\\>\\|[]|})]") "Regexp matching caml keywords which need special indentation.") @@ -1595,6 +1597,7 @@ Does not preserve point." ("in" caml-in-extra-indent 2) ("then" caml-then-extra-indent 3) ("to" caml-to-extra-indent 0) + ("downto" caml-to-extra-indent 0) ("with" caml-with-extra-indent 2) ("|" caml-|-extra-indent 2) ("]" caml-rb-extra-indent 0) diff --git a/emacs/camldebug.el b/emacs/camldebug.el index d5ba599cc..57a98701b 100644 --- a/emacs/camldebug.el +++ b/emacs/camldebug.el @@ -302,8 +302,8 @@ buffer, then try to obtain the time from context around point." ((save-excursion (beginning-of-line 1) (looking-at "^Time : \\([0-9]+\\) - pc : [0-9]+ ")) - (string-to-int (match-string 1))) - ((string-to-int (camldebug-format-command "%e")))))) + (caml-string-to-int (match-string 1))) + ((caml-string-to-int (camldebug-format-command "%e")))))) (camldebug-call "goto" nil time))) (t (let ((module (camldebug-module-name (buffer-file-name))) @@ -325,7 +325,7 @@ buffer, then try to obtain the time from context around point." " - module " module "$") nil t) (match-string 1))))) - (if address (camldebug-call "goto" nil (string-to-int address)) + (if address (camldebug-call "goto" nil (caml-string-to-int address)) (error "No time at %s at %s" module camldebug-goto-position)))))) @@ -383,12 +383,12 @@ around point." (arg (cond ((eobp) (save-excursion (re-search-backward bpline nil t)) - (string-to-int (match-string 1))) + (caml-string-to-int (match-string 1))) ((save-excursion (beginning-of-line 1) (looking-at bpline)) - (string-to-int (match-string 1))) - ((string-to-int (camldebug-format-command "%e")))))) + (caml-string-to-int (match-string 1))) + ((caml-string-to-int (camldebug-format-command "%e")))))) (camldebug-call "delete" nil arg))) (t (let ((camldebug-delete-file @@ -409,7 +409,7 @@ around point." camldebug-delete-file camldebug-delete-position) (camldebug-call "delete" nil - (string-to-int camldebug-delete-output))))))))) + (caml-string-to-int camldebug-delete-output))))))))) (defun camldebug-complete-filter (string) (setq camldebug-filter-accumulator @@ -529,9 +529,9 @@ the camldebug commands `cd DIR' and `directory'." (let ((isbefore (string= "before" (match-string 5 camldebug-filter-accumulator))) - (startpos (string-to-int + (startpos (caml-string-to-int (match-string 3 camldebug-filter-accumulator))) - (endpos (string-to-int + (endpos (caml-string-to-int (match-string 4 camldebug-filter-accumulator)))) (list (match-string 2 camldebug-filter-accumulator) (if isbefore startpos endpos) @@ -704,7 +704,7 @@ Obeying it means displaying in another window the specified file and line." (move-overlay camldebug-overlay-under spos (- epos 1) buffer)) (save-excursion (set-buffer buffer) - (goto-char pos) + (goto-char spos) (beginning-of-line) (move-marker camldebug-event-marker (point)) (setq overlay-arrow-position camldebug-event-marker)))) diff --git a/emacs/inf-caml.el b/emacs/inf-caml.el index ba2eb0390..f3e4c48d1 100644 --- a/emacs/inf-caml.el +++ b/emacs/inf-caml.el @@ -163,7 +163,7 @@ Input and output via buffer `*inferior-caml*'." (setq count (+ count 1))) (if (equal (buffer-name (current-buffer)) inferior-caml-buffer-name) - (end-of-buffer)) + (goto-char (point-max))) (while (> count 0) (previous-multiframe-window) @@ -201,7 +201,7 @@ Input and output via buffer `*inferior-caml*'." (re-search-backward (concat comint-prompt-regexp "[ \t]*Characters[ \t]+\\([0-9]+\\)-[0-9]+:$")) - (string-to-int (match-string 1)))))) + (caml-string-to-int (match-string 1)))))) (goto-char loc))) @@ -265,8 +265,8 @@ should lies." (cond ((re-search-forward " *Characters \\([01-9][01-9]*\\)-\\([1-9][01-9]*\\):\n[^W]" (point-max) t) - (setq beg (string-to-int (caml-match-string 1))) - (setq end (string-to-int (caml-match-string 2))) + (setq beg (caml-string-to-int (caml-match-string 1))) + (setq end (caml-string-to-int (caml-match-string 2))) (switch-to-buffer buf) (goto-char orig) (forward-byte end) @@ -330,7 +330,7 @@ should lies." (beep) (if wait (read-event) (caml-sit-for 60))) (delete-overlay caml-error-overlay))))) -;; wait some amount for ouput, that is, until inferior-caml-output is set +;; wait some amount for output, that is, until inferior-caml-output is set ;; to true. Hence, interleaves sitting for shorts delays and checking the ;; flag. Give up after some time. Typing into the source buffer will cancel ;; waiting, i.e. may report 'No result yet' diff --git a/lex/output.ml b/lex/output.ml index 620f67f65..5ca403b52 100644 --- a/lex/output.ml +++ b/lex/output.ml @@ -74,8 +74,8 @@ let output_tables oc tbl = let output_entry sourcefile ic oc oci e = let init_num, init_moves = e.auto_initial_state in - fprintf oc "%s %alexbuf =\n\ - %a%a __ocaml_lex_%s_rec %alexbuf %d\n" + fprintf oc "%s %alexbuf =\ +\n %a%a __ocaml_lex_%s_rec %alexbuf %d\n" e.auto_name output_args e.auto_args (fun oc x -> diff --git a/lex/outputbis.ml b/lex/outputbis.ml index 266c0acbd..6d5e77c30 100644 --- a/lex/outputbis.ml +++ b/lex/outputbis.ml @@ -20,31 +20,31 @@ open Lexgen open Common let output_auto_defs oc = - fprintf oc "let __ocaml_lex_init_lexbuf lexbuf mem_size =\n\ - let pos = lexbuf.Lexing.lex_curr_pos in\n\ - lexbuf.Lexing.lex_mem <- Array.create mem_size (-1) ;\n\ - lexbuf.Lexing.lex_start_pos <- pos ;\n\ - lexbuf.Lexing.lex_last_pos <- pos ;\n\ - lexbuf.Lexing.lex_last_action <- -1\n\ -\n\ + fprintf oc "let __ocaml_lex_init_lexbuf lexbuf mem_size =\ +\n let pos = lexbuf.Lexing.lex_curr_pos in\ +\n lexbuf.Lexing.lex_mem <- Array.create mem_size (-1) ;\ +\n lexbuf.Lexing.lex_start_pos <- pos ;\ +\n lexbuf.Lexing.lex_last_pos <- pos ;\ +\n lexbuf.Lexing.lex_last_action <- -1\ +\n\n\ " ; output_string oc - "let rec __ocaml_lex_next_char lexbuf =\n\ - if lexbuf.Lexing.lex_curr_pos >= lexbuf.Lexing.lex_buffer_len then begin\n\ - if lexbuf.Lexing.lex_eof_reached then\n\ - 256\n\ - else begin\n\ - lexbuf.Lexing.refill_buff lexbuf ;\n\ - __ocaml_lex_next_char lexbuf\n\ - end\n\ - end else begin\n\ - let i = lexbuf.Lexing.lex_curr_pos in\n\ - let c = lexbuf.Lexing.lex_buffer.[i] in\n\ - lexbuf.Lexing.lex_curr_pos <- i+1 ;\n\ - Char.code c\n\ - end\n\ -\n\ + "let rec __ocaml_lex_next_char lexbuf =\ +\n if lexbuf.Lexing.lex_curr_pos >= lexbuf.Lexing.lex_buffer_len then begin\ +\n if lexbuf.Lexing.lex_eof_reached then\ +\n 256\ +\n else begin\ +\n lexbuf.Lexing.refill_buff lexbuf ;\ +\n __ocaml_lex_next_char lexbuf\ +\n end\ +\n end else begin\ +\n let i = lexbuf.Lexing.lex_curr_pos in\ +\n let c = lexbuf.Lexing.lex_buffer.[i] in\ +\n lexbuf.Lexing.lex_curr_pos <- i+1 ;\ +\n Char.code c\ +\n end\ +\n\n\ " @@ -155,13 +155,13 @@ let output_automata oc auto = let output_entry sourcefile ic oc tr e = let init_num, init_moves = e.auto_initial_state in - fprintf oc "%s %alexbuf =\n\ - __ocaml_lex_init_lexbuf lexbuf %d; %a\n\ - let __ocaml_lex_result = __ocaml_lex_state%d lexbuf in\n\ - lexbuf.Lexing.lex_start_p <- lexbuf.Lexing.lex_curr_p;\n\ - lexbuf.Lexing.lex_curr_p <- {lexbuf.Lexing.lex_curr_p with\n\ - Lexing.pos_cnum = lexbuf.Lexing.lex_abs_pos + lexbuf.Lexing.lex_curr_pos};\n\ - match __ocaml_lex_result with\n" + fprintf oc "%s %alexbuf =\ +\n __ocaml_lex_init_lexbuf lexbuf %d; %a\ +\n let __ocaml_lex_result = __ocaml_lex_state%d lexbuf in\ +\n lexbuf.Lexing.lex_start_p <- lexbuf.Lexing.lex_curr_p;\ +\n lexbuf.Lexing.lex_curr_p <- {lexbuf.Lexing.lex_curr_p with\ +\n Lexing.pos_cnum = lexbuf.Lexing.lex_abs_pos + lexbuf.Lexing.lex_curr_pos};\ +\n match __ocaml_lex_result with\n" e.auto_name output_args e.auto_args e.auto_mem_size (output_memory_actions " ") init_moves init_num ; List.iter diff --git a/man/ocamldep.m b/man/ocamldep.m index be77936ea..97d4b3776 100644 --- a/man/ocamldep.m +++ b/man/ocamldep.m @@ -59,6 +59,12 @@ the same .B \-I options that are passed to the compiler. .TP +.BI \-ml\-synonym \ .ext +Consider the given extension (with leading dot) to be a synonym for .ml. +.TP +.BI \-mli\-synonym \ .ext +Consider the given extension (with leading dot) to be a synonym for .mli. +.TP .B \-modules Output raw dependencies of the form .IR filename : \ Module1\ Module2 \ ... \ ModuleN diff --git a/myocamlbuild.ml b/myocamlbuild.ml index ec4299c03..663847b49 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -683,6 +683,7 @@ let camlp4_import_list = "parsing/asttypes.mli"; "parsing/parsetree.mli"; "typing/outcometree.mli"; + "typing/oprint.ml"; "myocamlbuild_config.ml"; "utils/config.mlbuild"] ;; diff --git a/ocamlbuild/display.ml b/ocamlbuild/display.ml index 2385a58f7..f8aab1374 100644 --- a/ocamlbuild/display.ml +++ b/ocamlbuild/display.ml @@ -25,10 +25,12 @@ module ANSI = let clear_to_eol oc () = fp oc "\027[K";; let bol oc () = fp oc "\r";; let get_columns () = - try - int_of_string (String.chomp (My_unix.run_and_read "tput cols")) - with - | Failure _ -> 80 + if Sys.os_type = "Unix" then + try + int_of_string (String.chomp (My_unix.run_and_read "tput cols")) + with + | Failure _ -> 80 + else 80 end ;; (* ***) diff --git a/ocamlbuild/main.ml b/ocamlbuild/main.ml index 668fd812d..28b7c5c46 100644 --- a/ocamlbuild/main.ml +++ b/ocamlbuild/main.ml @@ -109,7 +109,8 @@ let proceed () = if name = "_tags" then ignore (Configuration.parse_file ?dir path_name); - (String.length name > 0 && name.[0] <> '_' && name <> !Options.build_dir && not (List.mem name !Options.exclude_dirs)) + (List.mem name ["_oasis"] || (String.length name > 0 && name.[0] <> '_')) + && (name <> !Options.build_dir && not (List.mem name !Options.exclude_dirs)) && begin if path_name <> Filename.current_dir_name && Pathname.is_directory path_name then let tags = tags_of_pathname path_name in diff --git a/ocamlbuild/ocaml_compiler.ml b/ocamlbuild/ocaml_compiler.ml index e4d168bf8..6a3b9ba6b 100644 --- a/ocamlbuild/ocaml_compiler.ml +++ b/ocamlbuild/ocaml_compiler.ml @@ -130,7 +130,7 @@ let byte_compile_ocaml_interf mli cmi env build = let byte_compile_ocaml_implem ?tag ml cmo env build = let ml = env ml and cmo = env cmo in prepare_compile build ml; - ocamlc_c (tags_of_pathname ml++"implem"+++tag) ml cmo + ocamlc_c (Tags.union (tags_of_pathname ml) (tags_of_pathname cmo)++"implem"+++tag) ml cmo let cache_prepare_link = Hashtbl.create 107 let rec prepare_link tag cmx extensions build = diff --git a/ocamlbuild/ocaml_specific.ml b/ocamlbuild/ocaml_specific.ml index 500cacf56..1b830addb 100644 --- a/ocamlbuild/ocaml_specific.ml +++ b/ocamlbuild/ocaml_specific.ml @@ -63,9 +63,14 @@ rule "target files" begin fun env build -> let itarget = env "%.itarget" in let dir = Pathname.dirname itarget in - List.iter ignore_good - (build (List.map (fun x -> [dir/x]) (string_list_of_file itarget))); - Nop + let targets = string_list_of_file itarget in + List.iter ignore_good (build (List.map (fun x -> [dir/x]) targets)); + if !Options.make_links then + let link x = + Cmd (S [A"ln"; A"-sf"; P (!Options.build_dir/x); A Pathname.parent_dir_name]) in + Seq (List.map (fun x -> link (dir/x)) targets) + else + Nop end;; rule "ocaml: mli -> cmi" @@ -244,6 +249,12 @@ rule "ocaml: p.cmxa & p.a -> p.cmxs & p.so" ~deps:["%.p.cmxa"; x_p_a] (Ocaml_compiler.native_shared_library_link ~tags:["profile";"linkall"] "%.p.cmxa" "%.p.cmxs");; +rule "ocaml: cmx & o -> cmxs" + ~tags:["ocaml"; "native"; "shared"; "library"] + ~prods:["%.cmxs"] + ~deps:["%.cmx"; x_o] + (Ocaml_compiler.native_shared_library_link "%.cmx" "%.cmxs");; + rule "ocaml: cmx & o -> cmxs & so" ~tags:["ocaml"; "native"; "shared"; "library"] ~prods:["%.cmxs"; x_dll] @@ -406,7 +417,8 @@ end;; let () = if !Options.use_ocamlfind then begin (* Ocamlfind will link the archives for us. *) - flag ["ocaml"; "link"] & A"-linkpkg"; + flag ["ocaml"; "link"; "program"] & A"-linkpkg"; + flag ["ocaml"; "link"; "toplevel"] & A"-linkpkg"; let all_tags = [ ["ocaml"; "byte"; "compile"]; @@ -441,7 +453,7 @@ let () = let () = pflag ["ocaml"; "native"; "compile"] "for-pack" (fun param -> S [A "-for-pack"; A param]); - pflag ["ocaml"; "compile"] "inline" + pflag ["ocaml"; "native"; "compile"] "inline" (fun param -> S [A "-inline"; A param]); pflag ["ocaml"; "compile"] "pp" (fun param -> S [A "-pp"; A param]); @@ -503,6 +515,7 @@ flag ["ocaml"; "dtypes"; "compile"] (A "-dtypes");; flag ["ocaml"; "annot"; "compile"] (A "-annot");; flag ["ocaml"; "rectypes"; "compile"] (A "-rectypes");; flag ["ocaml"; "rectypes"; "infer_interface"] (A "-rectypes");; +flag ["ocaml"; "rectypes"; "doc"] (A "-rectypes");; flag ["ocaml"; "linkall"; "link"] (A "-linkall");; flag ["ocaml"; "link"; "profile"; "native"] (A "-p");; flag ["ocaml"; "link"; "program"; "custom"; "byte"] (A "-custom");; @@ -515,6 +528,8 @@ if not !Options.use_ocamlfind then begin flag ["ocaml"; "doc"; "thread"] (S[A"-I"; A"+threads"]); flag ["ocaml"; "link"; "thread"; "native"; "program"] (S[A "threads.cmxa"; A "-thread"]); flag ["ocaml"; "link"; "thread"; "byte"; "program"] (S[A "threads.cma"; A "-thread"]) +end else begin + flag ["ocaml"; "link"; "thread"; "program"] (A "-thread") end;; flag ["ocaml"; "compile"; "nopervasives"] (A"-nopervasives");; diff --git a/ocamlbuild/ocaml_tools.ml b/ocamlbuild/ocaml_tools.ml index f66c127c3..1381ca465 100644 --- a/ocamlbuild/ocaml_tools.ml +++ b/ocamlbuild/ocaml_tools.ml @@ -27,7 +27,7 @@ let ocamldep_command' tags = let menhir_ocamldep_command' tags ~menhir_spec out = let menhir = if !Options.ocamlyacc = N then V"MENHIR" else !Options.ocamlyacc in Cmd(S[menhir; T tags; A"--raw-depend"; - A"--ocamldep"; Quote (ocamldep_command' tags); + A"--ocamldep"; Quote (ocamldep_command' Tags.empty); menhir_spec ; Sh ">"; Px out]) let menhir_ocamldep_command arg out env _build = diff --git a/ocamlbuild/ocamlbuild_pack.mlpack b/ocamlbuild/ocamlbuild_pack.mlpack index 12c91d623..9653afbcc 100644 --- a/ocamlbuild/ocamlbuild_pack.mlpack +++ b/ocamlbuild/ocamlbuild_pack.mlpack @@ -1,7 +1,6 @@ Log My_unix My_std -Std_signatures Signatures Shell Display diff --git a/ocamlbuild/options.ml b/ocamlbuild/options.ml index 0256d43ac..e547d44e3 100644 --- a/ocamlbuild/options.ml +++ b/ocamlbuild/options.ml @@ -127,7 +127,7 @@ let add_to' rxs x = () let set_cmd rcmd = String (fun s -> rcmd := Sh s) let set_build_dir s = make_links := false; build_dir := s -let spec = +let spec = ref ( Arg.align [ "-version", Unit (fun () -> print_endline version; raise Exit_OK), " Display the version"; @@ -177,6 +177,7 @@ let spec = "-dont-catch-errors", Clear catch_errors, " Don't catch and display exceptions (useful to display the call stack)"; "-just-plugin", Set just_plugin, " Just build myocamlbuild.ml"; "-byte-plugin", Clear native_plugin, " Don't use a native plugin but bytecode"; + "-plugin-option", String ignore, " Use the option only when plugin is run"; "-sanitization-script", Set_string sanitization_script, " Change the file name for the generated sanitization script"; "-no-sanitize", Clear sanitize, " Do not generate sanitization script"; "-nothing-should-be-rebuilt", Set nothing_should_be_rebuilt, " Fail if something needs to be rebuilt"; @@ -195,6 +196,7 @@ let spec = "-ocamlc", set_cmd ocamlc, " Set the OCaml bytecode compiler"; "-ocamlopt", set_cmd ocamlopt, " Set the OCaml native compiler"; "-ocamldep", set_cmd ocamldep, " Set the OCaml dependency tool"; + "-ocamldoc", set_cmd ocamldoc, " Set the OCaml documentation generator"; "-ocamlyacc", set_cmd ocamlyacc, " Set the ocamlyacc tool"; "-menhir", set_cmd ocamlyacc, " Set the menhir tool (use it after -use-menhir)"; "-ocamllex", set_cmd ocamllex, " Set the ocamllex tool"; @@ -205,7 +207,10 @@ let spec = "--", Rest (fun x -> program_to_execute := true; add_to' program_args_internal x), " Stop argument processing, remaining arguments are given to the user program"; - ] + ]) + +let add x = + spec := !spec @ [x] let targets = ref [] let ocaml_libs = ref [] @@ -226,7 +231,7 @@ let init () = let anon_fun = add_to' targets_internal in let usage_msg = sprintf "Usage %s [options] " Sys.argv.(0) in let argv' = Array.concat [Sys.argv; [|dummy|]] in - parse_argv argv' spec anon_fun usage_msg; + parse_argv argv' !spec anon_fun usage_msg; Shell.mkdir_p !build_dir; let () = diff --git a/ocamlbuild/plugin.ml b/ocamlbuild/plugin.ml index 0786b4799..4180755be 100644 --- a/ocamlbuild/plugin.ml +++ b/ocamlbuild/plugin.ml @@ -103,8 +103,9 @@ module Make(U:sig end) = Shell.chdir Pathname.pwd; if not !Options.just_plugin then let runner = if !Options.native_plugin then N else !Options.ocamlrun in + let argv = List.tl (Array.to_list Sys.argv) in let spec = S[runner; P(!Options.build_dir/plugin^(!Options.exe)); - A"-no-plugin"; atomize (List.tl (Array.to_list Sys.argv))] in + A"-no-plugin"; atomize (List.filter (fun s -> s <> "-plugin-option") argv)] in let () = Log.finish () in raise (Exit_silently_with_code (sys_command (Command.string_of_command_spec spec))) end diff --git a/ocamlbuild/signatures.mli b/ocamlbuild/signatures.mli index cb343bd87..91dc6c62f 100644 --- a/ocamlbuild/signatures.mli +++ b/ocamlbuild/signatures.mli @@ -35,7 +35,7 @@ module type LIST = sig val union : 'a list -> 'a list -> 'a list (* Original functions *) - include Std_signatures.LIST + include module type of List end module type STRING = sig @@ -89,7 +89,7 @@ module type STRING = sig val explode : string -> char list (** The following are original functions from the [String] module. *) - include Std_signatures.STRING + include module type of String end module type TAGS = sig @@ -401,6 +401,8 @@ module type OPTIONS = sig val ext_lib : string ref val ext_dll : string ref val exe : string ref + + val add : string * Arg.spec * string -> unit end module type ARCH = sig diff --git a/ocamlbuild/std_signatures.mli b/ocamlbuild/std_signatures.mli deleted file mode 100644 index 8cef44138..000000000 --- a/ocamlbuild/std_signatures.mli +++ /dev/null @@ -1,94 +0,0 @@ -(***********************************************************************) -(* ocamlbuild *) -(* *) -(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) -(* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - - -(* Original author: Nicolas Pouillard *) -(** Some signatures from the standard library. *) - -module type LIST = sig - val length : 'a list -> int - val hd : 'a list -> 'a - val tl : 'a list -> 'a list - val nth : 'a list -> int -> 'a - val rev : 'a list -> 'a list - val append : 'a list -> 'a list -> 'a list - val rev_append : 'a list -> 'a list -> 'a list - val concat : 'a list list -> 'a list - val flatten : 'a list list -> 'a list - val iter : ('a -> unit) -> 'a list -> unit - val map : ('a -> 'b) -> 'a list -> 'b list - val rev_map : ('a -> 'b) -> 'a list -> 'b list - val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a - val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b - val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit - val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list - val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list - val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a - val fold_right2 : - ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c - val for_all : ('a -> bool) -> 'a list -> bool - val exists : ('a -> bool) -> 'a list -> bool - val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - val mem : 'a -> 'a list -> bool - val memq : 'a -> 'a list -> bool - val find : ('a -> bool) -> 'a list -> 'a - val filter : ('a -> bool) -> 'a list -> 'a list - val find_all : ('a -> bool) -> 'a list -> 'a list - val partition : ('a -> bool) -> 'a list -> 'a list * 'a list - val assoc : 'a -> ('a * 'b) list -> 'b - val assq : 'a -> ('a * 'b) list -> 'b - val mem_assoc : 'a -> ('a * 'b) list -> bool - val mem_assq : 'a -> ('a * 'b) list -> bool - val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list - val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list - val split : ('a * 'b) list -> 'a list * 'b list - val combine : 'a list -> 'b list -> ('a * 'b) list - val sort : ('a -> 'a -> int) -> 'a list -> 'a list - val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list - val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list - val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list -end - -module type STRING = sig - external length : string -> int = "%string_length" - external get : string -> int -> char = "%string_safe_get" - external set : string -> int -> char -> unit = "%string_safe_set" - external create : int -> string = "caml_create_string" - val make : int -> char -> string - val copy : string -> string - val sub : string -> int -> int -> string - val fill : string -> int -> int -> char -> unit - val blit : string -> int -> string -> int -> int -> unit - val concat : string -> string list -> string - val iter : (char -> unit) -> string -> unit - val escaped : string -> string - val index : string -> char -> int - val rindex : string -> char -> int - val index_from : string -> int -> char -> int - val rindex_from : string -> int -> char -> int - val contains : string -> char -> bool - val contains_from : string -> int -> char -> bool - val rcontains_from : string -> int -> char -> bool - val uppercase : string -> string - val lowercase : string -> string - val capitalize : string -> string - val uncapitalize : string -> string - type t = string - val compare : t -> t -> int - external unsafe_get : string -> int -> char = "%string_unsafe_get" - external unsafe_set : string -> int -> char -> unit - = "%string_unsafe_set" - external unsafe_blit : string -> int -> string -> int -> int -> unit - = "caml_blit_string" "noalloc" - external unsafe_fill : string -> int -> int -> char -> unit - = "caml_fill_string" "noalloc" -end diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index b352aab63..64b85a8a3 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -31,7 +31,7 @@ OCAMLPP=-pp './remove_DEBUG' MKDIR=mkdir -p CP=cp -f OCAMLDOC=ocamldoc -OCAMLDOC_RUN=./ocamldoc.opt #sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES) +OCAMLDOC_RUN=sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES) OCAMLDOC_OPT=$(OCAMLDOC).opt OCAMLDOC_LIBCMA=odoc_info.cma OCAMLDOC_LIBCMI=odoc_info.cmi @@ -194,14 +194,13 @@ STDLIB_MLIS=../stdlib/*.mli \ ../otherlibs/bigarray/bigarray.mli \ ../otherlibs/num/num.mli -all: exe lib generators +all: exe lib generators manpages exe: $(OCAMLDOC) lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST) generators: $(GENERATORS_CMOS) opt.opt: exeopt libopt generatorsopt - $(MAKE) manpages exeopt: $(OCAMLDOC_OPT) libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) generatorsopt: $(GENERATORS_CMXS) diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml index f3500f51d..2979dea05 100644 --- a/ocamldoc/odoc_args.ml +++ b/ocamldoc/odoc_args.ml @@ -39,6 +39,7 @@ let analyse_merge_options s = (M.merge_version, [Odoc_types.Merge_version]) ; (M.merge_see, [Odoc_types.Merge_see]) ; (M.merge_since, [Odoc_types.Merge_since]) ; + (M.merge_before, [Odoc_types.Merge_before]) ; (M.merge_deprecated, [Odoc_types.Merge_deprecated]) ; (M.merge_param, [Odoc_types.Merge_param]) ; (M.merge_raised_exception, [Odoc_types.Merge_raised_exception]) ; @@ -83,7 +84,7 @@ let add_hidden_modules s = let set_generator (g : Odoc_gen.generator) = current_generator := Some g (** The default option list *) -let options = ref [ +let default_options = [ "-version", Arg.Unit (fun () -> print_string M.message_version ; print_newline () ; exit 0) , M.option_version ; "-vnum", Arg.Unit (fun () -> print_string M.config_version ; print_newline () ; exit 0) , M.option_version ; @@ -155,7 +156,8 @@ let options = ref [ "-css-style", Arg.String (fun s -> Odoc_html.css_style := Some s), M.css_style ; "-index-only", Arg.Set Odoc_html.index_only, M.index_only ; "-colorize-code", Arg.Set Odoc_html.colorize_code, M.colorize_code ; - "-short-functors", Arg.Set Odoc_html.html_short_functors, M.html_short_functors ^ + "-short-functors", Arg.Set Odoc_html.html_short_functors, M.html_short_functors ; + "-charset", Arg.Set_string Odoc_html.charset, (M.charset !Odoc_html.charset)^ "\n\n *** LaTeX options ***\n"; (* latex only options *) @@ -206,7 +208,34 @@ let options = ref [ ] +let options = ref default_options + +let modified_options () = + !options != default_options + +let append_last_doc suffix = + match List.rev !options with + | (key, spec, doc) :: tl -> + options := List.rev ((key, spec, doc ^ suffix) :: tl) + | [] -> () + +(** The help option list, overriding the default ones from the Arg module *) +let help_options = ref [] +let help_action () = + let msg = + Arg.usage_string + (!options @ !help_options) + (M.usage ^ M.options_are) in + print_string msg +let () = + help_options := [ + "-help", Arg.Unit help_action, M.help ; + "--help", Arg.Unit help_action, M.help +] + let add_option o = + if not (modified_options ()) then + append_last_doc "\n *** custom generator options ***\n"; let (s,_,_) = o in let rec iter = function [] -> [o] @@ -234,7 +263,9 @@ let parse () = in Odoc_global.files := !Odoc_global.files @ [sf] in - let _ = Arg.parse !options + if modified_options () then append_last_doc "\n"; + let options = !options @ !help_options in + let _ = Arg.parse options anonymous (M.usage^M.options_are) in diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index fecef0850..76d4bd36c 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -28,6 +28,7 @@ let css_style = ref None let index_only = ref false let colorize_code = ref false let html_short_functors = ref false +let charset = ref "iso-8859-1" (** The functions used for naming files and html marks.*) @@ -538,28 +539,34 @@ class virtual info = match l with [] -> () | _ -> - bp b "%s: %s
\n" - Odoc_messages.authors - (String.concat ", " l) + bp b "%s: " Odoc_messages.authors; + self#html_of_text b [Raw (String.concat ", " l)]; + bs b "
\n" (** Print html code for the given optional version information.*) method html_of_version_opt b v_opt = match v_opt with None -> () | Some v -> - bp b "%s: %s
\n" Odoc_messages.version v + bp b "%s: " Odoc_messages.version; + self#html_of_text b [Raw v]; + bs b "
\n" (** Print html code for the given optional since information.*) method html_of_since_opt b s_opt = match s_opt with None -> () | Some s -> - bp b "%s %s
\n" Odoc_messages.since s + bp b "%s " Odoc_messages.since; + self#html_of_text b [Raw s]; + bs b "
\n" (** Print html code for the given "before" information.*) method html_of_before b l = let f (v, text) = - bp b "%s %s " Odoc_messages.before v; + bp b "%s " Odoc_messages.before; + self#html_of_text b [Raw v]; + bs b " "; self#html_of_text b text; bs b "
\n" in @@ -734,8 +741,10 @@ class html = val mutable doctype = "\n" - val mutable character_encoding = - "\n" + method character_encoding () = + Printf.sprintf + "\n" + !charset (** The default style options. *) val mutable default_style_options = @@ -943,7 +952,7 @@ class html = in bs b "\n"; bs b style; - bs b character_encoding ; + bs b (self#character_encoding ()) ; bs b "\n" ; diff --git a/ocamldoc/odoc_latex_style.ml b/ocamldoc/odoc_latex_style.ml index a689b2686..db0964a71 100644 --- a/ocamldoc/odoc_latex_style.ml +++ b/ocamldoc/odoc_latex_style.ml @@ -13,79 +13,79 @@ (* $Id$ *) -let content ="\n\ -%% Support macros for LaTeX documentation generated by ocamldoc.\n\ -%% This file is in the public domain; do what you want with it.\n\ +let content ="\ +\n%% Support macros for LaTeX documentation generated by ocamldoc.\ +\n%% This file is in the public domain; do what you want with it.\ \n\ -\\NeedsTeXFormat{LaTeX2e}\n\ -\\ProvidesPackage{ocamldoc}\n\ - [2001/12/04 v1.0 ocamldoc support]\n\ +\n\\NeedsTeXFormat{LaTeX2e}\ +\n\\ProvidesPackage{ocamldoc}\ +\n [2001/12/04 v1.0 ocamldoc support]\ \n\ -\\newenvironment{ocamldoccode}{%\n\ - \\bgroup\n\ - \\leftskip\\@totalleftmargin\n\ - \\rightskip\\z@skip\n\ - \\parindent\\z@\n\ - \\parfillskip\\@flushglue\n\ - \\parskip\\z@skip\n\ - %\\noindent\n\ - \\@@par\\smallskip\n\ - \\@tempswafalse\n\ - \\def\\par{%\n\ - \\if@tempswa\n\ - \\leavevmode\\null\\@@par\\penalty\\interlinepenalty\n\ - \\else\n\ - \\@tempswatrue\n\ - \\ifhmode\\@@par\\penalty\\interlinepenalty\\fi\n\ - \\fi}\n\ - \\obeylines\n\ - \\verbatim@font\n\ - \\let\\org@prime~%\n\ - \\@noligs\n\ - \\let\\org@dospecials\\dospecials\n\ - \\g@remfrom@specials{\\\\}\n\ - \\g@remfrom@specials{\\{}\n\ - \\g@remfrom@specials{\\}}\n\ - \\let\\do\\@makeother\n\ - \\dospecials\n\ - \\let\\dospecials\\org@dospecials\n\ - \\frenchspacing\\@vobeyspaces\n\ - \\everypar \\expandafter{\\the\\everypar \\unpenalty}}\n\ -{\\egroup\\par}\n\ +\n\\newenvironment{ocamldoccode}{%\ +\n \\bgroup\ +\n \\leftskip\\@totalleftmargin\ +\n \\rightskip\\z@skip\ +\n \\parindent\\z@\ +\n \\parfillskip\\@flushglue\ +\n \\parskip\\z@skip\ +\n %\\noindent\ +\n \\@@par\\smallskip\ +\n \\@tempswafalse\ +\n \\def\\par{%\ +\n \\if@tempswa\ +\n \\leavevmode\\null\\@@par\\penalty\\interlinepenalty\ +\n \\else\ +\n \\@tempswatrue\ +\n \\ifhmode\\@@par\\penalty\\interlinepenalty\\fi\ +\n \\fi}\ +\n \\obeylines\ +\n \\verbatim@font\ +\n \\let\\org@prime~%\ +\n \\@noligs\ +\n \\let\\org@dospecials\\dospecials\ +\n \\g@remfrom@specials{\\\\}\ +\n \\g@remfrom@specials{\\{}\ +\n \\g@remfrom@specials{\\}}\ +\n \\let\\do\\@makeother\ +\n \\dospecials\ +\n \\let\\dospecials\\org@dospecials\ +\n \\frenchspacing\\@vobeyspaces\ +\n \\everypar \\expandafter{\\the\\everypar \\unpenalty}}\ +\n{\\egroup\\par}\ \n\ -\\def\\g@remfrom@specials#1{%\n\ - \\def\\@new@specials{}\n\ - \\def\\@remove##1{%\n\ - \\ifx##1#1\\else\n\ - \\g@addto@macro\\@new@specials{\\do ##1}\\fi}\n\ - \\let\\do\\@remove\\dospecials\n\ - \\let\\dospecials\\@new@specials\n\ - }\n\ +\n\\def\\g@remfrom@specials#1{%\ +\n \\def\\@new@specials{}\ +\n \\def\\@remove##1{%\ +\n \\ifx##1#1\\else\ +\n \\g@addto@macro\\@new@specials{\\do ##1}\\fi}\ +\n \\let\\do\\@remove\\dospecials\ +\n \\let\\dospecials\\@new@specials\ +\n }\ \n\ -\\newenvironment{ocamldocdescription}\n\ -{\\list{}{\\rightmargin0pt \\topsep0pt}\\raggedright\\item\\noindent\\relax\\ignorespaces}\n\ -{\\endlist\\medskip}\n\ +\n\\newenvironment{ocamldocdescription}\ +\n{\\list{}{\\rightmargin0pt \\topsep0pt}\\raggedright\\item\\noindent\\relax\\ignorespaces}\ +\n{\\endlist\\medskip}\ \n\ -\\newenvironment{ocamldoccomment}\n\ -{\\list{}{\\leftmargin 2\\leftmargini \\rightmargin0pt \\topsep0pt}\\raggedright\\item\\noindent\\relax}\n\ -{\\endlist}\n\ +\n\\newenvironment{ocamldoccomment}\ +\n{\\list{}{\\leftmargin 2\\leftmargini \\rightmargin0pt \\topsep0pt}\\raggedright\\item\\noindent\\relax}\ +\n{\\endlist}\ \n\ -\\let \\ocamldocparagraph \\paragraph\n\ -\\def \\paragraph #1{\\ocamldocparagraph {#1}\\noindent}\n\ -\\let \\ocamldocsubparagraph \\subparagraph\n\ -\\def \\subparagraph #1{\\ocamldocsubparagraph {#1}\\noindent}\n\ +\n\\let \\ocamldocparagraph \\paragraph\ +\n\\def \\paragraph #1{\\ocamldocparagraph {#1}\\noindent}\ +\n\\let \\ocamldocsubparagraph \\subparagraph\ +\n\\def \\subparagraph #1{\\ocamldocsubparagraph {#1}\\noindent}\ \n\ -\\let\\ocamldocvspace\\vspace\n\ +\n\\let\\ocamldocvspace\\vspace\ \n\ -\\newenvironment{ocamldocindent}{\\list{}{}\\item\\relax}{\\endlist}\n\ -\\newenvironment{ocamldocsigend}\n\ - {\\noindent\\quad\\texttt{sig}\\ocamldocindent}\n\ - {\\endocamldocindent\\vskip -\\lastskip\n\ - \\noindent\\quad\\texttt{end}\\medskip}\n\ -\\newenvironment{ocamldocobjectend}\n\ - {\\noindent\\quad\\texttt{object}\\ocamldocindent}\n\ - {\\endocamldocindent\\vskip -\\lastskip\n\ - \\noindent\\quad\\texttt{end}\\medskip}\n\ +\n\\newenvironment{ocamldocindent}{\\list{}{}\\item\\relax}{\\endlist}\ +\n\\newenvironment{ocamldocsigend}\ +\n {\\noindent\\quad\\texttt{sig}\\ocamldocindent}\ +\n {\\endocamldocindent\\vskip -\\lastskip\ +\n \\noindent\\quad\\texttt{end}\\medskip}\ +\n\\newenvironment{ocamldocobjectend}\ +\n {\\noindent\\quad\\texttt{object}\\ocamldocindent}\ +\n {\\endocamldocindent\\vskip -\\lastskip\ +\n \\noindent\\quad\\texttt{end}\\medskip}\ \n\ -\\endinput\n\ -" +\n\\endinput\ +\n" diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml index 8d062f9e0..4c6b452c7 100644 --- a/ocamldoc/odoc_merge.ml +++ b/ocamldoc/odoc_merge.ml @@ -43,6 +43,8 @@ let merge_before_tags l = iter [] l ;; +let version_separators = Str.regexp "[\\.\\+]";; + (** Merge two Odoctypes.info struture, completing the information of the first one with the information in the second one. The merge treatment depends on a given merge_option list. @@ -103,7 +105,19 @@ let merge_info merge_options (m1 : info) (m2 : info) = else Some v1 in - let new_before = merge_before_tags (m1.i_before @ m2.i_before) in + let new_before = + match m1.i_before, m2.i_before with + [], [] -> [] + | l, [] + | [], l -> l + | l1, l2 -> + if List.mem Merge_before merge_options then + merge_before_tags (m1.i_before @ m2.i_before) + else + l1 in + let new_before = List.map (fun (v, t) -> (Str.split version_separators v, v, t)) new_before in + let new_before = List.sort Pervasives.compare new_before in + let new_before = List.map (fun (_, v, t) -> (v, t)) new_before in let new_dep = match m1.i_deprecated, m2.i_deprecated with None, None -> None diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml index 4d92c5d24..1f27d5763 100644 --- a/ocamldoc/odoc_messages.ml +++ b/ocamldoc/odoc_messages.ml @@ -21,8 +21,8 @@ let message_version = software^" "^config_version (** Messages for command line *) -let usage = "Usage : "^(Sys.argv.(0))^" [options] \n" -let options_are = "Options are :" +let usage = "Usage: "^(Sys.argv.(0))^" [options] \n" +let options_are = "Options are:" let option_version = "\tPrint version and exit" let latex_only = "(LaTeX only)" let texi_only = "(TeXinfo only)" @@ -53,6 +53,9 @@ let css_style = "\n\t\tUse content of as CSS style definition "^htm let index_only = "\tGenerate index files only "^html_only let colorize_code = "\n\t\tColorize code even in documentation pages "^html_only let html_short_functors = "\n\t\tUse short form to display functor types "^html_only +let charset c = Printf.sprintf + "\n\t\tAdd information about character encoding being s\n\t\t(default is %s)" + c let generate_html = "\tGenerate HTML documentation" let generate_latex = "\tGenerate LaTeX documentation" let generate_texinfo = "\tGenerate TeXinfo documentation" @@ -63,7 +66,7 @@ let option_not_in_native_code op = "Option "^op^" not available in native code v let default_out_file = "ocamldoc.out" let out_file = - "\tSet the ouput file name, used by texi, latex and dot generators\n"^ + "\tSet the output file name, used by texi, latex and dot generators\n"^ "\t\t(default is "^default_out_file^")\n"^ "\t\tor the prefix of index files for the HTML generator\n"^ "\t\t(default is index)" @@ -172,6 +175,7 @@ let merge_author = ('a', "merge @author") let merge_version = ('v', "merge @version") let merge_see = ('l', "merge @see") let merge_since = ('s', "merge @since") +let merge_before = ('b', "merge @before") let merge_deprecated = ('o', "merge @deprecated") let merge_param = ('p', "merge @param") let merge_raised_exception = ('e', "merge @raise") @@ -199,6 +203,7 @@ let merge_options = merge_version ; merge_see ; merge_since ; + merge_before ; merge_deprecated ; merge_param ; merge_raised_exception ; @@ -207,6 +212,8 @@ let merge_options = merge_all ] ) +let help = "\t\tDisplay this list of options" + (** Error and warning messages *) diff --git a/ocamldoc/odoc_types.ml b/ocamldoc/odoc_types.ml index 5c58afe16..53a1ca5f9 100644 --- a/ocamldoc/odoc_types.ml +++ b/ocamldoc/odoc_types.ml @@ -103,6 +103,7 @@ type merge_option = | Merge_version | Merge_see | Merge_since + | Merge_before | Merge_deprecated | Merge_param | Merge_raised_exception @@ -115,6 +116,7 @@ let all_merge_options = [ Merge_version ; Merge_see ; Merge_since ; + Merge_before ; Merge_deprecated ; Merge_param ; Merge_raised_exception ; diff --git a/ocamldoc/odoc_types.mli b/ocamldoc/odoc_types.mli index 639697f59..d4affb503 100644 --- a/ocamldoc/odoc_types.mli +++ b/ocamldoc/odoc_types.mli @@ -108,6 +108,7 @@ type merge_option = | Merge_version (** Versions are concatenated. *) | Merge_see (** See references are concatenated. *) | Merge_since (** Since information are concatenated. *) + | Merge_before (** Before information are concatenated. *) | Merge_deprecated (** Deprecated information are concatenated. *) | Merge_param (** Information on each parameter is concatenated, and all parameters are kept. *) diff --git a/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend index 92f29e8c6..c70f81a52 100644 --- a/otherlibs/bigarray/.depend +++ b/otherlibs/bigarray/.depend @@ -10,7 +10,7 @@ mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/mlvalues.h ../../byterun/config.h ../../byterun/misc.h \ ../../byterun/custom.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/io.h ../../byterun/sys.h + ../../byterun/io.h ../../byterun/sys.h ../../byterun/signals.h mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/mlvalues.h ../../byterun/config.h ../../byterun/misc.h \ diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c index 4ec24bf97..787b99e12 100644 --- a/otherlibs/bigarray/bigarray_stubs.c +++ b/otherlibs/bigarray/bigarray_stubs.c @@ -530,8 +530,13 @@ static int caml_ba_compare(value v1, value v2) struct caml_ba_array * b1 = Caml_ba_array_val(v1); struct caml_ba_array * b2 = Caml_ba_array_val(v2); uintnat n, num_elts; + intnat flags1, flags2; int i; + /* Compare kind & layout in case the arguments are of different types */ + flags1 = b1->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK); + flags2 = b2->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK); + if (flags1 != flags2) return flags2 - flags1; /* 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 */ diff --git a/otherlibs/bigarray/mmap_unix.c b/otherlibs/bigarray/mmap_unix.c index f75e63578..6af039302 100644 --- a/otherlibs/bigarray/mmap_unix.c +++ b/otherlibs/bigarray/mmap_unix.c @@ -21,6 +21,7 @@ #include "io.h" #include "mlvalues.h" #include "sys.h" +#include "signals.h" extern int caml_ba_element_size[]; /* from bigarray_stubs.c */ @@ -130,7 +131,7 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, value caml_ba_map_file(value vfd, value vkind, value vlayout, value vshared, value vdim, value vpos) { - invalid_argument("Bigarray.map_file: not supported"); + caml_invalid_argument("Bigarray.map_file: not supported"); return Val_unit; } diff --git a/otherlibs/bigarray/mmap_win32.c b/otherlibs/bigarray/mmap_win32.c index efb44fe5f..9be9e18e0 100644 --- a/otherlibs/bigarray/mmap_win32.c +++ b/otherlibs/bigarray/mmap_win32.c @@ -108,7 +108,7 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, if (fmap == NULL) caml_ba_sys_error(); /* Determine offset so that the mapping starts at the given file pos */ GetSystemInfo(&sysinfo); - delta = (uintnat) (startpos % sysinfo.dwPageSize); + delta = (uintnat) (startpos % sysinfo.dwAllocationGranularity); /* Map the mapping in memory */ li.QuadPart = startpos - delta; addr = @@ -133,7 +133,7 @@ void caml_ba_unmap_file(void * addr, uintnat len) uintnat delta; GetSystemInfo(&sysinfo); - delta = (uintnat) addr % sysinfo.dwPageSize; + delta = (uintnat) addr % sysinfo.dwAllocationGranularity; UnmapViewOfFile((void *)((uintnat)addr - delta)); } diff --git a/otherlibs/db/.depend b/otherlibs/db/.depend deleted file mode 100644 index ba0e54e57..000000000 --- a/otherlibs/db/.depend +++ /dev/null @@ -1,2 +0,0 @@ -db.cmo: db.cmi -db.cmx: db.cmi diff --git a/otherlibs/labltk/browser/shell.ml b/otherlibs/labltk/browser/shell.ml index be93ef5fd..1f1492de9 100644 --- a/otherlibs/labltk/browser/shell.ml +++ b/otherlibs/labltk/browser/shell.ml @@ -254,7 +254,7 @@ let may_exec = let path_sep = if is_win32 then ";" else ":" -let warnings = ref "Al" +let warnings = ref Warnings.defaults_w let program_not_found prog = Jg_message.info ~title:"Error" diff --git a/otherlibs/num/big_int.ml b/otherlibs/num/big_int.ml index 6b6015185..b96b8e1f4 100644 --- a/otherlibs/num/big_int.ml +++ b/otherlibs/num/big_int.ml @@ -698,7 +698,9 @@ let shift_right_towards_zero_big_int bi n = let tmp = create_nat 1 in shift_right_nat res 0 size_res tmp 0 nbits end; - { sign = bi.sign; abs_value = res } + if is_zero_nat res 0 size_res + then zero_big_int + else { sign = bi.sign; abs_value = res } end end diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c index 2e65ecd0b..fbef6ea05 100644 --- a/otherlibs/systhreads/st_stubs.c +++ b/otherlibs/systhreads/st_stubs.c @@ -451,6 +451,11 @@ CAMLprim value caml_thread_cleanup(value unit) /* ML */ static void caml_thread_stop(void) { +#ifndef NATIVE_CODE + /* PR#5188: update curr_thread->stack_low because the stack may have + been reallocated since the last time we entered a blocking section */ + curr_thread->stack_low = stack_low; +#endif /* Signal that the thread has terminated */ caml_threadstatus_terminate(Terminated(curr_thread->descr)); /* Remove th from the doubly-linked list of threads and free its info block */ diff --git a/otherlibs/systhreads/thread.ml b/otherlibs/systhreads/thread.ml index e7d528f64..18cc819bb 100644 --- a/otherlibs/systhreads/thread.ml +++ b/otherlibs/systhreads/thread.ml @@ -18,6 +18,7 @@ type t external thread_initialize : unit -> unit = "caml_thread_initialize" +external thread_cleanup : unit -> unit = "caml_thread_cleanup" external thread_new : (unit -> unit) -> t = "caml_thread_new" external thread_uncaught_exception : exn -> unit = "caml_thread_uncaught_exception" @@ -57,8 +58,17 @@ let preempt_signal = | _ -> Sys.sigvtalrm let _ = - ignore(Sys.signal preempt_signal (Sys.Signal_handle preempt)); - thread_initialize() + Sys.set_signal preempt_signal (Sys.Signal_handle preempt); + thread_initialize(); + at_exit + (fun () -> + thread_cleanup(); + (* In case of DLL-embedded Ocaml the preempt_signal handler + will point to nowhere after DLL unloading and an accidental + preempt_signal will crash the main program. So restore the + default handler. *) + Sys.set_signal preempt_signal Sys.Signal_default + ) (* Wait functions *) diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend index 42875bdcc..42dbc3c03 100644 --- a/otherlibs/unix/.depend +++ b/otherlibs/unix/.depend @@ -255,7 +255,8 @@ lockf.o: lockf.c ../../byterun/fail.h ../../byterun/compatibility.h \ lseek.o: lseek.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/mlvalues.h ../../byterun/io.h unixsupport.h + ../../byterun/mlvalues.h ../../byterun/io.h ../../byterun/signals.h \ + unixsupport.h mkdir.o: mkdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h unixsupport.h diff --git a/otherlibs/unix/lseek.c b/otherlibs/unix/lseek.c index cb59bb551..d8180eaea 100644 --- a/otherlibs/unix/lseek.c +++ b/otherlibs/unix/lseek.c @@ -18,6 +18,7 @@ #include #include #include +#include #include "unixsupport.h" #ifdef HAS_UNISTD diff --git a/otherlibs/win32unix/channels.c b/otherlibs/win32unix/channels.c index 1c2cd2734..56a19c7dc 100644 --- a/otherlibs/win32unix/channels.c +++ b/otherlibs/win32unix/channels.c @@ -30,6 +30,7 @@ int win_CRT_fd_of_filedescr(value handle) } else { int fd = _open_osfhandle((long) Handle_val(handle), O_BINARY); if (fd == -1) uerror("channel_of_descr", Nothing); + CRT_fd_val(handle) = fd; return fd; } } diff --git a/otherlibs/win32unix/close.c b/otherlibs/win32unix/close.c index 48cd60e7a..21254ef1e 100644 --- a/otherlibs/win32unix/close.c +++ b/otherlibs/win32unix/close.c @@ -15,6 +15,9 @@ #include #include "unixsupport.h" +#include + +extern int _close(int); CAMLprim value unix_close(value fd) { @@ -24,9 +27,17 @@ CAMLprim value unix_close(value fd) uerror("close", Nothing); } } else { - if (! CloseHandle(Handle_val(fd))) { - win32_maperr(GetLastError()); - uerror("close", Nothing); + /* If we have an fd then closing it also closes + * the underlying handle. Also, closing only + * the handle and not the fd leads to fd leaks. */ + if (CRT_fd_val(fd) != NO_CRT_FD) { + if (_close(CRT_fd_val(fd)) != 0) + uerror("close", Nothing); + } else { + if (! CloseHandle(Handle_val(fd))) { + win32_maperr(GetLastError()); + uerror("close", Nothing); + } } } return Val_unit; diff --git a/parsing/parser.mly b/parsing/parser.mly index b4fa1d41b..9bba8768c 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -1447,7 +1447,7 @@ simple_core_type2: package_type: mty_longident { ($1, []) } | mty_longident WITH package_type_cstrs { ($1, $3) } - +; package_type_cstr: TYPE LIDENT EQUAL core_type { ($2, $4) } ; diff --git a/stdlib/arg.ml b/stdlib/arg.ml index 009e20375..ac552d38e 100644 --- a/stdlib/arg.ml +++ b/stdlib/arg.ml @@ -90,10 +90,14 @@ let usage_b buf speclist errmsg = List.iter (print_spec buf) (add_help speclist); ;; -let usage speclist errmsg = +let usage_string speclist errmsg = let b = Buffer.create 200 in usage_b b speclist errmsg; - eprintf "%s" (Buffer.contents b); + Buffer.contents b; +;; + +let usage speclist errmsg = + eprintf "%s" (usage_string speclist errmsg); ;; let current = ref 0;; diff --git a/stdlib/arg.mli b/stdlib/arg.mli index 4e5ed08d1..887256615 100644 --- a/stdlib/arg.mli +++ b/stdlib/arg.mli @@ -79,7 +79,7 @@ val parse : as their arguments appear on the command line. If an error occurs, [Arg.parse] exits the program, after printing - an error message as follows: + to standard error an error message as follows: - The reason for the error: unknown option, invalid or missing argument, etc. - [usage_msg] - The list of options, each followed by the corresponding [doc] string. @@ -88,9 +88,9 @@ val parse : [-], include for example [("-", String anon_fun, doc)] in [speclist]. By default, [parse] recognizes two unit options, [-help] and [--help], - which will display [usage_msg] and the list of options, and exit - the program. You can override this behaviour by specifying your - own [-help] and [--help] options in [speclist]. + which will print to standard output [usage_msg] and the list of + options, and exit the program. You can override this behaviour + by specifying your own [-help] and [--help] options in [speclist]. *) val parse_argv : ?current: int ref -> string array -> @@ -115,11 +115,15 @@ exception Bad of string [Arg.Bad] is also raised by [Arg.parse_argv] in case of an error. *) val usage : (key * spec * doc) list -> usage_msg -> unit -(** [Arg.usage speclist usage_msg] prints an error message including - the list of valid options. This is the same message that - {!Arg.parse} prints in case of error. +(** [Arg.usage speclist usage_msg] prints to standard error + an error message that includes the list of valid options. This is + the same message that {!Arg.parse} prints in case of error. [speclist] and [usage_msg] are the same as for [Arg.parse]. *) +val usage_string : (key * spec * doc) list -> usage_msg -> string +(** Returns the message that would have been printed by {!Arg.usage}, + if provided with the same parameters. *) + val align: (key * spec * doc) list -> (key * spec * doc) list;; (** Align the documentation strings by inserting spaces at the first space, according to the length of the keyword. Use a diff --git a/stdlib/filename.mli b/stdlib/filename.mli index e43f19ccf..efbdcd98d 100644 --- a/stdlib/filename.mli +++ b/stdlib/filename.mli @@ -82,6 +82,7 @@ val temp_file : ?temp_dir: string -> string -> string -> string (readable and writable only by the file owner). The file is guaranteed to be different from any other file that existed when [temp_file] was called. + Raise [Sys_error] if the file could not be created. @before 3.11.2 no ?temp_dir optional argument *) @@ -95,6 +96,7 @@ val open_temp_file : [mode] is a list of additional flags to control the opening of the file. It can contain one or several of [Open_append], [Open_binary], and [Open_text]. The default is [[Open_text]] (open in text mode). + Raise [Sys_error] if the file could not be opened. @before 3.11.2 no ?temp_dir optional argument *) diff --git a/stdlib/format.mli b/stdlib/format.mli index 38123900a..9b49c53f4 100644 --- a/stdlib/format.mli +++ b/stdlib/format.mli @@ -689,11 +689,11 @@ val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; (** {6 Deprecated} *) val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a;; -(** Deprecated and error prone function. Do not use it. +(** A deprecated and error prone function. Do not use it. If you need to print to some buffer [b], you must first define a formatter writing to [b], using [let to_b = formatter_of_buffer b]; then use regular calls to [Format.fprintf] on formatter [to_b]. *) val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; -(** Deprecated name. A synonym for [ksprintf]. *) +(** A deprecated synonym for [ksprintf]. *) diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml index 44c7fb271..5d53c7413 100644 --- a/stdlib/parsing.ml +++ b/stdlib/parsing.ml @@ -151,6 +151,7 @@ let yyparse tables start lexer lexbuf = and init_stackbase = env.stackbase and init_state = env.state and init_curr_char = env.curr_char + and init_lval = env.lval and init_errflag = env.errflag in env.stackbase <- env.sp + 1; env.curr_char <- start; @@ -164,6 +165,7 @@ let yyparse tables start lexer lexbuf = env.stackbase <- init_stackbase; env.state <- init_state; env.curr_char <- init_curr_char; + env.lval <- init_lval; env.errflag <- init_errflag; match exn with YYexit v -> diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index 7c35f6d4d..2062f8fdb 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -310,7 +310,7 @@ external atan : float -> float = "caml_atan_float" "atan" "float" Result is in radians and is between [-pi/2] and [pi/2]. *) external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float" -(** [atan x y] returns the arc tangent of [y /. x]. The signs of [x] +(** [atan2 y x] returns the arc tangent of [y /. x]. The signs of [x] and [y] are used to determine the quadrant of the result. Result is in radians and is between [-pi] and [pi]. *) @@ -518,7 +518,7 @@ val stdout : out_channel (** The standard output for the process. *) val stderr : out_channel -(** The standard error ouput for the process. *) +(** The standard error output for the process. *) (** {7 Output functions on standard output} *) @@ -871,9 +871,14 @@ external decr : int ref -> unit = "%decr" included for backward compatibility with earlier releases of Objective Caml. ['a] is the type of the parameters of the format, - ['c] is the result type for the "printf"-style function, - and ['b] is the type of the first argument given to - [%a] and [%t] printing functions. *) + ['b] is the type of the first argument given to + [%a] and [%t] printing functions, + ['c] is the type of the argument transmitted to the first argument of + "kprintf"-style functions, + ['d] is the result type for the "scanf"-style functions, + ['e] is the type of the receiver function for the "scanf"-style functions, + ['f] is the result type for the "printf"-style function. + *) type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 diff --git a/stdlib/printf.ml b/stdlib/printf.ml index 11cf3cdf9..dc88335f6 100644 --- a/stdlib/printf.ml +++ b/stdlib/printf.ml @@ -106,6 +106,7 @@ let pad_string pad_char p neg s i len = then String.blit s i res 0 len else String.blit s i res (p - len) len; res +;; (* Format a string given a %s format, e.g. %40s or %-20s. To do ?: ignore other flags (#, +, etc). *) @@ -196,7 +197,8 @@ let sub_format incomplete_format bad_conversion_format conv fmt i = ;; let sub_format_for_printf conv = - sub_format incomplete_format bad_conversion_format conv;; + sub_format incomplete_format bad_conversion_format conv +;; let iter_on_format_args fmt add_conv add_char = @@ -307,7 +309,7 @@ let ac_of_format fmt = let count_arguments_of_format fmt = let ac = ac_of_format fmt in - (* For printing only regular arguments have to be counted. *) + (* For printing, only the regular arguments have to be counted. *) ac.ac_rglr ;; @@ -376,7 +378,7 @@ type positional_specification = Note that this is optimized for the regular case, i.e. no positional parameter, since in this case we juste ``return'' the constant [Spec_none]; in case we have a positional parameter, we ``return'' a - [Spec_index] [positional_specification] which a bit more costly. + [Spec_index] [positional_specification] which is a bit more costly. Note also that we do not support [*$] specifications, since this would lead to type checking problems: a [*$] positional specification means @@ -663,9 +665,13 @@ let ksprintf k = mkprintf true get_buff Buffer.add_char Buffer.add_string ignore (get_cont k) ;; +let sprintf fmt = ksprintf (fun s -> s) fmt;; + +(* Obsolete and deprecated. *) let kprintf = ksprintf;; -let sprintf fmt = ksprintf (fun s -> s) fmt;; +(* For Caml system internal use only: needed to implement modules [Format] + and [Scanf]. *) module CamlinternalPr = struct diff --git a/stdlib/printf.mli b/stdlib/printf.mli index 35d390a5f..e122decec 100644 --- a/stdlib/printf.mli +++ b/stdlib/printf.mli @@ -75,7 +75,7 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a - [( 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]. + type as the internal format string [fmt]. - [!]: take no argument and flush the output. - [%]: take no argument and output one [%] character. - [,]: the no-op delimiter for conversion specifications. @@ -146,12 +146,14 @@ val kbprintf : (Buffer.t -> 'a) -> Buffer.t -> @since 3.10.0 *) +(** Deprecated *) + val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; (** A deprecated synonym for [ksprintf]. *) (**/**) -(* For system use only. Don't call directly. *) +(* For Caml system internal use only. Don't call directly. *) module CamlinternalPr : sig diff --git a/stdlib/string.ml b/stdlib/string.ml index e61e9efe9..72f9494cc 100644 --- a/stdlib/string.ml +++ b/stdlib/string.ml @@ -183,4 +183,4 @@ let rcontains_from s i c = type t = string -let compare = Pervasives.compare +let compare (x: t) (y: t) = Pervasives.compare x y diff --git a/stdlib/sys.mli b/stdlib/sys.mli index e1cf99aaf..713038aa7 100644 --- a/stdlib/sys.mli +++ b/stdlib/sys.mli @@ -31,7 +31,7 @@ external is_directory : string -> bool = "caml_sys_is_directory" (** Returns [true] if the given name refers to a directory, [false] if it refers to another kind of file. Raise [Sys_error] if no file exists with the given name. - @since 3.12.0 + @since 3.10.0 *) external remove : string -> unit = "caml_sys_remove" diff --git a/test/.cvsignore b/test/.cvsignore deleted file mode 100644 index 66d34d733..000000000 --- a/test/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -*.byt -*.out diff --git a/test/.depend b/test/.depend deleted file mode 100644 index ac5de61e8..000000000 --- a/test/.depend +++ /dev/null @@ -1,28 +0,0 @@ -KB/equations.cmi: KB/terms.cmi -KB/kb.cmi: KB/equations.cmi KB/terms.cmi -KB/orderings.cmi: KB/terms.cmi -KB/equations.cmo: KB/equations.cmi KB/terms.cmi -KB/equations.cmx: KB/equations.cmi KB/terms.cmx -KB/kb.cmo: KB/kb.cmi KB/equations.cmi KB/terms.cmi -KB/kb.cmx: KB/kb.cmi KB/equations.cmx KB/terms.cmx -KB/kbmain.cmo: KB/kb.cmi KB/orderings.cmi KB/equations.cmi KB/terms.cmi -KB/kbmain.cmx: KB/kb.cmx KB/orderings.cmx KB/equations.cmx KB/terms.cmx -KB/orderings.cmo: KB/orderings.cmi KB/terms.cmi -KB/orderings.cmx: KB/orderings.cmi KB/terms.cmx -KB/terms.cmo: KB/terms.cmi -KB/terms.cmx: KB/terms.cmi -Lex/grammar.cmi: Lex/syntax.cmo -Lex/gram_aux.cmo: Lex/syntax.cmo -Lex/gram_aux.cmx: Lex/syntax.cmx -Lex/grammar.cmo: Lex/grammar.cmi Lex/gram_aux.cmo Lex/syntax.cmo -Lex/grammar.cmx: Lex/grammar.cmi Lex/gram_aux.cmx Lex/syntax.cmx -Lex/lexgen.cmo: Lex/syntax.cmo -Lex/lexgen.cmx: Lex/syntax.cmx -Lex/main.cmo: Lex/lexgen.cmo Lex/output.cmo Lex/grammar.cmi \ - Lex/scanner.cmo Lex/syntax.cmo Lex/scan_aux.cmo -Lex/main.cmx: Lex/lexgen.cmx Lex/output.cmx Lex/grammar.cmx \ - Lex/scanner.cmx Lex/syntax.cmx Lex/scan_aux.cmx -Lex/output.cmo: Lex/syntax.cmo -Lex/output.cmx: Lex/syntax.cmx -Lex/scanner.cmo: Lex/syntax.cmo Lex/scan_aux.cmo Lex/grammar.cmi -Lex/scanner.cmx: Lex/syntax.cmx Lex/scan_aux.cmx Lex/grammar.cmx diff --git a/test/test_bng.c b/test/test_bng.c deleted file mode 100644 index 2d6a6e808..000000000 --- a/test/test_bng.c +++ /dev/null @@ -1,408 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, 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: test_bng.c 5900 2003-11-07 07:59:10Z xleroy $ */ - -/* Test harness for the BNG primitives. Use BigNum as a reference. */ - -#include -#include -#include - -#include - -#include "../../../config/m.h" -#include "bng.h" - -#if defined(__GNUC__) && BNG_ASM_LEVEL > 0 -#if defined(BNG_ARCH_ia32) -#include "bng_ia32.c" -#elif defined(BNG_ARCH_amd64) -#include "bng_amd64.c" -#elif defined(BNG_ARCH_ppc) -#include "bng_ppc.c" -#elif defined (BNG_ARCH_alpha) -#include "bng_alpha.c" -#elif defined (BNG_ARCH_sparc) -#include "bng_sparc.c" -#elif defined (BNG_ARCH_mips) -#include "bng_mips.c" -#endif -#endif - -#include "bng_digit.c" - -/* Random generator for digits. Can either generate "true" PRN numbers - or numbers consisting of long sequences of 0 and 1 bits. */ - -static int rand_skewed = 0; -static int rand_runlength = 0; -static int rand_bit = 0; -static bngdigit rand_seed = 0; - -static bngdigit randdigit(void) -{ - bngdigit res; - int i; - - if (rand_skewed) { - for (i = 0, res = 0; i < BNG_BITS_PER_DIGIT; i++) { - if (rand_runlength == 0) { - rand_runlength = 1 + (rand() % (2 * BNG_BITS_PER_DIGIT)); - rand_bit ^= 1; - } - res = (res << 1) | rand_bit; - rand_runlength--; - } - return res; - } else { - rand_seed = rand_seed * 69069 + 25173; - return rand_seed; - } -} - -/* Test the operations on digits. - This uses double-width integer arithmetic as reference. - This is only available on 32-bit platforms that support a 64-bit int type. -*/ - -#if defined(ARCH_UINT64_TYPE) && !defined(ARCH_SIXTYFOUR) - -typedef ARCH_UINT64_TYPE dbldigit; - -static int test_digit_ops(int i) -{ - bngdigit a1, a2, a3, r1, r2; - int ci, co, n; - - a1 = randdigit(); - a2 = randdigit(); - a3 = randdigit(); - ci = randdigit() & 1; - - BngAdd2(r1,co,a1,a2); - if ((dbldigit) r1 + ((dbldigit) co << BNG_BITS_PER_DIGIT) - != (dbldigit) a1 + (dbldigit) a2) { - printf("Round %d, BngAdd2(%lx,%x,%lx, %lx)\n", i, r1, co, a1, a2); - return 1; - } - - BngAdd2Carry(r1,co,a1,a2,ci); - if ((dbldigit) r1 + ((dbldigit) co << BNG_BITS_PER_DIGIT) - != (dbldigit) a1 + (dbldigit) a2 + (dbldigit) ci) { - printf("Round %d, BngAdd2Carry(%lx,%x,%lx, %lx, %x)\n", i, r1, co, a1, a2, ci); - return 1; - } - - r2 = 0; - BngAdd3(r1,r2,a1,a2,a3); - if ((dbldigit) r1 + ((dbldigit) r2 << BNG_BITS_PER_DIGIT) - != (dbldigit) a1 + (dbldigit) a2 + (dbldigit) a3) { - printf("Round %d, BngAdd3(%lx,%x,%lx, %lx, %lx)\n", i, r1, co, a1, a2, a3); - return 1; - } - - BngSub2(r1,co,a1,a2); - if ((dbldigit) r1 - ((dbldigit) co << BNG_BITS_PER_DIGIT) - != (dbldigit) a1 - (dbldigit) a2) { - printf("Round %d, BngSub2(%lx,%x,%lx, %lx)\n", i, r1, co, a1, a2); - return 1; - } - - BngSub2Carry(r1,co,a1,a2,ci); - if ((dbldigit) r1 - ((dbldigit) co << BNG_BITS_PER_DIGIT) - != (dbldigit) a1 - (dbldigit) a2 - (dbldigit) ci) { - printf("Round %d, BngSub2Carry(%lx,%x,%lx, %lx, %x)\n", i, r1, co, a1, a2, ci); - return 1; - } - - r2 = 0; - BngSub3(r1,r2,a1,a2,a3); - if ((dbldigit) r1 - ((dbldigit) r2 << BNG_BITS_PER_DIGIT) - != (dbldigit) a1 - (dbldigit) a2 - (dbldigit) a3) { - printf("Round %d, BngSub3(%lx,%x,%lx, %lx, %lx)\n", i, r1, co, a1, a2, a3); - return 1; - } - - BngMult(r1,r2,a1,a2); - if ((((dbldigit) r1 << BNG_BITS_PER_DIGIT) | (dbldigit) r2) - != (dbldigit) a1 * (dbldigit) a2) { - printf("Round %d, BngMult(%lx,%lx,%lx, %lx)\n", i, r1, r2, a1, a2); - return 1; - } - - /* Make sure a3 is normalized */ - a3 |= 1L << (BNG_BITS_PER_DIGIT - 1); - if (a1 < a3) { - BngDiv(r1,r2,a1,a2,a3); - if (r1 != (((dbldigit) a1 << BNG_BITS_PER_DIGIT) | (dbldigit) a2) / a3 - || - r2 != (((dbldigit) a1 << BNG_BITS_PER_DIGIT) | (dbldigit) a2) % a3) - { - printf("Round %d, BngDiv(%lx,%lx,%lx, %lx, %lx)\n", i, r1, r2, a1, a2, a3); - return 1; - } - } - - n = bng_leading_zero_bits(a1); - if (a1 == 0) { - if (n != BNG_BITS_PER_DIGIT) { - printf("Round %d, bng_leading_zero(bits(%lx) = %d", i, a1, n); - return 1; - } - } else { - if ((a1 << n) >> n != a1 || - ((a1 << n) & (1L << (BNG_BITS_PER_DIGIT - 1))) == 0) { - printf("Round %d, bng_leading_zero(bits(%lx) = %d", i, a1, n); - return 1; - } - } - return 0; -} - -#endif - -/* Test the bng operations. Use BigNum as a reference. */ - -#define MAX_DIGITS 32 - -void randbng(bng a, bngsize n) -{ - int i; - for (i = 0; i < n; i++) a[i] = randdigit(); -} - -char * bng2string(bng a, bngsize n) -{ - char * buffer = malloc((BNG_BITS_PER_DIGIT / 4 + 1) * MAX_DIGITS); - char temp[BNG_BITS_PER_DIGIT / 4 + 1]; - int i; - - buffer[0] = 0; - for (i = n - 1; i >= 0; i--) { - sprintf(temp, "%lx", a[i]); - strcat(buffer, temp); - if (i > 0) strcat(buffer, "_"); - } - return buffer; -} - -int bngsame(bng a, bng b, bngsize n) -{ - int i; - for (i = 0; i < n; i++) - if (a[i] != b[i]) return 0; - return 1; -} - -int test_bng_ops(int i) -{ - bngsize p, q; - bngdigit a[MAX_DIGITS], b[MAX_DIGITS], c[MAX_DIGITS], d[MAX_DIGITS]; - bngdigit f[2 * MAX_DIGITS], g[2 * MAX_DIGITS], h[2 * MAX_DIGITS]; - bngcarry ci, co, cp; - bngdigit dg, do_, dp; - int amount; - - /* Determine random lengths p and q between 1 and MAX_DIGITS. - Ensure p >= q. */ - p = 1 + (rand() % MAX_DIGITS); - q = 1 + (rand() % MAX_DIGITS); - if (q > p) { bngsize t = p; p = q; q = t; } - - /* Randomly generate bignums a of size p, b of size q */ - randbng(a, p); - randbng(b, q); - ci = rand() & 1; - - /* comparison */ - co = bng_compare(a, p, b, q); - cp = BnnCompare(a, p, b, q); - if (co != cp) { - printf("Round %d, bng_compare(%s, %ld, %s, %ld) = %d\n", - i, bng2string(a, p), p, bng2string(b, q), q, co); - return 1; - } - co = bng_compare(b, q, a, p); - cp = BnnCompare(b, q, a, p); - if (co != cp) { - printf("Round %d, bng_compare(%s, %ld, %s, %ld) = %d\n", - i, bng2string(b, q), q, bng2string(a, p), p, co); - return 1; - } - /* add carry */ - bng_assign(c, a, p); - co = bng_add_carry(c, p, ci); - BnnAssign(d, a, p); - cp = BnnAddCarry(d, p, ci); - if (co != cp || !bngsame(c, d, p)) { - printf("Round %d, bng_add_carry(%s, %ld, %d) -> %s, %d\n", - i, bng2string(a, p), p, ci, bng2string(c, p), co); - return 1; - } - /* add */ - bng_assign(c, a, p); - co = bng_add(c, p, b, q, ci); - BnnAssign(d, a, p); - cp = BnnAdd(d, p, b, q, ci); - if (co != cp || !bngsame(c, d, p)) { - printf("Round %d, bng_add(%s, %ld, %s, %ld, %d) -> %s, %d\n", - i, bng2string(a, p), p, bng2string(b, q), q, ci, - bng2string(c, p), co); - return 1; - } - /* sub carry */ - bng_assign(c, a, p); - co = bng_sub_carry(c, p, ci); - BnnAssign(d, a, p); - cp = BnnSubtractBorrow(d, p, ci ^ 1) ^ 1; - if (co != cp || !bngsame(c, d, p)) { - printf("Round %d, bng_sub_carry(%s, %ld, %d) -> %s, %d\n", - i, bng2string(a, p), p, ci, bng2string(c, p), co); - return 1; - } - /* sub */ - bng_assign(c, a, p); - co = bng_sub(c, p, b, q, ci); - BnnAssign(d, a, p); - cp = BnnSubtract(d, p, b, q, ci ^ 1) ^ 1; - if (co != cp || !bngsame(c, d, p)) { - printf("Round %d, bng_sub(%s, %ld, %s, %ld, %d) -> %s, %d\n", - i, bng2string(a, p), p, bng2string(b, q), q, ci, - bng2string(c, p), co); - return 1; - } - /* shift left */ - amount = rand() % BNG_BITS_PER_DIGIT; - bng_assign(c, a, p); - do_ = bng_shift_left(c, p, amount); - BnnAssign(d, a, p); - dp = BnnShiftLeft(d, p, amount); - if (do_ != dp || !bngsame(c, d, p)) { - printf("Round %d, bng_shift_left(%s, %ld, %d) -> %s, %ld\n", - i, bng2string(a, p), p, amount, bng2string(c, p), do_); - return 1; - } - /* shift right */ - amount = rand() % BNG_BITS_PER_DIGIT; - bng_assign(c, a, p); - do_ = bng_shift_right(c, p, amount); - BnnAssign(d, a, p); - dp = BnnShiftRight(d, p, amount); - if (do_ != dp || !bngsame(c, d, p)) { - printf("Round %d, bng_shift_right(%s, %ld, %d) -> %s, %ld\n", - i, bng2string(a, p), p, amount, bng2string(c, p), do_); - return 1; - } - /* mult_add_digit */ - dg = randdigit(); - if (p >= q + 1) { - bng_assign(c, a, p); - co = bng_mult_add_digit(c, p, b, q, dg); - BnnAssign(d, a, p); - cp = BnnMultiplyDigit(d, p, b, q, dg); - if (co != cp || !bngsame(c, d, p)) { - printf("Round %d, bng_mult_add_digit(%s, %ld, %s, %ld, %ld) -> %s, %d\n", - i, bng2string(a, p), p, bng2string(b, q), q, dg, - bng2string(c, p), co); - return 1; - } - } - /* mult_sub_digit */ - dg = randdigit(); - bng_assign(c, a, p); - do_ = bng_mult_add_digit(c, p, b, q, dg); - bng_assign(d, c, p); - dp = bng_mult_sub_digit(d, p, b, q, dg); - if (do_ != dp || !bngsame(a, d, p)) { - printf("Round %d, bng_mult_sub_digit(%s, %ld, %s, %ld, %ld) -> %s, %ld\n", - i, bng2string(c, p), p, bng2string(b, q), q, dg, - bng2string(d, p), dp); - return 1; - } - /* mult_add */ - randbng(f, 2*p); - bng_assign(g, f, 2*p); - co = bng_mult_add(g, 2*p, a, p, b, q); - BnnAssign(h, f, 2*p); - cp = BnnMultiply(h, 2*p, a, p, b, q); - if (co != cp || !bngsame(g, h, 2*p)) { - printf("Round %d, bng_mult_add(%s, %ld, %s, %ld, %s, %ld) -> %s, %d\n", - i, bng2string(f, 2*p), 2*p, - bng2string(a, p), p, - bng2string(b, q), q, - bng2string(g, 2*p), co); - return 1; - } - /* square_add */ - randbng(f, 2*p); - bng_assign(g, f, 2*p); - co = bng_square_add(g, 2*p, b, q); - BnnAssign(h, f, 2*p); - cp = BnnAdd(h, 2*p, h, 2*p); - cp += BnnMultiply(h, 2*p, b, q, b, q); - if (co != cp || !bngsame(g, h, 2*p)) { - printf("Round %d, bng_square_add(%s, %ld, %s, %ld) -> %s, %d\n", - i, bng2string(f, 2*p), 2*p, - bng2string(b, q), q, - bng2string(g, 2*p), co); - return 1; - } - /* div_rem_digit */ - if (a[p - 1] < dg) { - do_ = bng_div_rem_digit(c, a, p, dg); - dp = BnnDivideDigit(d, a, p, dg); - if (do_ != dp || !bngsame(c, d, p-1)) { - printf("Round %d, bng_div_rem_digit(%s, %s, %ld, %lx) -> %lx\n", - i, bng2string(d, p-1), bng2string(a, p), p, dg, do_); - return 1; - } - } - /* div_rem */ - if (p > q && a[p - 1] < b[q - 1]) { - bng_assign(c, a, p); - bng_div_rem(c, p, b, q); - BnnAssign(d, a, p); - BnnDivide(d, p, b, q); - if (!bngsame(c, d, p)) { - printf("Round %d, bng_div_rem(%s, %ld, %s, %ld) -> %s, %s\n", - i, bng2string(a, p), p, bng2string(b, q), q, - bng2string(c + q, p - q), - bng2string(c, q)); - return 1; - } - } - return 0; -} - -int main(int argc, char ** argv) -{ - int niter = 100000; - int i, err; - - bng_init(); - if (argc >= 2) niter = atoi(argv[1]); -#if defined(ARCH_UINT64_TYPE) && !defined(ARCH_SIXTYFOUR) - printf("Testing single-digit operations\n"); - for (err = 0, i = 1; i < niter; i++) err += test_digit_ops(i); - printf("%d rounds performed, %d errors found\n", niter, err); -#endif - printf("Testing bignum operations\n"); - for (err = 0, i = 1; i < niter; i++) err += test_bng_ops(i); - printf("%d rounds performed, %d errors found\n", niter, err); - printf("Testing bignum operations with skewed PRNG\n"); - rand_skewed = 1; - for (err = 0, i = 1; i < niter; i++) err += test_bng_ops(i); - printf("%d rounds performed, %d errors found\n", niter, err); - return 0; -} diff --git a/testlabl/sigsubst.ml b/testlabl/sigsubst.ml index ffddfdfc4..9b6c957b2 100644 --- a/testlabl/sigsubst.ml +++ b/testlabl/sigsubst.ml @@ -6,15 +6,20 @@ module type Comparable = sig type t val compare : t -> t -> int end +module type PrintableComparable = sig + include Printable + include Comparable with type t = t +end module type PrintableComparable = sig type t include Printable with type t := t include Comparable with type t := t end -module type PrintableComparable2 = sig +module type PrintableComparable = sig include Printable include Comparable with type t := t end +module type ComparableInt = Comparable with type t := int module type S = sig type t val f : t -> t end module type S' = S with type t := int diff --git a/testsuite/interactive/lib-gc/alloc.ml b/testsuite/interactive/lib-gc/alloc.ml index 4f607fb23..ea103e42a 100644 --- a/testsuite/interactive/lib-gc/alloc.ml +++ b/testsuite/interactive/lib-gc/alloc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: alloc.ml 2553 1999-11-17 18:59:06Z xleroy $ *) +(* $Id$ *) (* Random allocation test *) diff --git a/testsuite/lib/testing.ml b/testsuite/lib/testing.ml index 55da6f6d9..2015aa147 100644 --- a/testsuite/lib/testing.ml +++ b/testsuite/lib/testing.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: testing.ml,v 1.1 2006/01/12 12:52:14 weis Exp $ *) +(* $Id$ *) (* Testing auxilliaries. *) diff --git a/testsuite/lib/testing.mli b/testsuite/lib/testing.mli index c3880f08c..6f47d2a3e 100644 --- a/testsuite/lib/testing.mli +++ b/testsuite/lib/testing.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: testing.mli,v 1.1 2006/01/12 12:52:14 weis Exp $ *) +(* $Id$ *) (* Testing auxilliaries. *) diff --git a/testsuite/makefiles/Makefile.several b/testsuite/makefiles/Makefile.several index 327e70997..a2266b7ac 100644 --- a/testsuite/makefiles/Makefile.several +++ b/testsuite/makefiles/Makefile.several @@ -37,7 +37,7 @@ run-all: run-file: @printf " $(DESC)" - @$(COMP) $(COMPFLAGS) $(FILE) -o program + $(COMP) $(COMPFLAGS) $(FILE) -o program @if [ -f `basename $(FILE) ml`runner ]; then \ sh `basename $(FILE) ml`runner; \ else \ diff --git a/testsuite/tests/asmcomp/alpha.S b/testsuite/tests/asmcomp/alpha.S index 66bf73f28..d8851065c 100644 --- a/testsuite/tests/asmcomp/alpha.S +++ b/testsuite/tests/asmcomp/alpha.S @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: alpha.S 2638 1999-11-29 19:04:56Z doligez $ */ +/* $Id$ */ .globl call_gen_code .ent call_gen_code diff --git a/testsuite/tests/asmcomp/amd64.S b/testsuite/tests/asmcomp/amd64.S index bb2dc2b0b..8df6e2d20 100644 --- a/testsuite/tests/asmcomp/amd64.S +++ b/testsuite/tests/asmcomp/amd64.S @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: amd64.S 5634 2003-06-30 08:28:48Z xleroy $ */ +/* $Id$ */ #ifdef SYS_macosx #define ALIGN 4 diff --git a/testsuite/tests/asmcomp/arith.cmm b/testsuite/tests/asmcomp/arith.cmm index 77257c3cc..f4efefdbe 100644 --- a/testsuite/tests/asmcomp/arith.cmm +++ b/testsuite/tests/asmcomp/arith.cmm @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: arith.cmm 3218 2000-06-29 11:45:24Z xleroy $ *) +(* $Id$ *) (* Regression test for arithmetic instructions *) diff --git a/testsuite/tests/asmcomp/arm.S b/testsuite/tests/asmcomp/arm.S index 069709518..186d70614 100644 --- a/testsuite/tests/asmcomp/arm.S +++ b/testsuite/tests/asmcomp/arm.S @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: arm.S 9212 2009-03-31 09:46:08Z xleroy $ */ +/* $Id$ */ .text diff --git a/testsuite/tests/asmcomp/checkbound.cmm b/testsuite/tests/asmcomp/checkbound.cmm index a1277c95a..995b74f8a 100644 --- a/testsuite/tests/asmcomp/checkbound.cmm +++ b/testsuite/tests/asmcomp/checkbound.cmm @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: checkbound.cmm 2553 1999-11-17 18:59:06Z xleroy $ *) +(* $Id$ *) (function "checkbound2" (x: int y: int) (checkbound x y)) diff --git a/testsuite/tests/asmcomp/fib.cmm b/testsuite/tests/asmcomp/fib.cmm index e71a90273..b7e64d302 100644 --- a/testsuite/tests/asmcomp/fib.cmm +++ b/testsuite/tests/asmcomp/fib.cmm @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: fib.cmm 2553 1999-11-17 18:59:06Z xleroy $ *) +(* $Id$ *) (function "fib" (n: int) (if (< n 2) diff --git a/testsuite/tests/asmcomp/hppa.S b/testsuite/tests/asmcomp/hppa.S index 31fff9dfa..2b1ab21c6 100644 --- a/testsuite/tests/asmcomp/hppa.S +++ b/testsuite/tests/asmcomp/hppa.S @@ -10,7 +10,7 @@ ;* * ;********************************************************************* -; $Id: hppa.S 2553 1999-11-17 18:59:06Z xleroy $ +; $Id$ ; Must be preprocessed by cpp #ifdef SYS_hpux diff --git a/testsuite/tests/asmcomp/i386.S b/testsuite/tests/asmcomp/i386.S index 079eca179..f4b65e57a 100644 --- a/testsuite/tests/asmcomp/i386.S +++ b/testsuite/tests/asmcomp/i386.S @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: i386.S 2553 1999-11-17 18:59:06Z xleroy $ */ +/* $Id$ */ /* Linux with ELF binaries does not prefix identifiers with _. Linux with a.out binaries, FreeBSD, and NextStep do. */ diff --git a/testsuite/tests/asmcomp/i386nt.asm b/testsuite/tests/asmcomp/i386nt.asm index 0ad524756..66550eb8b 100644 --- a/testsuite/tests/asmcomp/i386nt.asm +++ b/testsuite/tests/asmcomp/i386nt.asm @@ -10,7 +10,7 @@ ; ;********************************************************************* -; $Id: i386nt.asm 2553 1999-11-17 18:59:06Z xleroy $ +; $Id$ .386 .MODEL FLAT diff --git a/testsuite/tests/asmcomp/ia64.S b/testsuite/tests/asmcomp/ia64.S index 49de1b194..51361690b 100644 --- a/testsuite/tests/asmcomp/ia64.S +++ b/testsuite/tests/asmcomp/ia64.S @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: ia64.S 3573 2001-07-12 12:54:24Z doligez $ */ +/* $Id$ */ #define ST8OFF(a,b,d) st8 [a] = b, d #define LD8OFF(a,b,d) ld8 a = [b], d diff --git a/testsuite/tests/asmcomp/integr.cmm b/testsuite/tests/asmcomp/integr.cmm index 84a01d465..481dd7587 100644 --- a/testsuite/tests/asmcomp/integr.cmm +++ b/testsuite/tests/asmcomp/integr.cmm @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: integr.cmm 3218 2000-06-29 11:45:24Z xleroy $ *) +(* $Id$ *) (function "square" (x: float) ( *f x x)) diff --git a/testsuite/tests/asmcomp/lexcmm.mli b/testsuite/tests/asmcomp/lexcmm.mli index 9ebc36b56..a28a57c52 100644 --- a/testsuite/tests/asmcomp/lexcmm.mli +++ b/testsuite/tests/asmcomp/lexcmm.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: lexcmm.mli 2553 1999-11-17 18:59:06Z xleroy $ *) +(* $Id$ *) val token: Lexing.lexbuf -> Parsecmm.token diff --git a/testsuite/tests/asmcomp/lexcmm.mll b/testsuite/tests/asmcomp/lexcmm.mll index a9d17dd3d..0e8432e1c 100644 --- a/testsuite/tests/asmcomp/lexcmm.mll +++ b/testsuite/tests/asmcomp/lexcmm.mll @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: lexcmm.mll 3211 2000-06-25 19:54:50Z xleroy $ *) +(* $Id$ *) { open Parsecmm diff --git a/testsuite/tests/asmcomp/m68k.S b/testsuite/tests/asmcomp/m68k.S index 8905da1bb..436e65e69 100644 --- a/testsuite/tests/asmcomp/m68k.S +++ b/testsuite/tests/asmcomp/m68k.S @@ -10,7 +10,7 @@ |* * |*********************************************************************** -| $Id: m68k.S 2553 1999-11-17 18:59:06Z xleroy $ +| $Id$ | call_gen_code is used with the following types: | unit -> int diff --git a/testsuite/tests/asmcomp/main.c b/testsuite/tests/asmcomp/main.c index 7f0e7174f..e45c8c27c 100644 --- a/testsuite/tests/asmcomp/main.c +++ b/testsuite/tests/asmcomp/main.c @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: main.c 9212 2009-03-31 09:46:08Z xleroy $ */ +/* $Id$ */ #include #include diff --git a/testsuite/tests/asmcomp/main.ml b/testsuite/tests/asmcomp/main.ml index 7017c35dc..d6207102a 100644 --- a/testsuite/tests/asmcomp/main.ml +++ b/testsuite/tests/asmcomp/main.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: main.ml 3229 2000-07-07 14:09:23Z xleroy $ *) +(* $Id$ *) open Clflags diff --git a/testsuite/tests/asmcomp/mainarith.c b/testsuite/tests/asmcomp/mainarith.c index efa48ba0e..95a923d8b 100644 --- a/testsuite/tests/asmcomp/mainarith.c +++ b/testsuite/tests/asmcomp/mainarith.c @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: mainarith.c 9212 2009-03-31 09:46:08Z xleroy $ */ +/* $Id$ */ #include #include diff --git a/testsuite/tests/asmcomp/mips.s b/testsuite/tests/asmcomp/mips.s index d8e93565a..9fe9f94b6 100644 --- a/testsuite/tests/asmcomp/mips.s +++ b/testsuite/tests/asmcomp/mips.s @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: mips.s 2638 1999-11-29 19:04:56Z doligez $ */ +/* $Id$ */ .globl call_gen_code .ent call_gen_code diff --git a/testsuite/tests/asmcomp/parsecmm.mly b/testsuite/tests/asmcomp/parsecmm.mly index 6ed2f8ff5..79b278b05 100644 --- a/testsuite/tests/asmcomp/parsecmm.mly +++ b/testsuite/tests/asmcomp/parsecmm.mly @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: parsecmm.mly 9212 2009-03-31 09:46:08Z xleroy $ */ +/* $Id$ */ /* A simple parser for C-- */ diff --git a/testsuite/tests/asmcomp/parsecmmaux.ml b/testsuite/tests/asmcomp/parsecmmaux.ml index a87432e4e..8c46888c6 100644 --- a/testsuite/tests/asmcomp/parsecmmaux.ml +++ b/testsuite/tests/asmcomp/parsecmmaux.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: parsecmmaux.ml 2553 1999-11-17 18:59:06Z xleroy $ *) +(* $Id$ *) (* Auxiliary functions for parsing *) diff --git a/testsuite/tests/asmcomp/parsecmmaux.mli b/testsuite/tests/asmcomp/parsecmmaux.mli index 941ebcb48..558996552 100644 --- a/testsuite/tests/asmcomp/parsecmmaux.mli +++ b/testsuite/tests/asmcomp/parsecmmaux.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: parsecmmaux.mli 2553 1999-11-17 18:59:06Z xleroy $ *) +(* $Id$ *) (* Auxiliary functions for parsing *) diff --git a/testsuite/tests/asmcomp/power-aix.S b/testsuite/tests/asmcomp/power-aix.S index ea1530830..96ed2b92d 100644 --- a/testsuite/tests/asmcomp/power-aix.S +++ b/testsuite/tests/asmcomp/power-aix.S @@ -10,7 +10,7 @@ #* * #********************************************************************* -# $Id: power-aix.S 3042 2000-04-05 18:30:22Z doligez $ +# $Id$ .csect .text[PR] diff --git a/testsuite/tests/asmcomp/power-elf.S b/testsuite/tests/asmcomp/power-elf.S index c7ddeef76..994a9fa7b 100644 --- a/testsuite/tests/asmcomp/power-elf.S +++ b/testsuite/tests/asmcomp/power-elf.S @@ -10,7 +10,7 @@ /* */ /*********************************************************************/ -/* $Id: power-elf.S 2553 1999-11-17 18:59:06Z xleroy $ */ +/* $Id$ */ /* Save and restore all callee-save registers */ /* GPR 14 at sp+16 ... GPR 31 at sp+84 diff --git a/testsuite/tests/asmcomp/power-rhapsody.S b/testsuite/tests/asmcomp/power-rhapsody.S index a9b8044b8..b45610586 100644 --- a/testsuite/tests/asmcomp/power-rhapsody.S +++ b/testsuite/tests/asmcomp/power-rhapsody.S @@ -10,7 +10,7 @@ /* */ /*********************************************************************/ -/* $Id: power-rhapsody.S 2553 1999-11-17 18:59:06Z xleroy $ */ +/* $Id$ */ /* Save and restore all callee-save registers */ /* GPR 14 at sp+16 ... GPR 31 at sp+84 diff --git a/testsuite/tests/asmcomp/quicksort.cmm b/testsuite/tests/asmcomp/quicksort.cmm index 043e607f8..4029da8d1 100644 --- a/testsuite/tests/asmcomp/quicksort.cmm +++ b/testsuite/tests/asmcomp/quicksort.cmm @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: quicksort.cmm 3211 2000-06-25 19:54:50Z xleroy $ *) +(* $Id$ *) (function "quicksort" (lo: int hi: int a: addr) (if (< lo hi) diff --git a/testsuite/tests/asmcomp/quicksort2.cmm b/testsuite/tests/asmcomp/quicksort2.cmm index 4d80cd58a..eae9809a7 100644 --- a/testsuite/tests/asmcomp/quicksort2.cmm +++ b/testsuite/tests/asmcomp/quicksort2.cmm @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: quicksort2.cmm 3218 2000-06-29 11:45:24Z xleroy $ *) +(* $Id$ *) (function "cmp" (i: int j: int) (- i j)) diff --git a/testsuite/tests/asmcomp/soli.cmm b/testsuite/tests/asmcomp/soli.cmm index 4716e4f21..47ce64c0b 100644 --- a/testsuite/tests/asmcomp/soli.cmm +++ b/testsuite/tests/asmcomp/soli.cmm @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: soli.cmm 5634 2003-06-30 08:28:48Z xleroy $ *) +(* $Id$ *) ("d1": int 0 int 1 "d2": int 1 int 0 diff --git a/testsuite/tests/asmcomp/sparc.S b/testsuite/tests/asmcomp/sparc.S index 54d81c1cc..9a829e173 100644 --- a/testsuite/tests/asmcomp/sparc.S +++ b/testsuite/tests/asmcomp/sparc.S @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: sparc.S 2553 1999-11-17 18:59:06Z xleroy $ */ +/* $Id$ */ #ifndef SYS_solaris #define Call_gen_code _call_gen_code diff --git a/testsuite/tests/asmcomp/tagged-fib.cmm b/testsuite/tests/asmcomp/tagged-fib.cmm index 04869792c..e5e45b0fb 100644 --- a/testsuite/tests/asmcomp/tagged-fib.cmm +++ b/testsuite/tests/asmcomp/tagged-fib.cmm @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: tagged-fib.cmm 2553 1999-11-17 18:59:06Z xleroy $ *) +(* $Id$ *) (function "fib" (n: int) (if (< n 5) diff --git a/testsuite/tests/asmcomp/tagged-integr.cmm b/testsuite/tests/asmcomp/tagged-integr.cmm index 054c78d7f..df46813eb 100644 --- a/testsuite/tests/asmcomp/tagged-integr.cmm +++ b/testsuite/tests/asmcomp/tagged-integr.cmm @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: tagged-integr.cmm 3229 2000-07-07 14:09:23Z xleroy $ *) +(* $Id$ *) ("res_square": skip 8) ("h": skip 8) diff --git a/testsuite/tests/asmcomp/tagged-quicksort.cmm b/testsuite/tests/asmcomp/tagged-quicksort.cmm index 6b74753e8..b519e5cef 100644 --- a/testsuite/tests/asmcomp/tagged-quicksort.cmm +++ b/testsuite/tests/asmcomp/tagged-quicksort.cmm @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: tagged-quicksort.cmm 3218 2000-06-29 11:45:24Z xleroy $ *) +(* $Id$ *) (function "quick" (lo: int hi: int a: addr) (if (< lo hi) diff --git a/testsuite/tests/asmcomp/tagged-tak.cmm b/testsuite/tests/asmcomp/tagged-tak.cmm index 5e04b7394..fe9e6eb02 100644 --- a/testsuite/tests/asmcomp/tagged-tak.cmm +++ b/testsuite/tests/asmcomp/tagged-tak.cmm @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: tagged-tak.cmm 3229 2000-07-07 14:09:23Z xleroy $ *) +(* $Id$ *) (function "tak" (x:int y:int z:int) (if (> x y) diff --git a/testsuite/tests/asmcomp/tak.cmm b/testsuite/tests/asmcomp/tak.cmm index de236fc8b..cd61ec89b 100644 --- a/testsuite/tests/asmcomp/tak.cmm +++ b/testsuite/tests/asmcomp/tak.cmm @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: tak.cmm 3211 2000-06-25 19:54:50Z xleroy $ *) +(* $Id$ *) (function "tak" (x:int y:int z:int) (if (> x y) diff --git a/testsuite/tests/basic-more/tformat.ml b/testsuite/tests/basic-more/tformat.ml index afad52970..d02cb2907 100644 --- a/testsuite/tests/basic-more/tformat.ml +++ b/testsuite/tests/basic-more/tformat.ml @@ -10,7 +10,7 @@ (* *) (*************************************************************************) -(* $Id: tformat.ml 9270 2009-05-20 11:52:42Z doligez $ +(* $Id$ A testbed file for the module Format. diff --git a/testsuite/tests/basic-private/length.ml b/testsuite/tests/basic-private/length.ml index 945d05d14..318e98cb1 100644 --- a/testsuite/tests/basic-private/length.ml +++ b/testsuite/tests/basic-private/length.ml @@ -1,4 +1,4 @@ -(* $Id: length.ml 8482 2007-11-06 21:06:18Z weis $ +(* $Id$ A testbed file for private type abbreviation definitions. diff --git a/testsuite/tests/basic-private/length.mli b/testsuite/tests/basic-private/length.mli index 2215ec8f7..6cd7e1214 100644 --- a/testsuite/tests/basic-private/length.mli +++ b/testsuite/tests/basic-private/length.mli @@ -1,4 +1,4 @@ -(* $Id: length.mli 8482 2007-11-06 21:06:18Z weis $ +(* $Id$ A testbed file for private type abbreviation definitions. diff --git a/testsuite/tests/basic-private/tlength.ml b/testsuite/tests/basic-private/tlength.ml index a428e2075..f1fd91af9 100644 --- a/testsuite/tests/basic-private/tlength.ml +++ b/testsuite/tests/basic-private/tlength.ml @@ -1,4 +1,4 @@ -(* $Id: tlength.ml 8482 2007-11-06 21:06:18Z weis $ +(* $Id$ A testbed file for private type abbreviation definitions. diff --git a/testsuite/tests/basic/maps.ml b/testsuite/tests/basic/maps.ml index cb0e989b1..c23f2d8c1 100644 --- a/testsuite/tests/basic/maps.ml +++ b/testsuite/tests/basic/maps.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: sets.ml 5183 2002-10-16 09:06:39Z weis $ *) +(* $Id$ *) module IntMap = Map.Make(struct type t = int let compare x y = x-y end) diff --git a/testsuite/tests/basic/sets.ml b/testsuite/tests/basic/sets.ml index 379b9e82c..983145ee4 100644 --- a/testsuite/tests/basic/sets.ml +++ b/testsuite/tests/basic/sets.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: sets.ml 5183 2002-10-16 09:06:39Z weis $ *) +(* $Id$ *) module IntSet = Set.Make(struct type t = int let compare x y = x-y end) diff --git a/testsuite/tests/embedded/.svnignore b/testsuite/tests/embedded/.svnignore new file mode 100755 index 000000000..4394099ff --- /dev/null +++ b/testsuite/tests/embedded/.svnignore @@ -0,0 +1,10 @@ +#!/bin/sh + +svn propset svn:ignore -F - . < y then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y) diff --git a/testsuite/tests/misc/taku.ml b/testsuite/tests/misc/taku.ml index c3eae9f9e..555fb01c8 100644 --- a/testsuite/tests/misc/taku.ml +++ b/testsuite/tests/misc/taku.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: taku.ml 7017 2005-08-12 09:22:04Z xleroy $ *) +(* $Id$ *) let rec tak (x, y, z) = if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y)) diff --git a/testsuite/tests/misc/weaktest.ml b/testsuite/tests/misc/weaktest.ml index 5dd4e19d4..92ab5576d 100644 --- a/testsuite/tests/misc/weaktest.ml +++ b/testsuite/tests/misc/weaktest.ml @@ -1,4 +1,4 @@ -(* $Id: weaktest.ml 8766 2008-01-11 11:55:36Z doligez $ *) +(* $Id$ *) let debug = false;; diff --git a/testsuite/tests/regression-camlp4-class-type-plus/Makefile b/testsuite/tests/regression-camlp4-class-type-plus/Makefile new file mode 100644 index 000000000..95106ce62 --- /dev/null +++ b/testsuite/tests/regression-camlp4-class-type-plus/Makefile @@ -0,0 +1,5 @@ +ADD_COMPFLAGS = -pp 'camlp4o' +MAIN_MODULE = camlp4_class_type_plus_ok + +include ../../makefiles/Makefile.okbad +include ../../makefiles/Makefile.common diff --git a/testsuite/tests/regression-camlp4-class-type-plus/camlp4_class_type_plus_ok.ml b/testsuite/tests/regression-camlp4-class-type-plus/camlp4_class_type_plus_ok.ml new file mode 100644 index 000000000..79ba26d82 --- /dev/null +++ b/testsuite/tests/regression-camlp4-class-type-plus/camlp4_class_type_plus_ok.ml @@ -0,0 +1,9 @@ +type t;; +type xdr_value;; + +class type [ 't ] engine = object +end;; + +module type T = sig +class unbound_async_call : t -> [xdr_value] engine;; +end;; diff --git a/testsuite/tests/regression-pr5080-notes/Makefile b/testsuite/tests/regression-pr5080-notes/Makefile new file mode 100644 index 000000000..149c289be --- /dev/null +++ b/testsuite/tests/regression-pr5080-notes/Makefile @@ -0,0 +1,5 @@ +ADD_COMPFLAGS = -pp 'camlp4o pa_macro.cmo' +MAIN_MODULE = pr5080_notes_ok + +include ../../makefiles/Makefile.okbad +include ../../makefiles/Makefile.common diff --git a/testsuite/tests/regression-pr5080-notes/pr5080_notes_ok.ml b/testsuite/tests/regression-pr5080-notes/pr5080_notes_ok.ml new file mode 100644 index 000000000..175bc8b74 --- /dev/null +++ b/testsuite/tests/regression-pr5080-notes/pr5080_notes_ok.ml @@ -0,0 +1,4 @@ +let marshal_int f = + match [] with + | _ :: `INT n :: _ -> f n + | _ -> failwith "marshal_int" diff --git a/testsuite/tests/tool-lexyacc/.svnignore b/testsuite/tests/tool-lexyacc/.svnignore index 9cc5affae..7345b4ea9 100644 --- a/testsuite/tests/tool-lexyacc/.svnignore +++ b/testsuite/tests/tool-lexyacc/.svnignore @@ -1,8 +1,20 @@ +#!/bin/sh + +svn propset svn:ignore -F - . < 'a = "%raise" @@ -43,4 +43,4 @@ external weak_get: 'a weak_t -> int -> 'a option = "caml_weak_get";; let x = 42;; -(* eof $Id: lib.ml 6190 2004-04-06 09:11:45Z starynke $ *) +(* eof $Id$ *) diff --git a/testsuite/tests/tool-ocaml/t301-object.ml b/testsuite/tests/tool-ocaml/t301-object.ml index 6cef9bedc..5b053c006 100644 --- a/testsuite/tests/tool-ocaml/t301-object.ml +++ b/testsuite/tests/tool-ocaml/t301-object.ml @@ -7,7 +7,7 @@ ocamlc -nostdlib -I ../../stdlib \ t301-object.ml -o t301-object.byte ***) -(* $Id: t301-object.ml 6363 2004-06-02 09:42:01Z basile $ *) +(* $Id$ *) class c = object (self) @@ -26,4 +26,4 @@ let (x,y,z) = f () in if y <> 2 then raise Not_found; if z <> 4 then raise Not_found;; -(**** eof $Id: t301-object.ml 6363 2004-06-02 09:42:01Z basile $ *) +(**** eof $Id$ *) diff --git a/testsuite/tests/tool-ocamldoc/odoc_test.ml b/testsuite/tests/tool-ocamldoc/odoc_test.ml index 8bd112701..ba73fe52e 100644 --- a/testsuite/tests/tool-ocamldoc/odoc_test.ml +++ b/testsuite/tests/tool-ocamldoc/odoc_test.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_test.ml 6127 2004-02-20 16:28:27Z guesdon $ *) +(* $Id$ *) (** Custom generator to perform test on ocamldoc. *) diff --git a/testsuite/tests/typing-fstclassmod/.svnignore b/testsuite/tests/typing-fstclassmod/.svnignore new file mode 100755 index 000000000..4394099ff --- /dev/null +++ b/testsuite/tests/typing-fstclassmod/.svnignore @@ -0,0 +1,10 @@ +#!/bin/sh + +svn propset svn:ignore -F - . < as 'a);; +class type ['a] o2 = object ('a obj) end;; +class ['a] o3 = object (self : 'a obj) end;; +class ['a] o4 = object (self) method m = (self : 'a obj) end;; +(* +let o = object (self : 'a obj) end;; +let o = object (self) method m = (self : 'a obj) end;; +*) diff --git a/testsuite/tests/typing-objects/.svnignore b/testsuite/tests/typing-objects/.svnignore new file mode 100755 index 000000000..4394099ff --- /dev/null +++ b/testsuite/tests/typing-objects/.svnignore @@ -0,0 +1,10 @@ +#!/bin/sh + +svn propset svn:ignore -F - . < 1 && suffix.[0] = '.' then + synonyms := suffix :: !synonyms + else begin + fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix; + error_occurred := true + end + let find_file name = let uname = String.uncapitalize name in let rec find_in_array a pos = @@ -63,19 +73,25 @@ let find_file name = | None -> find_in_path rem in find_in_path !load_path +let rec find_file_in_list = function + [] -> raise Not_found +| x :: rem -> try find_file x with Not_found -> find_file_in_list rem + let find_dependency modname (byt_deps, opt_deps) = try - let filename = find_file (modname ^ ".mli") in - let basename = Filename.chop_suffix filename ".mli" in + let candidates = List.map ((^) modname) !mli_synonyms in + let filename = find_file_in_list candidates in + let basename = Filename.chop_extension filename in let optname = - if Sys.file_exists (basename ^ ".ml") + if List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !ml_synonyms then basename ^ ".cmx" else basename ^ ".cmi" in ((basename ^ ".cmi") :: byt_deps, optname :: opt_deps) with Not_found -> try - let filename = find_file (modname ^ ".ml") in - let basename = Filename.chop_suffix filename ".ml" in + let candidates = List.map ((^) modname) !ml_synonyms in + let filename = find_file_in_list candidates in + let basename = Filename.chop_extension filename in let bytename = basename ^ (if !native_only then ".cmx" else ".cmo") in (bytename :: byt_deps, (basename ^ ".cmx") :: opt_deps) @@ -129,7 +145,12 @@ let print_dependencies target_file deps = let print_raw_dependencies source_file deps = print_filename source_file; print_string ":"; Depend.StringSet.iter - (fun dep -> print_char ' '; print_string dep) + (fun dep -> + if (String.length dep > 0) + && (match dep.[0] with 'A'..'Z' -> true | _ -> false) then begin + print_char ' '; + print_string dep + end) deps; print_char '\n' @@ -203,7 +224,7 @@ let ml_file_dependencies source_file = end else begin let basename = Filename.chop_extension source_file in let init_deps = - if Sys.file_exists (basename ^ ".mli") + if List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !mli_synonyms then let cmi_name = basename ^ ".cmi" in ([cmi_name], [cmi_name]) else ([], []) in let (byt_deps, opt_deps) = @@ -264,9 +285,9 @@ let file_dependencies_as kind source_file = report_err x let file_dependencies source_file = - if Filename.check_suffix source_file ".ml" then + if List.exists (Filename.check_suffix source_file) !ml_synonyms then file_dependencies_as ML source_file - else if Filename.check_suffix source_file ".mli" then + else if List.exists (Filename.check_suffix source_file) !mli_synonyms then file_dependencies_as MLI source_file else () @@ -294,6 +315,14 @@ let _ = " Process as a .ml file"; "-intf", Arg.String (file_dependencies_as MLI), " Process as a .mli file"; + "-ml-synonym", Arg.String(add_to_synonym_list ml_synonyms), + " Consider as a synonym of the .ml extension"; + "-mli-synonym", Arg.String(add_to_synonym_list mli_synonyms), + " Consider as a synonym of the .mli extension"; + "-ml-synonym", Arg.String(add_to_synonym_list ml_synonyms), + " Consider as a synonym of the .ml extension"; + "-mli-synonym", Arg.String(add_to_synonym_list mli_synonyms), + " Consider as a synonym of the .mli extension"; "-modules", Arg.Set raw_dependencies, " Print module dependencies in raw form (not suitable for make)"; "-native", Arg.Set native_only, diff --git a/tools/ocamlmklib.mlp b/tools/ocamlmklib.mlp index 737749c17..2e2edd024 100644 --- a/tools/ocamlmklib.mlp +++ b/tools/ocamlmklib.mlp @@ -141,37 +141,37 @@ let parse_arguments argv = if !output_c = "" then output_c := !output let usage = "\ -Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|.dll files>\n\ -Options are:\n\ - -cclib C library passed to ocamlc -a or ocamlopt -a only\n\ - -ccopt C option passed to ocamlc -a or ocamlopt -a only\n\ - -custom disable dynamic loading\n\ - -dllpath Add to the run-time search path for DLLs\n\ - -F Specify a framework directory (MacOSX)\n\ - -framework Use framework (MacOSX)\n\ - -help Print this help message and exit\n\ - --help Same as -help\n\ - -h Same as -help\n\ - -I Add to the path searched for Caml object files\n\ - -failsafe fall back to static linking if DLL construction failed\n\ - -ldopt C option passed to the shared linker only\n\ - -linkall Build Caml archive with link-all behavior\n\ - -l Specify a dependent C library\n\ - -L Add to the path searched for C libraries\n\ - -ocamlc Use in place of \"ocamlc\"\n\ - -ocamlopt Use in place of \"ocamlopt\"\n\ - -o Generated Caml library is named .cma or .cmxa\n\ - -oc Generated C library is named dll.so or lib.a\n\ - -rpath Same as -dllpath \n\ - -R Same as -rpath\n\ - -verbose Print commands before executing them\n\ - -v same as -verbose\n\ - -version Print version and exit\n\ - -vnum Print version number and exit\n\ - -Wl,-rpath, Same as -dllpath \n\ - -Wl,-rpath -Wl, Same as -dllpath \n\ - -Wl,-R Same as -dllpath \n\ -" +Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|.dll files>\ +\nOptions are:\ +\n -cclib C library passed to ocamlc -a or ocamlopt -a only\ +\n -ccopt C option passed to ocamlc -a or ocamlopt -a only\ +\n -custom disable dynamic loading\ +\n -dllpath Add to the run-time search path for DLLs\ +\n -F Specify a framework directory (MacOSX)\ +\n -framework Use framework (MacOSX)\ +\n -help Print this help message and exit\ +\n --help Same as -help\ +\n -h Same as -help\ +\n -I Add to the path searched for Caml object files\ +\n -failsafe fall back to static linking if DLL construction failed\ +\n -ldopt C option passed to the shared linker only\ +\n -linkall Build Caml archive with link-all behavior\ +\n -l Specify a dependent C library\ +\n -L Add to the path searched for C libraries\ +\n -ocamlc Use in place of \"ocamlc\"\ +\n -ocamlopt Use in place of \"ocamlopt\"\ +\n -o Generated Caml library is named .cma or .cmxa\ +\n -oc Generated C library is named dll.so or lib.a\ +\n -rpath Same as -dllpath \ +\n -R Same as -rpath\ +\n -verbose Print commands before executing them\ +\n -v same as -verbose\ +\n -version Print version and exit\ +\n -vnum Print version number and exit\ +\n -Wl,-rpath, Same as -dllpath \ +\n -Wl,-rpath -Wl, Same as -dllpath \ +\n -Wl,-R Same as -dllpath \ +\n" let command cmd = if !verbose then (print_string "+ "; print_string cmd; print_newline()); diff --git a/typing/ctype.ml b/typing/ctype.ml index 40c400b18..d3e97e65e 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -177,6 +177,11 @@ module TypePairs = (* Miscellaneous operations on object types *) (**********************************************) +(* Note: + We need to maintain some invariants: + * cty_self must be a Tobject + * ... +*) (**** Object field manipulation. ****) @@ -866,6 +871,20 @@ let instance_parameterized_type_2 sch_args sch_lst sch = cleanup_types (); (ty_args, ty_lst, ty) +let instance_declaration decl = + let decl = + {decl with type_params = List.map copy decl.type_params; + type_manifest = may_map copy decl.type_manifest; + type_kind = match decl.type_kind with + | Type_abstract -> Type_abstract + | Type_variant cl -> + Type_variant (List.map (fun (s,tl) -> (s, List.map copy tl)) cl) + | Type_record (fl, rr) -> + Type_record (List.map (fun (s,m,ty) -> (s, m, copy ty)) fl, rr)} + in + cleanup_types (); + decl + let instance_class params cty = let rec copy_class_type = function diff --git a/typing/ctype.mli b/typing/ctype.mli index 5e0db4a99..d12a673b0 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -116,6 +116,7 @@ val instance_parameterized_type: val instance_parameterized_type_2: type_expr list -> type_expr list -> type_expr -> type_expr list * type_expr list * type_expr +val instance_declaration: type_declaration -> type_declaration val instance_class: type_expr list -> class_type -> type_expr list * class_type val instance_poly: diff --git a/typing/env.ml b/typing/env.ml index 044247990..6eb558552 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -869,4 +869,4 @@ let report_error ppf = function | Need_recursive_types(import, export) -> fprintf ppf "@[Unit %s imports from %s, which uses recursive types.@ %s@]" - import export "The compilation flag -rectypes is required" + export import "The compilation flag -rectypes is required" diff --git a/typing/oprint.ml b/typing/oprint.ml index ca5db71a6..681661734 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -32,7 +32,7 @@ let parenthesized_ident name = (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]) || (match name.[0] with - 'a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' -> + 'a'..'z' | 'A'..'Z' | '\223'..'\246' | '\248'..'\255' | '_' -> false | _ -> true) diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 03c5e9110..081e30083 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -742,7 +742,7 @@ let tree_of_class_declaration id cl rs = reset (); List.iter add_alias params; prepare_class_type params cl.cty_type; - let sty = self_type cl.cty_type in + let sty = Ctype.self_type cl.cty_type in List.iter mark_loops params; List.iter check_name_of_type (List.map proxy params); @@ -764,7 +764,7 @@ let tree_of_cltype_declaration id cl rs = reset (); List.iter add_alias params; prepare_class_type params cl.clty_type; - let sty = self_type cl.clty_type in + let sty = Ctype.self_type cl.clty_type in List.iter mark_loops params; List.iter check_name_of_type (List.map proxy params); diff --git a/typing/typeclass.ml b/typing/typeclass.ml index de093cfc5..c81e8fe8d 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -360,7 +360,7 @@ let rec class_type_field env self_type meths (val_sig, concr_meths, inher) = and class_signature env sty sign = let meths = ref Meths.empty in - let self_type = transl_simple_type env false sty in + let self_type = Ctype.expand_head env (transl_simple_type env false sty) in (* Check that the binder is a correct type, and introduce a dummy method preventing self type from being closed. *) @@ -719,7 +719,9 @@ and class_structure cl_num final val_env met_env loc (spat, str) = let added = List.filter (fun x -> List.mem x l1) l2 in if added <> [] then Location.prerr_warning loc (Warnings.Implicit_public_methods added); - {cl_field = fields; cl_meths = meths}, sign + {cl_field = fields; cl_meths = meths}, + if final then sign else + {sign with cty_self = Ctype.expand_head val_env public_self} and class_expr cl_num val_env met_env scl = match scl.pcl_desc with diff --git a/typing/typedecl.ml b/typing/typedecl.ml index bc2986c41..f8a581815 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -771,7 +771,7 @@ let transl_value_decl env valdecl = (* Translate a "with" constraint -- much simplified version of transl_type_decl. *) -let transl_with_constraint env id row_path sdecl = +let transl_with_constraint env id row_path orig_decl sdecl = reset_type_variables(); Ctype.begin_def(); let params = @@ -779,6 +779,10 @@ let transl_with_constraint env id row_path sdecl = List.map (enter_type_variable true sdecl.ptype_loc) sdecl.ptype_params with Already_bound -> raise(Error(sdecl.ptype_loc, Repeated_parameter)) in + let orig_decl = Ctype.instance_declaration orig_decl in + let arity_ok = List.length params = orig_decl.type_arity in + if arity_ok then + List.iter2 (Ctype.unify_var env) params orig_decl.type_params; List.iter (function (ty, ty', loc) -> try @@ -791,7 +795,7 @@ let transl_with_constraint env id row_path sdecl = let decl = { type_params = params; type_arity = List.length params; - type_kind = Type_abstract; + type_kind = if arity_ok then orig_decl.type_kind else Type_abstract; type_private = sdecl.ptype_private; type_manifest = begin match sdecl.ptype_manifest with diff --git a/typing/typedecl.mli b/typing/typedecl.mli index fb7b219be..f0e742bd8 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -30,7 +30,7 @@ val transl_value_decl: Env.t -> Parsetree.value_description -> value_description val transl_with_constraint: - Env.t -> Ident.t -> Path.t option -> + Env.t -> Ident.t -> Path.t option -> type_declaration -> Parsetree.type_declaration -> type_declaration val abstract_type_decl: int -> type_declaration diff --git a/typing/typemod.ml b/typing/typemod.ml index 2edf087e8..64c099e65 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -93,6 +93,16 @@ let rec make_params n = function let wrap_param s = {ptyp_desc=Ptyp_var s; ptyp_loc=Location.none} +let make_next_first rs rem = + if rs = Trec_first then + match rem with + Tsig_type (id, decl, Trec_next) :: rem -> + Tsig_type (id, decl, Trec_first) :: rem + | Tsig_module (id, mty, Trec_next) :: rem -> + Tsig_module (id, mty, Trec_first) :: rem + | _ -> rem + else rem + let merge_constraint initial_env loc sg lid constr = let real_id = ref None in let rec merge env sg namelist row_id = @@ -115,7 +125,7 @@ let merge_constraint initial_env loc sg lid constr = 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 id (Some(Pident id_row)) sdecl in + initial_env id (Some(Pident id_row)) decl 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 @@ -123,7 +133,7 @@ let merge_constraint initial_env loc sg lid constr = | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_type sdecl) when Ident.name id = s -> let newdecl = - Typedecl.transl_with_constraint initial_env id None sdecl in + Typedecl.transl_with_constraint initial_env id None decl 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 _ | Pwith_typesubst _)) @@ -133,10 +143,10 @@ let merge_constraint initial_env loc sg lid constr = when Ident.name id = s -> (* Check as for a normal with constraint, but discard definition *) let newdecl = - Typedecl.transl_with_constraint initial_env id None sdecl in + Typedecl.transl_with_constraint initial_env id None decl sdecl in check_type_decl env id row_id newdecl decl rs rem; real_id := Some id; - rem + make_next_first rs rem | (Tsig_module(id, mty, rs) :: rem, [s], Pwith_module lid) when Ident.name id = s -> let (path, mty') = Typetexp.find_module initial_env loc lid in @@ -149,7 +159,7 @@ let merge_constraint initial_env loc sg lid constr = let newmty = Mtype.strengthen env mty' path in ignore(Includemod.modtypes env newmty mty); real_id := Some id; - rem + make_next_first 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 None in @@ -318,7 +328,8 @@ let check_sig_item type_names module_names modtype_names loc = function let rec remove_values ids = function [] -> [] - | Tsig_value (id, _) :: rem when List.exists (Ident.equal id) ids -> rem + | Tsig_value (id, _) :: rem + when List.exists (Ident.equal id) ids -> remove_values ids rem | f :: rem -> f :: remove_values ids rem let rec get_values = function diff --git a/typing/unused_var.ml b/typing/unused_var.ml index 953ad9d15..00675655c 100644 --- a/typing/unused_var.ml +++ b/typing/unused_var.ml @@ -106,7 +106,7 @@ and structure_item ppf tbl s = | Pstr_open _ -> () | Pstr_class cdl -> List.iter (class_declaration ppf tbl) cdl; | Pstr_class_type _ -> () - | Pstr_include _ -> () + | Pstr_include me -> module_expr ppf tbl me; and expression ppf tbl e = match e.pexp_desc with