From: Stephane Glondu Date: Wed, 15 Jun 2011 16:18:21 +0000 (+0200) Subject: Imported Upstream version 3.12.1~rc1 X-Git-Tag: archive/raspbian/4.08.1-4+rpi1~3^2~63^2~17 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=05cf7b74a9913efad4360ad9b838096634e01e12;p=ocaml.git Imported Upstream version 3.12.1~rc1 --- diff --git a/.depend b/.depend index 9c00f119..2c1a7958 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 5f4a4ac2..17e376ae 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,99 @@ +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 +- 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: ---------------------- @@ -2624,4 +2720,4 @@ Caml Special Light 1.06: * First public release. -$Id: Changes 10613 2010-07-02 08:44:04Z frisch $ +$Id: Changes 11083 2011-06-11 07:24:12Z xleroy $ diff --git a/INSTALL b/INSTALL index dd479b41..d73657fa 100644 --- a/INSTALL +++ b/INSTALL @@ -251,10 +251,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 cecc326c..29b5c850 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 0f9505fd..502dd181 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 @@ -135,4 +135,4 @@ You can also contact the implementors directly at caml@inria.fr. ---- -$Id: README 9547 2010-01-22 12:48:24Z doligez $ +$Id: README 11017 2011-04-29 09:10:12Z doligez $ diff --git a/VERSION b/VERSION index 100cc0d7..26a72c1f 100644 --- a/VERSION +++ b/VERSION @@ -1,6 +1,6 @@ -3.12.0 +3.12.1+rc1 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli -# $Id: VERSION 10641 2010-08-02 13:10:35Z doligez $ +# $Id: VERSION 11094 2011-06-15 11:01:14Z doligez $ diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 55da47b5..94e9cb28 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp 10488 2010-06-02 08:55:35Z xleroy $ *) +(* $Id: emit.mlp 10980 2011-03-13 13:33:17Z xleroy $ *) (* Emission of x86-64 (AMD 64) assembly code *) @@ -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 @@ -688,17 +691,18 @@ let fundecl fundecl = emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; emit_call_bound_errors (); + begin match Config.system with + "linux" | "gnu" -> + ` .type {emit_symbol fundecl.fun_name},@function\n`; + ` .size {emit_symbol fundecl.fun_name},.-{emit_symbol fundecl.fun_name}\n` + | _ -> () + end; if !float_constants <> [] then begin if macosx then ` .literal8\n` else ` .section .rodata.cst8,\"a\",@progbits\n`; List.iter emit_float_constant !float_constants - end; - match Config.system with - "linux" | "gnu" -> - ` .type {emit_symbol fundecl.fun_name},@function\n`; - ` .size {emit_symbol fundecl.fun_name},.-{emit_symbol fundecl.fun_name}\n` - | _ -> () + end (* Emission of data *) diff --git a/asmcomp/amd64/emit_nt.mlp b/asmcomp/amd64/emit_nt.mlp index 60b5400e..125099c3 100644 --- a/asmcomp/amd64/emit_nt.mlp +++ b/asmcomp/amd64/emit_nt.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit_nt.mlp 10460 2010-05-24 15:26:23Z xleroy $ *) +(* $Id: emit_nt.mlp 10862 2010-11-27 17:19:24Z xleroy $ *) (* Emission of x86-64 (AMD 64) assembly code, MASM syntax *) @@ -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 4f83289a..5424b384 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: asmlink.ml 10424 2010-05-19 11:29:38Z xleroy $ *) +(* $Id: asmlink.ml 11049 2011-05-17 14:14:38Z doligez $ *) (* Link a set of .cmx/.o files and produce an executable *) @@ -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 544772a6..c5468751 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: closure.ml 8966 2008-08-01 12:52:14Z xleroy $ *) +(* $Id: closure.ml 10667 2010-09-02 13:29:21Z xclerc $ *) (* Introduction of closures, uncurrying, recognition of direct calls *) @@ -513,7 +513,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 0ed7435d..dd982fbc 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: cmmgen.ml 10424 2010-05-19 11:29:38Z xleroy $ *) +(* $Id: cmmgen.ml 10794 2010-11-11 17:08:07Z xleroy $ *) (* Translation from closed lambda to C-- *) @@ -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 b62a1b05..e9e51d41 100644 --- a/asmcomp/comballoc.ml +++ b/asmcomp/comballoc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: comballoc.ml 7812 2007-01-29 12:11:18Z xleroy $ *) +(* $Id: comballoc.ml 10910 2010-12-22 13:52:24Z xleroy $ *) (* Combine heap allocations occurring in the same basic block *) @@ -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.mlp b/asmcomp/i386/emit.mlp index 3baba2e6..16a4da45 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp 9540 2010-01-20 16:26:46Z doligez $ *) +(* $Id: emit.mlp 10980 2011-03-13 13:33:17Z xleroy $ *) (* Emission of Intel 386 assembly code *) @@ -905,12 +905,12 @@ let fundecl fundecl = emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; emit_call_bound_errors (); - List.iter emit_float_constant !float_constants; - match Config.system with + begin match Config.system with "linux_elf" | "bsd_elf" | "gnu" -> ` .type {emit_symbol fundecl.fun_name},@function\n`; ` .size {emit_symbol fundecl.fun_name},.-{emit_symbol fundecl.fun_name}\n` - | _ -> () + | _ -> () end; + List.iter emit_float_constant !float_constants (* Emission of data *) diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index 2aff37df..0efe2628 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit_nt.mlp 9547 2010-01-22 12:48:24Z doligez $ *) +(* $Id: emit_nt.mlp 11067 2011-06-04 15:21:43Z xleroy $ *) (* Emission of Intel 386 assembly code, MASM syntax. *) @@ -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 824dbb50..2fc40f73 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: selectgen.ml 10450 2010-05-21 12:00:49Z doligez $ *) +(* $Id: selectgen.ml 10667 2010-09-02 13:29:21Z xclerc $ *) (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) @@ -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 8eb4ebfa..090610a2 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: amd64.S 10270 2010-04-19 08:47:10Z xleroy $ */ +/* $Id: amd64.S 10862 2010-11-27 17:19:24Z xleroy $ */ /* Asm part of the runtime system, AMD64 processor */ /* Must be preprocessed by cpp */ @@ -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 fa72ed8e..6430cfef 100644 --- a/asmrun/amd64nt.asm +++ b/asmrun/amd64nt.asm @@ -11,7 +11,7 @@ ; ;********************************************************************* -; $Id: amd64nt.asm 10215 2010-03-28 08:04:39Z xleroy $ +; $Id: amd64nt.asm 10862 2010-11-27 17:19:24Z xleroy $ ; Asm part of the runtime system, AMD64 processor, Intel syntax @@ -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 0e7e1811..98f4c561 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep index 59d44704..cce4cd49 100755 Binary files a/boot/ocamldep and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index 1987b5a3..e9d8c8c1 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/build/boot.sh b/build/boot.sh index 5625cb7c..89903a65 100755 --- a/build/boot.sh +++ b/build/boot.sh @@ -1,8 +1,8 @@ #!/bin/sh -# $Id: boot.sh 10443 2010-05-20 09:44:25Z doligez $ +# $Id: boot.sh 10956 2011-02-21 15:09:49Z xclerc $ 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 9f1417a2..264d6355 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 673482cf..78315361 100755 --- a/build/camlp4-byte-only.sh +++ b/build/camlp4-byte-only.sh @@ -8,12 +8,11 @@ # # # 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. # # # ######################################################################### -# $Id: camlp4-byte-only.sh 10443 2010-05-20 09:44:25Z doligez $ +# $Id: camlp4-byte-only.sh 11041 2011-05-13 08:40:05Z doligez $ set -e cd `dirname $0`/.. diff --git a/build/camlp4-mkCamlp4Ast.sh b/build/camlp4-mkCamlp4Ast.sh index 2a30b9ab..76b629c4 100755 --- a/build/camlp4-mkCamlp4Ast.sh +++ b/build/camlp4-mkCamlp4Ast.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id$ +# $Id: camlp4-mkCamlp4Ast.sh 11040 2011-05-13 08:37:04Z doligez $ set -e cd `dirname $0`/.. diff --git a/build/camlp4-native-only.sh b/build/camlp4-native-only.sh index c8e9e6c4..005e2554 100755 --- a/build/camlp4-native-only.sh +++ b/build/camlp4-native-only.sh @@ -8,12 +8,11 @@ # # # 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. # # # ######################################################################### -# $Id: camlp4-native-only.sh 10443 2010-05-20 09:44:25Z doligez $ +# $Id: camlp4-native-only.sh 11041 2011-05-13 08:40:05Z doligez $ set -e cd `dirname $0`/.. diff --git a/build/fastworld.sh b/build/fastworld.sh index ca9d9712..629d070a 100755 --- a/build/fastworld.sh +++ b/build/fastworld.sh @@ -8,12 +8,11 @@ # # # 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. # # # ######################################################################### -# $Id: fastworld.sh 10443 2010-05-20 09:44:25Z doligez $ +# $Id: fastworld.sh 11041 2011-05-13 08:40:05Z doligez $ cd `dirname $0` set -e @@ -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 a7ab1035..27859323 100755 --- a/build/install.sh +++ b/build/install.sh @@ -12,7 +12,7 @@ # # ######################################################################### -# $Id: install.sh 10443 2010-05-20 09:44:25Z doligez $ +# $Id: install.sh 10856 2010-11-25 13:57:43Z xclerc $ set -e @@ -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 fe4d34e8..18569880 100755 --- a/build/ocamlbuild-byte-only.sh +++ b/build/ocamlbuild-byte-only.sh @@ -8,12 +8,11 @@ # # # 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. # # # ######################################################################### -# $Id: ocamlbuild-byte-only.sh 10443 2010-05-20 09:44:25Z doligez $ +# $Id: ocamlbuild-byte-only.sh 11041 2011-05-13 08:40:05Z doligez $ set -e cd `dirname $0`/.. diff --git a/build/ocamlbuild-native-only.sh b/build/ocamlbuild-native-only.sh index 92630a11..93ac14ae 100755 --- a/build/ocamlbuild-native-only.sh +++ b/build/ocamlbuild-native-only.sh @@ -8,12 +8,11 @@ # # # 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. # # # ######################################################################### -# $Id: ocamlbuild-native-only.sh 10443 2010-05-20 09:44:25Z doligez $ +# $Id: ocamlbuild-native-only.sh 11041 2011-05-13 08:40:05Z doligez $ set -e cd `dirname $0`/.. diff --git a/build/ocamlbuildlib-native-only.sh b/build/ocamlbuildlib-native-only.sh index 6997b15f..a9fd02f1 100755 --- a/build/ocamlbuildlib-native-only.sh +++ b/build/ocamlbuildlib-native-only.sh @@ -8,12 +8,11 @@ # # # 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. # # # ######################################################################### -# $Id: ocamlbuildlib-native-only.sh 10443 2010-05-20 09:44:25Z doligez $ +# $Id: ocamlbuildlib-native-only.sh 11041 2011-05-13 08:40:05Z doligez $ set -e cd `dirname $0`/.. diff --git a/build/otherlibs-targets.sh b/build/otherlibs-targets.sh index cb19fe39..85064701 100644 --- a/build/otherlibs-targets.sh +++ b/build/otherlibs-targets.sh @@ -8,12 +8,11 @@ # # # 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. # # # ######################################################################### -# $Id: otherlibs-targets.sh 10443 2010-05-20 09:44:25Z doligez $ +# $Id: otherlibs-targets.sh 11041 2011-05-13 08:40:05Z doligez $ OTHERLIBS_BYTE="" OTHERLIBS_NATIVE="" diff --git a/build/targets.sh b/build/targets.sh index e740a9bd..75c96daa 100644 --- a/build/targets.sh +++ b/build/targets.sh @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: targets.sh 10443 2010-05-20 09:44:25Z doligez $ +# $Id: targets.sh 10856 2010-11-25 13:57:43Z xclerc $ . config/config.sh . build/otherlibs-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 0b9a4b28..534bce54 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 7189cbc9..d863c59d 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: bytegen.ml 9270 2009-05-20 11:52:42Z doligez $ *) +(* $Id: bytegen.ml 10667 2010-09-02 13:29:21Z xclerc $ *) (* bytegen.ml : translation of lambda terms to lists of instructions. *) @@ -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 4a6426db..bd8f3b23 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: bytelink.ml 9540 2010-01-20 16:26:46Z doligez $ *) +(* $Id: bytelink.ml 10695 2010-09-29 16:46:54Z doligez $ *) (* Link a set of .cmo files and produce a bytecode executable. *) @@ -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 cc1cdcd3..4ee3b8b0 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: bytepackager.ml 10450 2010-05-21 12:00:49Z doligez $ *) +(* $Id: bytepackager.ml 11083 2011-06-11 07:24:12Z xleroy $ *) (* "Package" a set of .cmo files into one .cmo file having the original compilation units as sub-modules. *) @@ -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 0b195425..bf39ffeb 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: lambda.ml 9547 2010-01-22 12:48:24Z doligez $ *) +(* $Id: lambda.ml 10667 2010-09-02 13:29:21Z xclerc $ *) open Misc open Path @@ -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 2f14c299..5f948ddc 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: lambda.mli 10268 2010-04-18 09:02:40Z xleroy $ *) +(* $Id: lambda.mli 10667 2010-09-02 13:29:21Z xclerc $ *) (* The "lambda" intermediate code *) @@ -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 0c7fde69..e195ece1 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: printlambda.ml 8974 2008-08-01 16:57:10Z mauny $ *) +(* $Id: printlambda.ml 10667 2010-09-02 13:29:21Z xclerc $ *) open Format open Asttypes @@ -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 e62af889..9608bc68 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: simplif.ml 9547 2010-01-22 12:48:24Z doligez $ *) +(* $Id: simplif.ml 10667 2010-09-02 13:29:21Z xclerc $ *) (* Elimination of useless Llet(Alias) bindings. Also transform let-bound references into variables. *) @@ -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 @@ -313,7 +313,7 @@ let simplify_lets lam = (* Lalias-bound variables are never assigned, so don't increase v's refcount *) count l - | Lsend(_, m, o, ll) -> List.iter count (m::o::ll) + | Lsend(_, m, o, ll, _) -> List.iter count (m::o::ll) | Levent(l, _) -> count l | Lifused(v, l) -> if count_var v > 0 then count l @@ -402,11 +402,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 fd8eab74..e19f4f51 100644 --- a/bytecomp/simplif.mli +++ b/bytecomp/simplif.mli @@ -10,10 +10,17 @@ (* *) (***********************************************************************) -(* $Id: simplif.mli 2553 1999-11-17 18:59:06Z xleroy $ *) +(* $Id: simplif.mli 10667 2010-09-02 13:29:21Z xclerc $ *) -(* 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 a8f689a0..cd727650 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translclass.ml 9153 2008-12-03 18:09:09Z doligez $ *) +(* $Id: translclass.ml 10667 2010-09-02 13:29:21Z xclerc $ *) open Misc open Asttypes @@ -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 12b2f90d..e1a50084 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translcore.ml 10445 2010-05-20 14:57:42Z doligez $ *) +(* $Id: translcore.ml 10667 2010-09-02 13:29:21Z xclerc $ *) (* Translation from typed abstract syntax to lambda terms, for the core language *) @@ -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 a383724e..9d26d4e0 100644 --- a/byterun/compare.c +++ b/byterun/compare.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: compare.c 8768 2008-01-11 16:13:18Z doligez $ */ +/* $Id: compare.c 11037 2011-05-12 14:34:05Z xleroy $ */ #include #include @@ -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/config.h b/byterun/config.h index 79713829..4bf1274c 100644 --- a/byterun/config.h +++ b/byterun/config.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: config.h 9153 2008-12-03 18:09:09Z doligez $ */ +/* $Id: config.h 10787 2010-11-10 15:47:34Z doligez $ */ #ifndef CAML_CONFIG_H #define CAML_CONFIG_H @@ -135,7 +135,7 @@ typedef struct { uint32 l, h; } uint64, int64; #define Minor_heap_max (1 << 28) /* Default size of the minor zone. (words) */ -#define Minor_heap_def 32768 +#define Minor_heap_def 262144 /* Minimum size increment when growing the heap (words). diff --git a/byterun/custom.h b/byterun/custom.h index 7ac9745c..aa453deb 100644 --- a/byterun/custom.h +++ b/byterun/custom.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: custom.h 9547 2010-01-22 12:48:24Z doligez $ */ +/* $Id: custom.h 11037 2011-05-12 14:34:05Z xleroy $ */ #ifndef CAML_CUSTOM_H #define CAML_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 72af1f0e..e7b1494d 100644 --- a/byterun/fail.c +++ b/byterun/fail.c @@ -11,10 +11,12 @@ /* */ /***********************************************************************/ -/* $Id: fail.c 9030 2008-09-18 11:23:28Z xleroy $ */ +/* $Id: fail.c 10793 2010-11-11 11:07:48Z xleroy $ */ /* 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 ccace825..c55a3d3f 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: gc_ctrl.c 10315 2010-04-27 07:55:08Z xleroy $ */ +/* $Id: gc_ctrl.c 10786 2010-11-10 15:46:16Z doligez $ */ #include "alloc.h" #include "compact.h" @@ -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 8b5463e4..e66e7172 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: ints.c 9547 2010-01-22 12:48:24Z doligez $ */ +/* $Id: ints.c 11037 2011-05-12 14:34:05Z xleroy $ */ #include #include @@ -614,7 +614,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 588ea503..e183dfce 100644 --- a/byterun/major_gc.h +++ b/byterun/major_gc.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: major_gc.h 8766 2008-01-11 11:55:36Z doligez $ */ +/* $Id: major_gc.h 10843 2010-11-22 15:32:07Z doligez $ */ #ifndef CAML_MAJOR_GC_H #define CAML_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 b19ddad5..2748353a 100644 --- a/byterun/stacks.c +++ b/byterun/stacks.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: stacks.c 10315 2010-04-27 07:55:08Z xleroy $ */ +/* $Id: stacks.c 10793 2010-11-11 11:07:48Z xleroy $ */ /* To initialize and resize the stacks */ @@ -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 57cbb738..db273b29 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: startup.c 10444 2010-05-20 14:06:29Z doligez $ */ +/* $Id: startup.c 10668 2010-09-03 16:31:32Z doligez $ */ /* Start-up code */ @@ -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 458d3172..78bc5399 100644 --- a/byterun/sys.c +++ b/byterun/sys.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: sys.c 7944 2007-03-01 13:37:39Z xleroy $ */ +/* $Id: sys.c 11038 2011-05-12 15:12:14Z xleroy $ */ /* Basic system calls */ @@ -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 b6725989..8f62adf3 100644 --- a/camlp4/Camlp4/Camlp4Ast.partial.ml +++ b/camlp4/Camlp4/Camlp4Ast.partial.ml @@ -197,6 +197,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 dc48882e..06765691 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; @@ -877,6 +878,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$ >> -> @@ -1005,21 +1007,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 @@ -1031,30 +1033,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 c09261b9..1ec7120b 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 52590ae7..19945879 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 4b681936..e286eafb 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 51311439..bd8e13a1 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 020a7e0c..92c64eb8 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -856,6 +856,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 c2afdd63..67b99feb 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 4dae7e71..cb63478a 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 b8e97efe..1823ae0a 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 78fd2734..a123cc12 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 874426b1..f5878fb9 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 57f660da..0cb81be9 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 c7a510a5..0e0d9897 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 @@ -399,15 +442,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 -> @@ -537,6 +580,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$ >> ] ] ; @@ -584,6 +634,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 11fd0250..b8eaf0bd 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 -> @@ -1449,7 +1450,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) @@ -1734,7 +1735,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 c8025d75..76e67f41 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 978397d8..ce772d1d 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 92daa282..2dc65813 100644 --- a/camlp4/boot/Camlp4.ml +++ b/camlp4/boot/Camlp4.ml @@ -1124,6 +1124,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 = @@ -1981,6 +1983,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 @@ -3056,7 +3059,7 @@ module ErrorHandler : | x when x = Obj.string_tag -> "\"" ^ ((String.escaped (Obj.magic r : string)) ^ "\"") | x when x = Obj.double_tag -> - string_of_float (Obj.magic r : float) + Camlp4_import.Oprint.float_repres (Obj.magic r : float) | x when x = Obj.abstract_tag -> opaque "abstract" | x when x = Obj.custom_tag -> opaque "custom" | x when x = Obj.final_tag -> opaque "final" @@ -8999,6 +9002,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, @@ -11285,6 +11297,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, @@ -12406,6 +12427,9 @@ 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) @@ -13305,6 +13329,8 @@ 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 @@ -15014,7 +15040,7 @@ module Struct = with | Failure _ -> error loc - "Integer literal exceeds the range of representable integers of type int64") + "Integer literal exceeds the range of representable integers of type int64.1") in mkexp loc (Pexp_constant (Const_int64 i64)) | ExNativeInt (loc, s) -> let nati = @@ -16038,7 +16064,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 @@ -16140,7 +16168,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 @@ -16333,6 +16363,8 @@ module Struct = module Tools = struct + let get_prev_loc_only = ref false + module Make (Structure : Structure.S) = struct open Structure @@ -16353,22 +16385,38 @@ module Struct = let keep_prev_loc strm = match Stream.peek strm with | None -> Stream.sempty - | Some ((_, init_loc)) -> - let rec go prev_loc (__strm : _ Stream.t) = - (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; - })) - (Stream.slazy (fun _ -> go cur_loc strm))) - | _ -> Stream.sempty) + | 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 = @@ -16380,9 +16428,17 @@ module Struct = | None -> Loc.ghost let get_prev_loc strm = - match Stream.peek strm with - | Some ((_, r)) -> r.prev_loc - | None -> 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 diff --git a/camlp4/boot/Camlp4Ast.ml b/camlp4/boot/Camlp4Ast.ml index 67d865b5..32848f03 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 @@ -3894,6 +3902,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 @@ -4903,6 +4919,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 ]; @@ -5678,6 +5697,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 618693ed..786e249c 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) @@ -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)))); @@ -9450,7 +9459,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, @@ -14694,7 +14707,7 @@ module L = *) module Id = struct - let name = "Camlp4ListComprenhsion" + let name = "Camlp4ListComprehension" let version = Sys.ocaml_version diff --git a/camlp4/mkcamlp4.ml b/camlp4/mkcamlp4.ml index 6c6b4b24..8c911b12 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 00000000..ec315871 --- /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 66ccda94..37d46c2b 100755 --- a/configure +++ b/configure @@ -13,7 +13,7 @@ # # ######################################################################### -# $Id: configure 10636 2010-07-28 13:18:22Z doligez $ +# $Id: configure 11064 2011-06-04 08:13:25Z xleroy $ configure_options="$*" prefix=/usr/local @@ -304,7 +304,7 @@ case "$bytecc,$host" in bytecccompopts="-D_XOPEN_SOURCE=500";; gcc*,*-*-cygwin*) bytecccompopts="-fno-defer-pop $gcc_warnings -U_WIN32" - dllccompopts="-D_WIN32 -DCAML_DLL" + dllccompopts="-U_WIN32 -DCAML_DLL" if test $withsharedlibs = yes; then flexlink="flexlink -chain cygwin -merge-manifest" flexdir=`$flexlink -where | dos2unix` @@ -433,11 +433,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... @@ -465,8 +466,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 @@ -628,6 +629,12 @@ if test $withsharedlibs = "yes"; then sparc-*-linux*) natdynlink=true;; i686-*-kfreebsd*) natdynlink=true;; x86_64-*-kfreebsd*) natdynlink=true;; + i[345]86-*-freebsd*) natdynlink=true;; + x86_64-*-freebsd*) natdynlink=true;; + i[345]86-*-openbsd*) natdynlink=true;; + x86_64-*-openbsd*) natdynlink=true;; + i[345]86-*-netbsd*) natdynlink=true;; + x86_64-*-netbsd*) natdynlink=true;; i386-*-gnu0.3) natdynlink=true;; esac fi diff --git a/debugger/command_line.ml b/debugger/command_line.ml index c6680d7e..7fe76944 100644 --- a/debugger/command_line.ml +++ b/debugger/command_line.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: command_line.ml 10287 2010-04-20 15:47:15Z doligez $ *) +(* $Id: command_line.ml 10695 2010-09-29 16:46:54Z doligez $ *) (************************ Reading and executing commands ***************) @@ -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 1572b77b..19ce8316 100644 --- a/emacs/Makefile +++ b/emacs/Makefile @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: Makefile 9547 2010-01-22 12:48:24Z doligez $ +# $Id: Makefile 10661 2010-08-30 10:16:22Z doligez $ include ../config/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 c7eacfd1..8960203a 100644 --- a/emacs/caml-emacs.el +++ b/emacs/caml-emacs.el @@ -10,7 +10,7 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml-emacs.el 6612 2004-08-20 17:04:35Z doligez $ *) +;(* $Id: caml-emacs.el 10662 2010-08-30 15:15:33Z doligez $ *) ;; for caml-help.el (defalias 'caml-info-other-window 'info-other-window) @@ -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 f287ffa0..95622546 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 59066c1b..25316bb2 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -10,7 +10,7 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml-types.el 9540 2010-01-20 16:26:46Z doligez $ *) +;(* $Id: caml-types.el 10661 2010-08-30 10:16:22Z doligez $ *) ; An emacs-lisp complement to the "-annot" option of ocamlc and ocamlopt. @@ -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 9a9d8454..f8aa5052 100644 --- a/emacs/caml-xemacs.el +++ b/emacs/caml-xemacs.el @@ -10,7 +10,7 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml-xemacs.el 6824 2005-03-24 17:20:54Z doligez $ *) +;(* $Id: caml-xemacs.el 10662 2010-08-30 15:15:33Z doligez $ *) (require 'overlay) @@ -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 c3236253..a05cbf55 100644 --- a/emacs/caml.el +++ b/emacs/caml.el @@ -10,7 +10,7 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml.el 9153 2008-12-03 18:09:09Z doligez $ *) +;(* $Id: caml.el 11055 2011-05-20 07:40:01Z garrigue $ *) ;;; caml.el --- O'Caml code editing commands for Emacs @@ -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 49b987d0..343fdd57 100644 --- a/emacs/camldebug.el +++ b/emacs/camldebug.el @@ -10,7 +10,7 @@ ;(* *) ;(***********************************************************************) -;(* $Id: camldebug.el 10322 2010-04-28 10:33:43Z remy $ *) +;(* $Id: camldebug.el 10661 2010-08-30 10:16:22Z doligez $ *) ;;; Run camldebug under Emacs ;;; Derived from gdb.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 2da73b72..11b5e40b 100644 --- a/emacs/inf-caml.el +++ b/emacs/inf-caml.el @@ -10,7 +10,7 @@ ;(* *) ;(***********************************************************************) -;(* $Id: inf-caml.el 10317 2010-04-27 08:45:18Z remy $ *) +;(* $Id: inf-caml.el 11027 2011-05-05 11:28:57Z doligez $ *) ;;; inf-caml.el --- run the Caml toplevel in an Emacs buffer @@ -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 847106ce..116a0d3b 100644 --- a/lex/output.ml +++ b/lex/output.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: output.ml 9512 2010-01-07 15:15:07Z doligez $ *) +(* $Id: output.ml 10695 2010-09-29 16:46:54Z doligez $ *) (* Output the DFA tables and its entry points *) @@ -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 7e97db0d..a78b59dd 100644 --- a/lex/outputbis.ml +++ b/lex/outputbis.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: outputbis.ml 9512 2010-01-07 15:15:07Z doligez $ *) +(* $Id: outputbis.ml 10695 2010-09-29 16:46:54Z doligez $ *) (* Output the DFA tables and its entry points *) @@ -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 febabcda..0d3cfa96 100644 --- a/man/ocamldep.m +++ b/man/ocamldep.m @@ -1,4 +1,4 @@ -\" $Id: ocamldep.m 10444 2010-05-20 14:06:29Z doligez $ +\" $Id: ocamldep.m 10914 2011-01-04 10:33:49Z xclerc $ .TH OCAMLDEP 1 @@ -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 7a5a7043..d50274d8 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: myocamlbuild.ml 10542 2010-06-08 09:50:56Z pouillar $ *) +(* $Id: myocamlbuild.ml 10941 2011-02-08 14:07:47Z xclerc $ *) open Ocamlbuild_plugin open Command @@ -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 2385a58f..f8aab137 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 668fd812..28b7c5c4 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 e4d168bf..6a3b9ba6 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 500cacf5..1b830add 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 f66c127c..1381ca46 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 12c91d62..9653afbc 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 0256d43a..e547d44e 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 0786b479..4180755b 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 cb343bd8..91dc6c62 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 8cef4413..00000000 --- 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 2d8b0ea0..8f6e87c7 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -9,7 +9,7 @@ #(* *) #(***********************************************************************) -# $Id: Makefile 10584 2010-06-16 11:38:22Z guesdon $ +# $Id: Makefile 11020 2011-05-02 13:14:14Z guesdon $ include ../config/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 @@ -188,13 +188,12 @@ STDLIB_MLIS=../stdlib/*.mli \ ../otherlibs/bigarray/bigarray.mli \ ../otherlibs/num/num.mli -all: exe lib +all: exe lib manpages exe: $(OCAMLDOC) lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST) opt.opt: exeopt libopt - $(MAKE) manpages exeopt: $(OCAMLDOC_OPT) libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) debug: diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml index 74a3018d..3845f079 100644 --- a/ocamldoc/odoc_args.ml +++ b/ocamldoc/odoc_args.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* cvsid $Id: odoc_args.ml 10444 2010-05-20 14:06:29Z doligez $ *) +(* cvsid $Id: odoc_args.ml 11029 2011-05-09 07:29:55Z xclerc $ *) (** Command-line arguments. *) @@ -70,6 +70,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]) ; @@ -126,6 +127,8 @@ let colorize_code = ref false let html_short_functors = ref false +let charset = ref "iso-8859-1" + let with_header = ref true let with_trailer = ref true @@ -210,7 +213,7 @@ let default_man_generator = ref (None : doc_generator option) let default_dot_generator = ref (None : doc_generator option) (** 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 ; @@ -263,7 +266,8 @@ let options = ref [ "-css-style", Arg.String (fun s -> css_style := Some s), M.css_style ; "-index-only", Arg.Set index_only, M.index_only ; "-colorize-code", Arg.Set colorize_code, M.colorize_code ; - "-short-functors", Arg.Set html_short_functors, M.html_short_functors ^ + "-short-functors", Arg.Set html_short_functors, M.html_short_functors ; + "-charset", Arg.Set_string charset, (M.charset !charset)^ "\n\n *** LaTeX options ***\n"; (* latex only options *) @@ -306,7 +310,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] @@ -339,7 +370,9 @@ let parse ~html_generator ~latex_generator ~texi_generator ~man_generator ~dot_g default_texi_generator := Some texi_generator ; default_man_generator := Some man_generator ; default_dot_generator := Some dot_generator ; - 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_args.mli b/ocamldoc/odoc_args.mli index 993e545f..a3bd95f4 100644 --- a/ocamldoc/odoc_args.mli +++ b/ocamldoc/odoc_args.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_args.mli 9270 2009-05-20 11:52:42Z doligez $ *) +(* $Id: odoc_args.mli 11027 2011-05-05 11:28:57Z doligez $ *) (** Analysis of the command line arguments. *) @@ -97,6 +97,9 @@ val colorize_code : bool ref in HTML generated documentation. *) val html_short_functors : bool ref +(** Encoding used in HTML pages header. *) +val charset : string ref + (** The flag which indicates if we must generate a header (for LaTeX). *) val with_header : bool ref @@ -151,7 +154,7 @@ val info_section : string ref (** The Info directory entries to insert *) val info_entry : string list ref -(** Include all modules or only the ones on the command line, for the dot ouput. *) +(** Include all modules or only the ones on the command line, for the dot output. *) val dot_include_all : bool ref (** Generate dependency graph for types. *) diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index 01a51e83..692712cd 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_html.ml 10493 2010-06-04 05:37:50Z guesdon $ *) +(* $Id: odoc_html.ml 11023 2011-05-02 13:55:00Z guesdon $ *) (** Generation of html documentation.*) @@ -532,28 +532,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 @@ -726,8 +732,10 @@ class html = val mutable doctype = "\n" - val mutable character_encoding = - "\n" + method character_encoding () = + Printf.sprintf + "\n" + !Odoc_info.Args.charset (** The default style options. *) val mutable default_style_options = @@ -935,7 +943,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_info.mli b/ocamldoc/odoc_info.mli index 2d5cc345..46c0492b 100644 --- a/ocamldoc/odoc_info.mli +++ b/ocamldoc/odoc_info.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_info.mli 10480 2010-05-31 11:52:13Z guesdon $ *) +(* $Id: odoc_info.mli 11027 2011-05-05 11:28:57Z doligez $ *) (** Interface to the information collected in source files. *) @@ -990,6 +990,9 @@ module Args : in HTML generated documentation. *) val html_short_functors : bool ref + (** Character encoding used in HTML pages header. *) + val charset : string ref + (** The flag which indicates if we must generate a header (for LaTeX). *) val with_header : bool ref @@ -1044,7 +1047,7 @@ module Args : (** The Info directory entries to insert *) val info_entry : string list ref - (** Include all modules or only the ones on the command line, for the dot ouput. *) + (** Include all modules or only the ones on the command line, for the dot output. *) val dot_include_all : bool ref (** Generate dependency graph for types. *) diff --git a/ocamldoc/odoc_latex_style.ml b/ocamldoc/odoc_latex_style.ml index b194adb4..eb881c3b 100644 --- a/ocamldoc/odoc_latex_style.ml +++ b/ocamldoc/odoc_latex_style.ml @@ -11,81 +11,81 @@ (** The content of the LaTeX style to generate when generating LaTeX code. *) -(* $Id: odoc_latex_style.ml 9512 2010-01-07 15:15:07Z doligez $ *) +(* $Id: odoc_latex_style.ml 10695 2010-09-29 16:46:54Z doligez $ *) -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 45048d81..afd95a00 100644 --- a/ocamldoc/odoc_merge.ml +++ b/ocamldoc/odoc_merge.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_merge.ml 10480 2010-05-31 11:52:13Z guesdon $ *) +(* $Id: odoc_merge.ml 10871 2010-11-30 08:08:24Z xclerc $ *) (** Merge of information from [.ml] and [.mli] for a module.*) @@ -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 5d3d792d..9ec4b038 100644 --- a/ocamldoc/odoc_messages.ml +++ b/ocamldoc/odoc_messages.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_messages.ml 10480 2010-05-31 11:52:13Z guesdon $ *) +(* $Id: odoc_messages.ml 11027 2011-05-05 11:28:57Z doligez $ *) (** The messages of the application. *) @@ -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 306adbb9..e0498de8 100644 --- a/ocamldoc/odoc_types.ml +++ b/ocamldoc/odoc_types.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_types.ml 10480 2010-05-31 11:52:13Z guesdon $ *) +(* $Id: odoc_types.ml 10867 2010-11-29 12:49:46Z xclerc $ *) type ref_kind = RK_module @@ -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 9dbef9a7..3b5a3a51 100644 --- a/ocamldoc/odoc_types.mli +++ b/ocamldoc/odoc_types.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_types.mli 10480 2010-05-31 11:52:13Z guesdon $ *) +(* $Id: odoc_types.mli 10867 2010-11-29 12:49:46Z xclerc $ *) (** Types for the information collected in comments. *) @@ -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 92f29e8c..c70f81a5 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 4b30a9a1..19e240c4 100644 --- a/otherlibs/bigarray/bigarray_stubs.c +++ b/otherlibs/bigarray/bigarray_stubs.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: bigarray_stubs.c 9153 2008-12-03 18:09:09Z doligez $ */ +/* $Id: bigarray_stubs.c 11037 2011-05-12 14:34:05Z xleroy $ */ #include #include @@ -529,8 +529,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 7096389f..889f7609 100644 --- a/otherlibs/bigarray/mmap_unix.c +++ b/otherlibs/bigarray/mmap_unix.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: mmap_unix.c 10223 2010-04-01 07:36:49Z shinwell $ */ +/* $Id: mmap_unix.c 10648 2010-08-18 12:46:09Z doligez $ */ #include #include @@ -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 b1d8a501..b2d8c36b 100644 --- a/otherlibs/bigarray/mmap_win32.c +++ b/otherlibs/bigarray/mmap_win32.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: mmap_win32.c 9547 2010-01-22 12:48:24Z doligez $ */ +/* $Id: mmap_win32.c 11066 2011-06-04 13:53:24Z xleroy $ */ #include #include @@ -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 ba0e54e5..00000000 --- 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 5b009b3f..c366cd8e 100644 --- a/otherlibs/labltk/browser/shell.ml +++ b/otherlibs/labltk/browser/shell.ml @@ -12,7 +12,7 @@ (* *) (*************************************************************************) -(* $Id: shell.ml 7327 2006-01-18 13:26:03Z garrigue $ *) +(* $Id: shell.ml 10659 2010-08-28 06:10:22Z garrigue $ *) open StdLabels module Unix = UnixLabels @@ -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 bd903482..6c0c9432 100644 --- a/otherlibs/num/big_int.ml +++ b/otherlibs/num/big_int.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: big_int.ml 10327 2010-04-29 13:53:01Z xleroy $ *) +(* $Id: big_int.ml 10649 2010-08-18 13:22:48Z doligez $ *) open Int_misc open Nat @@ -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 2e65ecd0..fbef6ea0 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 e7d528f6..18cc819b 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 42875bdc..42dbc3c0 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 a4e82679..29c59b98 100644 --- a/otherlibs/unix/lseek.c +++ b/otherlibs/unix/lseek.c @@ -11,13 +11,14 @@ /* */ /***********************************************************************/ -/* $Id: lseek.c 10223 2010-04-01 07:36:49Z shinwell $ */ +/* $Id: lseek.c 10647 2010-08-18 12:44:33Z doligez $ */ #include #include #include #include #include +#include #include "unixsupport.h" #ifdef HAS_UNISTD diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index b8a83f06..8045d3f8 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: unix.mli 10450 2010-05-21 12:00:49Z doligez $ *) +(* $Id: unix.mli 10972 2011-03-06 16:17:09Z weis $ *) (** Interface to the Unix system *) @@ -911,7 +911,7 @@ type socket_domain = | PF_INET (** Internet domain (IPv4) *) | PF_INET6 (** Internet domain (IPv6) *) (** The type of socket domains. Not all platforms support - IPv6 sockets (type [PF_INET6]). *) + IPv6 sockets (type [PF_INET6]). *) type socket_type = SOCK_STREAM (** Stream socket *) @@ -921,7 +921,9 @@ type socket_type = (** The type of socket kinds, specifying the semantics of communications. *) -type sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int +type sockaddr = + ADDR_UNIX of string + | ADDR_INET of inet_addr * int (** The type of socket addresses. [ADDR_UNIX name] is a socket address in the Unix domain; [name] is a file name in the file system. [ADDR_INET(addr,port)] is a socket address in the Internet @@ -1270,7 +1272,7 @@ val tcgetattr : file_descr -> terminal_io file descriptor. *) type setattr_when = - TCSANOW + TCSANOW | TCSADRAIN | TCSAFLUSH diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli index e8dc6b37..46a0a53a 100644 --- a/otherlibs/unix/unixLabels.mli +++ b/otherlibs/unix/unixLabels.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: unixLabels.mli 10450 2010-05-21 12:00:49Z doligez $ *) +(* $Id: unixLabels.mli 10971 2011-03-06 16:15:34Z weis $ *) (** Interface to the Unix system. To use as replacement to default {!Unix} module, @@ -146,7 +146,9 @@ type process_status = Unix.process_status = | WSTOPPED of int (** The process was stopped by a signal; the argument is the signal number. *) -(** The termination status of a process. *) +(** The termination status of a process. See module {!Sys} for the + definitions of the standard signal numbers. Note that they are + not the numbers used by the OS. *) type wait_flag = Unix.wait_flag = @@ -167,11 +169,11 @@ val execve : prog:string -> args:string array -> env:string array -> 'a environment to the program executed. *) val execvp : prog:string -> args:string array -> 'a -(** Same as {!UnixLabels.execv} respectively, except that +(** Same as {!UnixLabels.execv}, except that the program is searched in the path. *) val execvpe : prog:string -> args:string array -> env:string array -> 'a -(** Same as {!UnixLabels.execvp} respectively, except that +(** Same as {!UnixLabels.execve}, except that the program is searched in the path. *) val fork : unit -> int @@ -183,7 +185,7 @@ val wait : unit -> int * process_status and termination status. *) val waitpid : mode:wait_flag list -> int -> int * process_status -(** Same as {!UnixLabels.wait}, but waits for the process whose pid is given. +(** Same as {!UnixLabels.wait}, but waits for the child process whose pid is given. A pid of [-1] means wait for any child. A pid of [0] means wait for any child in the same process group as the current process. @@ -472,7 +474,6 @@ val clear_close_on_exec : file_descr -> unit See {!UnixLabels.set_close_on_exec}.*) - (** {6 Directories} *) @@ -670,7 +671,6 @@ val lockf : file_descr -> mode:lock_command -> len:int -> unit the functions {!Sys.signal} and {!Sys.set_signal}. *) - val kill : pid:int -> signal:int -> unit (** [kill pid sig] sends signal number [sig] to the process with id [pid]. *) @@ -764,7 +764,8 @@ val times : unit -> process_times val utimes : string -> access:float -> modif:float -> unit (** Set the last access time (second arg) and last modification time (third arg) for a file. Times are expressed in seconds from - 00:00:00 GMT, Jan. 1, 1970. *) + 00:00:00 GMT, Jan. 1, 1970. A time of [0.0] is interpreted as the + current time. *) type interval_timer = Unix.interval_timer = ITIMER_REAL @@ -823,6 +824,16 @@ val getgroups : unit -> int array (** Return the list of groups to which the user executing the process belongs. *) +val setgroups : int array -> unit + (** [setgroups groups] sets the supplementary group IDs for the + calling process. Appropriate privileges are required. *) + +val initgroups : string -> int -> unit + (** [initgroups user group] initializes the group access list by + reading the group database /etc/group and using all groups of + which [user] is a member. The additional group [group] is also + added to the list. *) + type passwd_entry = Unix.passwd_entry = { pw_name : string; pw_passwd : string; @@ -903,7 +914,8 @@ type socket_domain = Unix.socket_domain = PF_UNIX (** Unix domain *) | PF_INET (** Internet domain (IPv4) *) | PF_INET6 (** Internet domain (IPv6) *) -(** The type of socket domains. *) +(** The type of socket domains. Not all platforms support + IPv6 sockets (type [PF_INET6]). *) type socket_type = Unix.socket_type = SOCK_STREAM (** Stream socket *) diff --git a/otherlibs/win32unix/channels.c b/otherlibs/win32unix/channels.c index 2ff62e7f..95af7ac3 100644 --- a/otherlibs/win32unix/channels.c +++ b/otherlibs/win32unix/channels.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: channels.c 9547 2010-01-22 12:48:24Z doligez $ */ +/* $Id: channels.c 11030 2011-05-09 11:38:43Z doligez $ */ #include #include @@ -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 4890ae0b..87c84756 100644 --- a/otherlibs/win32unix/close.c +++ b/otherlibs/win32unix/close.c @@ -11,10 +11,13 @@ /* */ /***********************************************************************/ -/* $Id: close.c 4765 2002-04-30 15:00:48Z xleroy $ */ +/* $Id: close.c 11030 2011-05-09 11:38:43Z doligez $ */ #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/location.ml b/parsing/location.ml index a9b73597..d1ad9b55 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: location.ml 8768 2008-01-11 16:13:18Z doligez $ *) +(* $Id: location.ml 11050 2011-05-17 16:14:39Z doligez $ *) open Lexing diff --git a/parsing/parser.mly b/parsing/parser.mly index e958b920..eabc97d8 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: parser.mly 10536 2010-06-07 15:32:32Z doligez $ */ +/* $Id: parser.mly 11016 2011-04-29 04:56:21Z furuse $ */ /* The parser definition */ @@ -1424,7 +1424,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 af6c9f28..e27058b1 100644 --- a/stdlib/arg.ml +++ b/stdlib/arg.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: arg.ml 8768 2008-01-11 16:13:18Z doligez $ *) +(* $Id: arg.ml 11028 2011-05-09 07:28:57Z xclerc $ *) type key = string type doc = string @@ -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 778ef312..ca70fdd7 100644 --- a/stdlib/arg.mli +++ b/stdlib/arg.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: arg.mli 8768 2008-01-11 16:13:18Z doligez $ *) +(* $Id: arg.mli 11031 2011-05-09 11:39:33Z doligez $ *) (** Parsing of command line arguments. @@ -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 1695e560..f5c47219 100644 --- a/stdlib/filename.mli +++ b/stdlib/filename.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: filename.mli 10457 2010-05-21 18:30:12Z doligez $ *) +(* $Id: filename.mli 10957 2011-02-21 15:17:38Z xclerc $ *) (** Operations on file names. *) @@ -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 e09d9fc2..2d973461 100644 --- a/stdlib/format.mli +++ b/stdlib/format.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: format.mli 10457 2010-05-21 18:30:12Z doligez $ *) +(* $Id: format.mli 10970 2011-03-06 16:13:14Z weis $ *) (** Pretty printing. @@ -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 11e169e0..d11ca97c 100644 --- a/stdlib/parsing.ml +++ b/stdlib/parsing.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: parsing.ml 9270 2009-05-20 11:52:42Z doligez $ *) +(* $Id: parsing.ml 10908 2010-12-22 13:05:55Z xleroy $ *) (* The parsing engine *) @@ -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 ae85bd03..e4e1513f 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: pervasives.mli 10548 2010-06-09 10:26:19Z weis $ *) +(* $Id: pervasives.mli 11048 2011-05-17 13:31:32Z doligez $ *) (** The initially opened module. @@ -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]. *) @@ -505,7 +505,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} *) @@ -858,9 +858,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 e253c9f3..a62c48b5 100644 --- a/stdlib/printf.ml +++ b/stdlib/printf.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: printf.ml 9463 2009-12-09 08:28:59Z weis $ *) +(* $Id: printf.ml 10969 2011-03-06 16:11:50Z weis $ *) external format_float: string -> float -> string = "caml_format_float" @@ -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 1bf2a9ce..ca5dc14d 100644 --- a/stdlib/printf.mli +++ b/stdlib/printf.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: printf.mli 10457 2010-05-21 18:30:12Z doligez $ *) +(* $Id: printf.mli 10968 2011-03-06 16:10:59Z weis $ *) (** Formatted output functions. *) @@ -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/scanf.mli b/stdlib/scanf.mli index 9ab1f8d9..458ebd49 100644 --- a/stdlib/scanf.mli +++ b/stdlib/scanf.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: scanf.mli 10457 2010-05-21 18:30:12Z doligez $ *) +(* $Id: scanf.mli 10967 2011-03-06 16:08:33Z weis $ *) (** Formatted input functions. *) @@ -99,35 +99,42 @@ type scanbuf = in_channel;; Note: a scanning action may often require to examine one character in advance; when this ``lookahead'' character does not belong to the token read, it is stored back in the scanning buffer and becomes the next - character read. *) + character yet to be read. *) val stdin : in_channel;; -(** The standard input notion for the module [Scanf]. - [stdin] is equivalent to [Scanning.from_channel Pervasives.stdin]. - - Note: when input is read interactively from [stdin], the newline character - that triggers the evaluation is incorporated in the input; thus, scanning - specifications must properly skip this character (simply add a ['\n'] - as the last character of the format string). +(** The standard input notion for the [Scanf] module. + [Scanning.stdin] is the formatted input channel attached to + [Pervasives.stdin]. + + Note: in the interactive system, when input is read from [stdin], the + newline character that triggers the evaluation is incorporated in the + input; thus, the scanning specifications must properly skip this + additional newline character (for instance, simply add a ['\n'] as the + last character of the format string). @since 3.12.0 *) val open_in : string -> in_channel;; -(** Bufferized file reading in text mode. The efficient and usual - way to scan text mode files (in effect, [from_file] returns a - scanning buffer that reads characters in large chunks, rather than one - character at a time as buffers returned by [from_channel] below do). - [Scanning.from_file fname] returns a scanning buffer which reads - from the given file [fname] in text mode. +(** [Scanning.open_in fname] returns a formatted input channel for bufferized + reading in text mode of file [fname]. + + Note: + [open_in] returns a formatted input channel that efficiently reads + characters in large chunks; in contrast, [from_channel] below returns + formatted input channels that must read one character at a time, leading + to a much slower scanning rate. @since 3.12.0 *) val open_in_bin : string -> in_channel;; -(** Bufferized file reading in binary mode. @since 3.12.0 *) +(** [Scanning.open_in_bin fname] returns a formatted input channel for bufferized + reading in binary mode of file [fname]. + @since 3.12.0 +*) val close_in : in_channel -> unit;; -(** Close the [Pervasives.input_channel] associated with the given - [Scanning.in_channel]. +(** Closes the [Pervasives.input_channel] associated with the given + [Scanning.in_channel] formatted input channel. @since 3.12.0 *) @@ -143,8 +150,8 @@ val from_string : string -> in_channel;; The end-of-input condition is set when the end of the string is reached. *) val from_function : (unit -> char) -> in_channel;; -(** [Scanning.from_function f] returns a scanning buffer with the given - function as its reading method. +(** [Scanning.from_function f] returns a formatted input channel with the + given function as its reading method. When scanning needs one more character, the given function is called. @@ -165,7 +172,7 @@ val beginning_of_input : in_channel -> bool;; the given formatted input channel. *) val name_of_input : in_channel -> string;; -(** [Scanning.file_name_of_input ic] returns the name of the character source +(** [Scanning.name_of_input ic] returns the name of the character source for the formatted input channel [ic]. @since 3.09.0 *) @@ -223,7 +230,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;; (** The format is a character string which contains three types of objects: - plain characters, which are simply matched with the characters of the - input (with a special case for {!Scanf.space} and line feed), + input (with a special case for space and line feed, see {!Scanf.space}), - conversion specifications, each of which causes reading and conversion of one argument for the function [f] (see {!Scanf.conversion}), - scanning indications to specify boundaries of tokens @@ -264,11 +271,11 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;; - [x] or [X]: reads an unsigned hexadecimal integer ([[0-9a-f]+] or [[0-9A-F]+]). - [o]: reads an unsigned octal integer ([[0-7]+]). - [s]: reads a string argument that spreads as much as possible, until the - following bounding condition holds: - - a whitespace has been found (see {!Scanf.space}), - - a scanning indication (see scanning {!Scanf.indication}) has been - encountered, - - the end-of-input has been reached. + following bounding condition holds: {ul + {- a whitespace has been found (see {!Scanf.space}),} + {- a scanning indication (see scanning {!Scanf.indication}) has been + encountered,} + {- the end-of-input has been reached.}} Hence, this conversion always succeeds: it returns an empty string, if the bounding condition holds when the scan begins. - [S]: reads a delimited string argument (delimiters and special @@ -314,23 +321,27 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;; The format string read must have the same type as the format string specification [fmt]. For instance, ["%{ %i %}"] reads any format string that can read a value of - type [int]; hence [Scanf.sscanf "fmt:\"number is %u\"" "fmt:%{%i%}"] - succeeds and returns the format string ["number is %u"]. + type [int]; hence, if [s] is the string ["fmt:\"number is %u\""], then + [Scanf.sscanf s "fmt: %{%i%}"] succeeds and returns the format string + ["number is %u"]. - [\( fmt %\)]: scanning format substitution. - Reads a format string to read with it instead of [fmt]. + Reads a format string and then goes on scanning with the format string + read, instead of using [fmt]. The format string read must have the same type as the format string - specification [fmt] that is replaces. + specification [fmt] that it replaces. For instance, ["%( %i %)"] reads any format string that can read a value of type [int]. Returns the format string read, and the value read using the format string read. - Hence, [Scanf.sscanf "\"%4d\"1234.00" "%(%i%)" - (fun fmt i -> fmt, i)] evaluates to [("%4d", 1234)]. + Hence, if [s] is the string ["\"%4d\"1234.00"], then + [Scanf.sscanf s "%(%i%)" (fun fmt i -> fmt, i)] evaluates to + [("%4d", 1234)]. If the special flag [_] is used, the conversion discards the format string read and only returns the value read with the format string read. - Hence, [Scanf.sscanf "\"%4d\"1234.00" "%_(%i%)"] is simply - equivalent to [Scanf.sscanf "1234.00" "%4d"]. + Hence, if [s] is the string ["\"%4d\"1234.00"], then + [Scanf.sscanf s "%_(%i%)"] is simply equivalent to + [Scanf.sscanf "1234.00" "%4d"]. - [l]: returns the number of lines read so far. - [n]: returns the number of characters read so far. - [N] or [L]: returns the number of tokens read so far. @@ -341,8 +352,8 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;; Following the [%] character that introduces a conversion, there may be the special flag [_]: the conversion that follows occurs as usual, but the resulting value is discarded. - For instance, if [f] is the function [fun i -> i + 1], then - [Scanf.sscanf "x = 1" "%_s = %i" f] returns [2]. + For instance, if [f] is the function [fun i -> i + 1], and [s] is the + string ["x = 1"], then [Scanf.sscanf s "%_s = %i" f] returns [2]. The field width is composed of an optional integer literal indicating the maximal width of the token to read. @@ -419,7 +430,7 @@ val fscanf : Pervasives.in_channel -> ('a, 'b, 'c, 'd) scanner;; Warning: since all formatted input functions operate from a {e formatted input channel}, be aware that each [fscanf] invocation will operate with a formatted input channel reading from the given channel. This extra level - of bufferization can lead to strange scanning behaviour if you use low + of bufferization can lead to a strange scanning behaviour if you use low level primitives on the channel (reading characters, seeking the reading position, and so on). @@ -439,7 +450,7 @@ val kscanf : (** Same as {!Scanf.bscanf}, but takes an additional function argument [ef] that is called in case of error: if the scanning process or some conversion fails, the scanning function aborts and calls the - error handling function [ef] with the scanning buffer and the + error handling function [ef] with the formatted input channel and the exception that aborted the scanning process as arguments. *) (** {6 Reading format strings from input} *) diff --git a/stdlib/string.ml b/stdlib/string.ml index 767562d7..02ba00a8 100644 --- a/stdlib/string.ml +++ b/stdlib/string.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: string.ml 9153 2008-12-03 18:09:09Z doligez $ *) +(* $Id: string.ml 11043 2011-05-16 15:00:33Z doligez $ *) (* String operations *) @@ -180,4 +180,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 b6bf631a..455f31ce 100644 --- a/stdlib/sys.mli +++ b/stdlib/sys.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: sys.mli 10457 2010-05-21 18:30:12Z doligez $ *) +(* $Id: sys.mli 10715 2010-10-12 09:55:46Z doligez $ *) (** System interface. *) @@ -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/testsuite/Makefile b/testsuite/Makefile index d7a97569..283e0746 100644 --- a/testsuite/Makefile +++ b/testsuite/Makefile @@ -1,4 +1,4 @@ -# $Id$ +# $Id: Makefile 10713 2010-10-08 11:53:19Z doligez $ BASEDIR=${PWD} NO_PRINT=`($(MAKE) empty --no-print-directory > /dev/null 2>&1) && echo '--no-print-directory' || echo ''` diff --git a/testsuite/interactive/lib-gc/alloc.ml b/testsuite/interactive/lib-gc/alloc.ml index 4f607fb2..83ccbe35 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: alloc.ml 10713 2010-10-08 11:53:19Z doligez $ *) (* Random allocation test *) diff --git a/testsuite/lib/Makefile b/testsuite/lib/Makefile index 52b50207..9b8257ad 100644 --- a/testsuite/lib/Makefile +++ b/testsuite/lib/Makefile @@ -1,4 +1,4 @@ -# $Id$ +# $Id: Makefile 10713 2010-10-08 11:53:19Z doligez $ compile: testing.cmi testing.cmo testing.cmx diff --git a/testsuite/lib/testing.ml b/testsuite/lib/testing.ml index 55da6f6d..ffbc62ed 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.ml 10713 2010-10-08 11:53:19Z doligez $ *) (* Testing auxilliaries. *) diff --git a/testsuite/lib/testing.mli b/testsuite/lib/testing.mli index c3880f08..4e0e6d7e 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.mli 10713 2010-10-08 11:53:19Z doligez $ *) (* Testing auxilliaries. *) diff --git a/testsuite/makefiles/Makefile.common b/testsuite/makefiles/Makefile.common index a1abd1aa..794878ac 100644 --- a/testsuite/makefiles/Makefile.common +++ b/testsuite/makefiles/Makefile.common @@ -1,4 +1,4 @@ -# $Id$ +# $Id: Makefile.common 10713 2010-10-08 11:53:19Z doligez $ TOPDIR=$(BASEDIR)/.. diff --git a/testsuite/makefiles/Makefile.okbad b/testsuite/makefiles/Makefile.okbad index 833cfab3..959b549a 100644 --- a/testsuite/makefiles/Makefile.okbad +++ b/testsuite/makefiles/Makefile.okbad @@ -1,4 +1,4 @@ -# $Id$ +# $Id: Makefile.okbad 10713 2010-10-08 11:53:19Z doligez $ default: compile diff --git a/testsuite/makefiles/Makefile.one b/testsuite/makefiles/Makefile.one index 4921d7df..7f0ac0a1 100644 --- a/testsuite/makefiles/Makefile.one +++ b/testsuite/makefiles/Makefile.one @@ -1,4 +1,4 @@ -# $Id$ +# $Id: Makefile.one 10713 2010-10-08 11:53:19Z doligez $ CMI_FILES=$(MODULES:=.cmi) CMO_FILES=$(MODULES:=.cmo) diff --git a/testsuite/makefiles/Makefile.several b/testsuite/makefiles/Makefile.several index 09925132..098b5d12 100644 --- a/testsuite/makefiles/Makefile.several +++ b/testsuite/makefiles/Makefile.several @@ -1,4 +1,4 @@ -# $Id$ +# $Id: Makefile.several 10713 2010-10-08 11:53:19Z doligez $ CC=$(NATIVECC) $(NATIVECCCOMPOPTS) FC=$(FORTAN_COMPILER) diff --git a/testsuite/makefiles/Makefile.toplevel b/testsuite/makefiles/Makefile.toplevel index 2302b196..0bcc0a80 100644 --- a/testsuite/makefiles/Makefile.toplevel +++ b/testsuite/makefiles/Makefile.toplevel @@ -1,4 +1,4 @@ -# $Id$ +# $Id: Makefile.toplevel 10713 2010-10-08 11:53:19Z doligez $ default: @for file in *.ml; do \ diff --git a/testsuite/tests/asmcomp/.svnignore b/testsuite/tests/asmcomp/.svnignore new file mode 100755 index 00000000..dcb3b20e --- /dev/null +++ b/testsuite/tests/asmcomp/.svnignore @@ -0,0 +1,17 @@ +#!/bin/sh + +svn propset svn:ignore -F - . < Parsecmm.token diff --git a/testsuite/tests/asmcomp/lexcmm.mll b/testsuite/tests/asmcomp/lexcmm.mll index a9d17dd3..ea0af554 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: lexcmm.mll 10713 2010-10-08 11:53:19Z doligez $ *) { open Parsecmm diff --git a/testsuite/tests/asmcomp/m68k.S b/testsuite/tests/asmcomp/m68k.S index 8905da1b..ffe3d342 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: m68k.S 10713 2010-10-08 11:53:19Z doligez $ | 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 7f0e7174..aef888f0 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: main.c 10713 2010-10-08 11:53:19Z doligez $ */ #include #include diff --git a/testsuite/tests/asmcomp/main.ml b/testsuite/tests/asmcomp/main.ml index 7017c35d..f5ca538c 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: main.ml 10713 2010-10-08 11:53:19Z doligez $ *) open Clflags diff --git a/testsuite/tests/asmcomp/mainarith.c b/testsuite/tests/asmcomp/mainarith.c index efa48ba0..338f8428 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: mainarith.c 10713 2010-10-08 11:53:19Z doligez $ */ #include #include diff --git a/testsuite/tests/asmcomp/mips.s b/testsuite/tests/asmcomp/mips.s index d8e93565..22e5ab8e 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: mips.s 10713 2010-10-08 11:53:19Z doligez $ */ .globl call_gen_code .ent call_gen_code diff --git a/testsuite/tests/asmcomp/parsecmm.mly b/testsuite/tests/asmcomp/parsecmm.mly index 6ed2f8ff..23131180 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: parsecmm.mly 10713 2010-10-08 11:53:19Z doligez $ */ /* A simple parser for C-- */ diff --git a/testsuite/tests/asmcomp/parsecmmaux.ml b/testsuite/tests/asmcomp/parsecmmaux.ml index a87432e4..a911414e 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: parsecmmaux.ml 10713 2010-10-08 11:53:19Z doligez $ *) (* Auxiliary functions for parsing *) diff --git a/testsuite/tests/asmcomp/parsecmmaux.mli b/testsuite/tests/asmcomp/parsecmmaux.mli index 941ebcb4..642fa885 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: parsecmmaux.mli 10713 2010-10-08 11:53:19Z doligez $ *) (* Auxiliary functions for parsing *) diff --git a/testsuite/tests/asmcomp/power-aix.S b/testsuite/tests/asmcomp/power-aix.S index ea153083..41c1679e 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: power-aix.S 10713 2010-10-08 11:53:19Z doligez $ .csect .text[PR] diff --git a/testsuite/tests/asmcomp/power-elf.S b/testsuite/tests/asmcomp/power-elf.S index c7ddeef7..5ddfd607 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: power-elf.S 10713 2010-10-08 11:53:19Z doligez $ */ /* 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 a9b8044b..0a62f6ae 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: power-rhapsody.S 10713 2010-10-08 11:53:19Z doligez $ */ /* 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 043e607f..b7d7cc10 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: quicksort.cmm 10713 2010-10-08 11:53:19Z doligez $ *) (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 4d80cd58..f027cad1 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: quicksort2.cmm 10713 2010-10-08 11:53:19Z doligez $ *) (function "cmp" (i: int j: int) (- i j)) diff --git a/testsuite/tests/asmcomp/soli.cmm b/testsuite/tests/asmcomp/soli.cmm index 4716e4f2..ff0b3d83 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: soli.cmm 10713 2010-10-08 11:53:19Z doligez $ *) ("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 54d81c1c..4f36a37a 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: sparc.S 10713 2010-10-08 11:53:19Z doligez $ */ #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 04869792..2c727dc8 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: tagged-fib.cmm 10713 2010-10-08 11:53:19Z doligez $ *) (function "fib" (n: int) (if (< n 5) diff --git a/testsuite/tests/asmcomp/tagged-integr.cmm b/testsuite/tests/asmcomp/tagged-integr.cmm index 054c78d7..14268d34 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: tagged-integr.cmm 10713 2010-10-08 11:53:19Z doligez $ *) ("res_square": skip 8) ("h": skip 8) diff --git a/testsuite/tests/asmcomp/tagged-quicksort.cmm b/testsuite/tests/asmcomp/tagged-quicksort.cmm index 6b74753e..f828b45c 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: tagged-quicksort.cmm 10713 2010-10-08 11:53:19Z doligez $ *) (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 5e04b739..bc6785a4 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: tagged-tak.cmm 10713 2010-10-08 11:53:19Z doligez $ *) (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 de236fc8..3d5ea420 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: tak.cmm 10713 2010-10-08 11:53:19Z doligez $ *) (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 afad5297..6c45217e 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: tformat.ml 10713 2010-10-08 11:53:19Z doligez $ A testbed file for the module Format. diff --git a/testsuite/tests/basic-private/length.ml b/testsuite/tests/basic-private/length.ml index 945d05d1..8f7b8958 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: length.ml 10713 2010-10-08 11:53:19Z doligez $ 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 2215ec8f..b88a7cd4 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: length.mli 10713 2010-10-08 11:53:19Z doligez $ 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 a428e207..3ab07500 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: tlength.ml 10713 2010-10-08 11:53:19Z doligez $ A testbed file for private type abbreviation definitions. diff --git a/testsuite/tests/basic/maps.ml b/testsuite/tests/basic/maps.ml index cb0e989b..c7717678 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: maps.ml 10713 2010-10-08 11:53:19Z doligez $ *) 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 379b9e82..635303df 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: sets.ml 10713 2010-10-08 11:53:19Z doligez $ *) 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 00000000..4394099f --- /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 c3eae9f9..e01b1e5b 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: taku.ml 10713 2010-10-08 11:53:19Z doligez $ *) 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 5dd4e19d..3c3e4488 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: weaktest.ml 10713 2010-10-08 11:53:19Z doligez $ *) 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 00000000..95106ce6 --- /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 00000000..79ba26d8 --- /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 00000000..149c289b --- /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 00000000..175bc8b7 --- /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/runtime-errors/.svnignore b/testsuite/tests/runtime-errors/.svnignore new file mode 100755 index 00000000..ceeffd0d --- /dev/null +++ b/testsuite/tests/runtime-errors/.svnignore @@ -0,0 +1,11 @@ +#!/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: lib.ml 10713 2010-10-08 11:53:19Z doligez $ *) diff --git a/testsuite/tests/tool-ocaml/t301-object.ml b/testsuite/tests/tool-ocaml/t301-object.ml index 6cef9bed..8a64a831 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: t301-object.ml 10713 2010-10-08 11:53:19Z doligez $ *) 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: t301-object.ml 10713 2010-10-08 11:53:19Z doligez $ *) diff --git a/testsuite/tests/tool-ocamldoc/.svnignore b/testsuite/tests/tool-ocamldoc/.svnignore new file mode 100755 index 00000000..eee23b68 --- /dev/null +++ b/testsuite/tests/tool-ocamldoc/.svnignore @@ -0,0 +1,14 @@ +#!/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 00000000..4394099f --- /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,10 @@ 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"; "-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 6b78a689..8374439a 100644 --- a/tools/ocamlmklib.mlp +++ b/tools/ocamlmklib.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ocamlmklib.mlp 10444 2010-05-20 14:06:29Z doligez $ *) +(* $Id: ocamlmklib.mlp 10695 2010-09-29 16:46:54Z doligez $ *) open Printf open Myocamlbuild_config @@ -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 5f05f1da..24bbb7d9 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ctype.ml 10605 2010-06-24 08:43:39Z garrigue $ *) +(* $Id: ctype.ml 10702 2010-10-02 08:56:39Z garrigue $ *) (* Operations on core types *) @@ -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 05d959d1..fef23840 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ctype.mli 10541 2010-06-08 08:43:38Z garrigue $ *) +(* $Id: ctype.mli 10669 2010-09-06 06:34:13Z garrigue $ *) (* Operations on core types *) @@ -115,6 +115,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 4a52484a..dd4887e4 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: env.ml 10328 2010-04-30 01:56:21Z garrigue $ *) +(* $Id: env.ml 11062 2011-06-01 22:23:56Z doligez $ *) (* Environment handling *) @@ -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 763bf2b8..add376c9 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: oprint.ml 10486 2010-05-31 13:18:11Z xclerc $ *) +(* $Id: oprint.ml 11051 2011-05-18 15:01:07Z xclerc $ *) open Format open Outcometree @@ -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 8d542df7..08280c82 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: printtyp.ml 10333 2010-04-30 07:11:27Z garrigue $ *) +(* $Id: printtyp.ml 10703 2010-10-02 08:58:23Z garrigue $ *) (* Printing functions *) @@ -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 334d1492..ad36db82 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typeclass.ml 10422 2010-05-18 17:25:02Z frisch $ *) +(* $Id: typeclass.ml 10702 2010-10-02 08:56:39Z garrigue $ *) open Misc open Parsetree @@ -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 3322b1bc..ca74fbb8 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typedecl.ml 10458 2010-05-24 06:52:16Z garrigue $ *) +(* $Id: typedecl.ml 10669 2010-09-06 06:34:13Z garrigue $ *) (**** Typing of type definitions ****) @@ -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 5cc7187d..cb16d653 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typedecl.mli 10447 2010-05-21 03:36:52Z garrigue $ *) +(* $Id: typedecl.mli 10669 2010-09-06 06:34:13Z garrigue $ *) (* Typing of type definitions and primitive definitions *) @@ -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 3e69aad8..b774b22a 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typemod.ml 10532 2010-06-07 08:24:02Z garrigue $ *) +(* $Id: typemod.ml 10706 2010-10-07 02:22:19Z garrigue $ *) (* Type-checking of the module language *) @@ -91,6 +91,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 = @@ -113,7 +123,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 @@ -121,7 +131,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 _)) @@ -131,10 +141,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 @@ -147,7 +157,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 @@ -316,7 +326,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