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
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 \
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
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
+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:
----------------------
* First public release.
-$Id: Changes 10613 2010-07-02 08:44:04Z frisch $
+$Id: Changes 11083 2011-06-11 07:24:12Z xleroy $
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".
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).
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
----
-$Id: README 9547 2010-01-22 12:48:24Z doligez $
+$Id: README 11017 2011-04-29 09:10:12Z doligez $
-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 $
(* *)
(***********************************************************************)
-(* $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 *)
| 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) ->
| _ ->
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`
| 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
` 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
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 *)
(* *)
(***********************************************************************)
-(* $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 *)
| 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
| _ ->
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;
| 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
` 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
(* *)
(***********************************************************************)
-(* $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 *)
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
(* *)
(***********************************************************************)
-(* $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 *)
| ((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),
(* *)
(***********************************************************************)
-(* $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-- *)
| 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 *)
(* *)
(***********************************************************************)
-(* $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 *)
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,
(* *)
(***********************************************************************)
-(* $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 *)
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 *)
(* *)
(***********************************************************************)
-(* $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. *)
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 ->
(* *)
(***********************************************************************)
-(* $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. *)
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
/* */
/***********************************************************************/
-/* $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 */
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
;
;*********************************************************************
-; $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
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
#!/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
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)
# #
# 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`/..
#!/bin/sh
-# $Id$
+# $Id: camlp4-mkCamlp4Ast.sh 11040 2011-05-13 08:37:04Z doligez $
set -e
cd `dirname $0`/..
# #
# 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`/..
# #
# 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
$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 ..
# #
#########################################################################
-# $Id: install.sh 10443 2010-05-20 09:44:25Z doligez $
+# $Id: install.sh 10856 2010-11-25 13:57:43Z xclerc $
set -e
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
# #
# 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`/..
# #
# 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`/..
# #
# 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`/..
# #
# 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=""
# #
#########################################################################
-# $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
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 \
# #
# 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: 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. *)
| 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))
(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' =
| 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
(* *)
(***********************************************************************)
-(* $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. *)
begin try
(* The bytecode *)
output_string outchan "\
-#ifdef __cplusplus\n\
-extern \"C\" {\n\
-#endif\n\
-#include <caml/mlvalues.h>\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 <caml/mlvalues.h>\
+\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;
(* 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;
(* *)
(***********************************************************************)
-(* $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. *)
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 ->
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
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
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;
(* 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
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
(* *)
(***********************************************************************)
-(* $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
| 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
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
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
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
| 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)
(* *)
(***********************************************************************)
-(* $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 *)
| 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
(* *)
(***********************************************************************)
-(* $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
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 =
(* *)
(***********************************************************************)
-(* $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. *)
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) ->
(* 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
| 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
(* 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
| 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
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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
"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
| 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) ->
(* *)
(***********************************************************************)
-(* $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 *)
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 _}) ->
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
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, _) ->
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 ->
/* */
/***********************************************************************/
-/* $Id: compare.c 8768 2008-01-11 16:13:18Z doligez $ */
+/* $Id: compare.c 11037 2011-05-12 14:34:05Z xleroy $ */
#include <string.h>
#include <stdlib.h>
if (Is_long(v2))
return Long_val(v1) - Long_val(v2);
/* Subtraction above cannot overflow and cannot result in UNORDERED */
- if (Is_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 */
}
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;
}
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;
/* */
/***********************************************************************/
-/* $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
#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).
/* */
/***********************************************************************/
-/* $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
/*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
#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)))
/* */
/***********************************************************************/
-/* $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 <stdio.h>
+#include <stdlib.h>
#include "alloc.h"
#include "fail.h"
#include "io.h"
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);
}
/* */
/***********************************************************************/
-/* $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"
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 ();
{
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);
/* */
/***********************************************************************/
-/* $Id: ints.c 9547 2010-01-22 12:48:24Z doligez $ */
+/* $Id: ints.c 11037 2011-05-12 14:34:05Z xleroy $ */
#include <stdio.h>
#include <string.h>
{
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 {
/* */
/***********************************************************************/
-/* $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
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);
/* */
/***********************************************************************/
-/* $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 */
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 */
/* */
/***********************************************************************/
-/* $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 */
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) {
/* */
/***********************************************************************/
-/* $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 */
/* 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));
}
| 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
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;
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$ >> ->
| <: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
| <: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
value pipe : bool;
value semi : bool;
value semisep : sep;
+ value no_semisep : sep;
method value_val : string;
method value_let : string;
method andsep : sep;
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;
| <: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;
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 ());
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;
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)
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
type token_info = { prev_loc : Loc.t
; cur_loc : Loc.t
+ ; prev_loc_only : bool
};
type token_stream = Stream.t (Token.t * token_info);
type token_info = { prev_loc : Loc.t
; cur_loc : Loc.t
+ ; prev_loc_only : bool
};
type token_stream = Stream.t (Token.t * token_info);
* - 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;
[ [: ` 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;
| 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
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))
| 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;
[ ("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]
| ("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"]
module Id = struct
- value name = "Camlp4ListComprenhsion";
+ value name = "Camlp4ListComprehension";
value version = Sys.ocaml_version;
end;
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)
[ 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
| 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 ->
| "{"; 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$ >> ] ]
;
<: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; ")" ->
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
}
<: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 ->
| `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"
<: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 ->
<: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)
more_ctyp:
[ [ "mutable"; x = SELF -> <:ctyp< mutable $x$ >>
| "`"; x = a_ident -> <:ctyp< `$x$ >>
- | x = type_kind -> x
+ | x = ctyp -> x
| x = type_parameter -> x
] ]
;
| "`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") >>
fprintf ppf "@[<hv 2>{ %a }@]"
(print_list print_out_label (fun ppf -> fprintf ppf ";@ ")) lbls
| Otyp_abstract -> fprintf ppf "<abstract>"
+ | 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
| 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)) =
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
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 =
| 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
| 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"
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,
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,
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)
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
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 =
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
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
module Tools =
struct
+ let get_prev_loc_only = ref false
+
module Make (Structure : Structure.S) =
struct
open Structure
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 =
| 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
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
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
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 ];
| 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
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)
(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))));
| "`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,
*)
module Id =
struct
- let name = "Camlp4ListComprenhsion"
+ let name = "Camlp4ListComprehension"
let version = Sys.ocaml_version
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();
}
--- /dev/null
+/***********************************************************************/
+/* */
+/* 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 <math.h>
+
+volatile double x;
+
+int main(int argc, char **argv)
+{
+ x = 3.1415;
+ x = expm1(x);
+ x = log1p(x);
+ return 0;
+}
# #
#########################################################################
-# $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
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`
# 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...
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
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
(* *)
(***********************************************************************)
-(* $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 ***************)
(* 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\
# #
#########################################################################
-# $Id: Makefile 9547 2010-01-22 12:48:24Z doligez $
+# $Id: Makefile 10661 2010-08-30 10:16:22Z doligez $
include ../config/Makefile
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
;(* *)
;(***********************************************************************)
-;(* $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)
(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)
. 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))
;(* *)
;(***********************************************************************)
-;(* $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.
((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))
((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)))
((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))
(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
(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)
(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)
;(* *)
;(***********************************************************************)
-;(* $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)
(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)
;(* *)
;(***********************************************************************)
-;(* $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
(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
(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.")
("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))
(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.")
("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)
;(* *)
;(***********************************************************************)
-;(* $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.
((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)))
" - 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))))))
(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
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
(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)
(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))))
;(* *)
;(***********************************************************************)
-;(* $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
(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)
(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)))
(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)
(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'
(* *)
(***********************************************************************)
-(* $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 *)
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 ->
(* *)
(***********************************************************************)
-(* $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 *)
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\
"
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
-\" $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
.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
(* *)
(***********************************************************************)
-(* $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
"parsing/asttypes.mli";
"parsing/parsetree.mli";
"typing/outcometree.mli";
+ "typing/oprint.ml";
"myocamlbuild_config.ml";
"utils/config.mlbuild"]
;;
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
;;
(* ***)
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
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 =
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"
~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]
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"];
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]);
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");;
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");;
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 =
Log
My_unix
My_std
-Std_signatures
Signatures
Shell
Display
()
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";
"-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";
"-ocamlc", set_cmd ocamlc, "<command> Set the OCaml bytecode compiler";
"-ocamlopt", set_cmd ocamlopt, "<command> Set the OCaml native compiler";
"-ocamldep", set_cmd ocamldep, "<command> Set the OCaml dependency tool";
+ "-ocamldoc", set_cmd ocamldoc, "<command> Set the OCaml documentation generator";
"-ocamlyacc", set_cmd ocamlyacc, "<command> Set the ocamlyacc tool";
"-menhir", set_cmd ocamlyacc, "<command> Set the menhir tool (use it after -use-menhir)";
"-ocamllex", set_cmd ocamllex, "<command> Set the ocamllex tool";
"--", 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 []
let anon_fun = add_to' targets_internal in
let usage_msg = sprintf "Usage %s [options] <target>" 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 () =
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
val union : 'a list -> 'a list -> 'a list
(* Original functions *)
- include Std_signatures.LIST
+ include module type of List
end
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
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
+++ /dev/null
-(***********************************************************************)
-(* 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
#(* *)
#(***********************************************************************)
-# $Id: Makefile 10584 2010-06-16 11:38:22Z guesdon $
+# $Id: Makefile 11020 2011-05-02 13:14:14Z guesdon $
include ../config/Makefile
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
../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:
(* *)
(***********************************************************************)
-(* 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. *)
(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]) ;
let html_short_functors = ref false
+let charset = ref "iso-8859-1"
+
let with_header = ref true
let with_trailer = ref true
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 ;
"-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 *)
]
+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]
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
(* *)
(***********************************************************************)
-(* $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. *)
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
(** 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. *)
(* *)
(***********************************************************************)
-(* $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.*)
match l with
[] -> ()
| _ ->
- bp b "<b>%s:</b> %s<br>\n"
- Odoc_messages.authors
- (String.concat ", " l)
+ bp b "<b>%s:</b> " Odoc_messages.authors;
+ self#html_of_text b [Raw (String.concat ", " l)];
+ bs b "<br>\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 "<b>%s:</b> %s<br>\n" Odoc_messages.version v
+ bp b "<b>%s:</b> " Odoc_messages.version;
+ self#html_of_text b [Raw v];
+ bs b "<br>\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 "<b>%s</b> %s<br>\n" Odoc_messages.since s
+ bp b "<b>%s</b> " Odoc_messages.since;
+ self#html_of_text b [Raw s];
+ bs b "<br>\n"
(** Print html code for the given "before" information.*)
method html_of_before b l =
let f (v, text) =
- bp b "<b>%s %s </b> " Odoc_messages.before v;
+ bp b "<b>%s " Odoc_messages.before;
+ self#html_of_text b [Raw v];
+ bs b " </b> ";
self#html_of_text b text;
bs b "<br>\n"
in
val mutable doctype =
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">\n"
- val mutable character_encoding =
- "<meta content=\"text/html; charset=iso-8859-1\" http-equiv=\"Content-Type\">\n"
+ method character_encoding () =
+ Printf.sprintf
+ "<meta content=\"text/html; charset=%s\" http-equiv=\"Content-Type\">\n"
+ !Odoc_info.Args.charset
(** The default style options. *)
val mutable default_style_options =
in
bs b "<head>\n";
bs b style;
- bs b character_encoding ;
+ bs b (self#character_encoding ()) ;
bs b "<link rel=\"Start\" href=\"";
bs b self#index;
bs b "\">\n" ;
(* *)
(***********************************************************************)
-(* $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. *)
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
(** 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. *)
(** 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"
(* *)
(***********************************************************************)
-(* $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.*)
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.
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
(* *)
(***********************************************************************)
-(* $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. *)
(** Messages for command line *)
-let usage = "Usage : "^(Sys.argv.(0))^" [options] <files>\n"
-let options_are = "Options are :"
+let usage = "Usage: "^(Sys.argv.(0))^" [options] <files>\n"
+let options_are = "Options are:"
let option_version = "\tPrint version and exit"
let latex_only = "(LaTeX only)"
let texi_only = "(TeXinfo only)"
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
+ "<s>\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"
let default_out_file = "ocamldoc.out"
let out_file =
- "<file>\tSet the ouput file name, used by texi, latex and dot generators\n"^
+ "<file>\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)"
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")
merge_version ;
merge_see ;
merge_since ;
+ merge_before ;
merge_deprecated ;
merge_param ;
merge_raised_exception ;
merge_all ]
)
+let help = "\t\tDisplay this list of options"
+
(** Error and warning messages *)
(* *)
(***********************************************************************)
-(* $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
| Merge_version
| Merge_see
| Merge_since
+ | Merge_before
| Merge_deprecated
| Merge_param
| Merge_raised_exception
Merge_version ;
Merge_see ;
Merge_since ;
+ Merge_before ;
Merge_deprecated ;
Merge_param ;
Merge_raised_exception ;
(* *)
(***********************************************************************)
-(* $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. *)
| 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. *)
../../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 \
/* */
/***********************************************************************/
-/* $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 <stddef.h>
#include <stdarg.h>
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 */
/* */
/***********************************************************************/
-/* $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 <stddef.h>
#include <string.h>
#include "io.h"
#include "mlvalues.h"
#include "sys.h"
+#include "signals.h"
extern int caml_ba_element_size[]; /* from bigarray_stubs.c */
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;
}
/* */
/***********************************************************************/
-/* $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 <stddef.h>
#include <stdio.h>
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 =
uintnat delta;
GetSystemInfo(&sysinfo);
- delta = (uintnat) addr % sysinfo.dwPageSize;
+ delta = (uintnat) addr % sysinfo.dwAllocationGranularity;
UnmapViewOfFile((void *)((uintnat)addr - delta));
}
+++ /dev/null
-db.cmo: db.cmi
-db.cmx: db.cmi
(* *)
(*************************************************************************)
-(* $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
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"
(* *)
(***********************************************************************)
-(* $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
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
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 */
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"
| _ -> 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 *)
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
/* */
/***********************************************************************/
-/* $Id: lseek.c 10223 2010-04-01 07:36:49Z shinwell $ */
+/* $Id: lseek.c 10647 2010-08-18 12:44:33Z doligez $ */
#include <errno.h>
#include <sys/types.h>
#include <mlvalues.h>
#include <alloc.h>
#include <io.h>
+#include <signals.h>
#include "unixsupport.h"
#ifdef HAS_UNISTD
(* *)
(***********************************************************************)
-(* $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 *)
| 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 *)
(** 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
file descriptor. *)
type setattr_when =
- TCSANOW
+ TCSANOW
| TCSADRAIN
| TCSAFLUSH
(* *)
(***********************************************************************)
-(* $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,
| 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 =
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
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.
See {!UnixLabels.set_close_on_exec}.*)
-
(** {6 Directories} *)
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]. *)
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
(** 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;
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 *)
/* */
/***********************************************************************/
-/* $Id: channels.c 9547 2010-01-22 12:48:24Z doligez $ */
+/* $Id: channels.c 11030 2011-05-09 11:38:43Z doligez $ */
#include <mlvalues.h>
#include <alloc.h>
} 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;
}
}
/* */
/***********************************************************************/
-/* $Id: close.c 4765 2002-04-30 15:00:48Z xleroy $ */
+/* $Id: close.c 11030 2011-05-09 11:38:43Z doligez $ */
#include <mlvalues.h>
#include "unixsupport.h"
+#include <io.h>
+
+extern int _close(int);
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;
(* *)
(***********************************************************************)
-(* $Id: location.ml 8768 2008-01-11 16:13:18Z doligez $ *)
+(* $Id: location.ml 11050 2011-05-17 16:14:39Z doligez $ *)
open Lexing
/* */
/***********************************************************************/
-/* $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 */
package_type:
mty_longident { ($1, []) }
| mty_longident WITH package_type_cstrs { ($1, $3) }
-
+;
package_type_cstr:
TYPE LIDENT EQUAL core_type { ($2, $4) }
;
(* *)
(***********************************************************************)
-(* $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
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;;
(* *)
(***********************************************************************)
-(* $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.
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.
[-], 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 ->
[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
(* *)
(***********************************************************************)
-(* $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. *)
(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
*)
[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
*)
(* *)
(***********************************************************************)
-(* $Id: format.mli 10457 2010-05-21 18:30:12Z doligez $ *)
+(* $Id: format.mli 10970 2011-03-06 16:13:14Z weis $ *)
(** Pretty printing.
(** {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]. *)
(* *)
(***********************************************************************)
-(* $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 *)
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;
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 ->
(* *)
(***********************************************************************)
-(* $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.
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]. *)
(** 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} *)
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
(* *)
(***********************************************************************)
-(* $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"
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). *)
;;
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 =
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
;;
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
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
(* *)
(***********************************************************************)
-(* $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. *)
- [( 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.
@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
(* *)
(***********************************************************************)
-(* $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. *)
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
*)
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.
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
*)
(** 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
- [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
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.
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.
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).
(** 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} *)
(* *)
(***********************************************************************)
-(* $Id: string.ml 9153 2008-12-03 18:09:09Z doligez $ *)
+(* $Id: string.ml 11043 2011-05-16 15:00:33Z doligez $ *)
(* String operations *)
type t = string
-let compare = Pervasives.compare
+let compare (x: t) (y: t) = Pervasives.compare x y
(* *)
(***********************************************************************)
-(* $Id: sys.mli 10457 2010-05-21 18:30:12Z doligez $ *)
+(* $Id: sys.mli 10715 2010-10-12 09:55:46Z doligez $ *)
(** System interface. *)
(** 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"
-# $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 ''`
(* *)
(***********************************************************************)
-(* $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 *)
-# $Id$
+# $Id: Makefile 10713 2010-10-08 11:53:19Z doligez $
compile: testing.cmi testing.cmo testing.cmx
(* *)
(***********************************************************************)
-(* $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. *)
(* *)
(***********************************************************************)
-(* $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. *)
-# $Id$
+# $Id: Makefile.common 10713 2010-10-08 11:53:19Z doligez $
TOPDIR=$(BASEDIR)/..
-# $Id$
+# $Id: Makefile.okbad 10713 2010-10-08 11:53:19Z doligez $
default: compile
-# $Id$
+# $Id: Makefile.one 10713 2010-10-08 11:53:19Z doligez $
CMI_FILES=$(MODULES:=.cmi)
CMO_FILES=$(MODULES:=.cmo)
-# $Id$
+# $Id: Makefile.several 10713 2010-10-08 11:53:19Z doligez $
CC=$(NATIVECC) $(NATIVECCCOMPOPTS)
FC=$(FORTAN_COMPILER)
-# $Id$
+# $Id: Makefile.toplevel 10713 2010-10-08 11:53:19Z doligez $
default:
@for file in *.ml; do \
--- /dev/null
+#!/bin/sh
+
+svn propset svn:ignore -F - . <<EOF
+
+*.result
+*.byte
+*.native
+program
+*.s
+*.out
+*.dSYM
+parsecmm.mli
+parsecmm.ml
+lexcmm.ml
+codegen
+
+EOF
/* */
/***********************************************************************/
-/* $Id: alpha.S 2638 1999-11-29 19:04:56Z doligez $ */
+/* $Id: alpha.S 10713 2010-10-08 11:53:19Z doligez $ */
.globl call_gen_code
.ent call_gen_code
/* */
/***********************************************************************/
-/* $Id: amd64.S 5634 2003-06-30 08:28:48Z xleroy $ */
+/* $Id: amd64.S 10713 2010-10-08 11:53:19Z doligez $ */
#ifdef SYS_macosx
#define ALIGN 4
(* *)
(***********************************************************************)
-(* $Id: arith.cmm 3218 2000-06-29 11:45:24Z xleroy $ *)
+(* $Id: arith.cmm 10713 2010-10-08 11:53:19Z doligez $ *)
(* Regression test for arithmetic instructions *)
/* */
/***********************************************************************/
-/* $Id: arm.S 9212 2009-03-31 09:46:08Z xleroy $ */
+/* $Id: arm.S 10713 2010-10-08 11:53:19Z doligez $ */
.text
(* *)
(***********************************************************************)
-(* $Id: checkbound.cmm 2553 1999-11-17 18:59:06Z xleroy $ *)
+(* $Id: checkbound.cmm 10713 2010-10-08 11:53:19Z doligez $ *)
(function "checkbound2" (x: int y: int)
(checkbound x y))
(* *)
(***********************************************************************)
-(* $Id: fib.cmm 2553 1999-11-17 18:59:06Z xleroy $ *)
+(* $Id: fib.cmm 10713 2010-10-08 11:53:19Z doligez $ *)
(function "fib" (n: int)
(if (< n 2)
;* *
;*********************************************************************
-; $Id: hppa.S 2553 1999-11-17 18:59:06Z xleroy $
+; $Id: hppa.S 10713 2010-10-08 11:53:19Z doligez $
; Must be preprocessed by cpp
#ifdef SYS_hpux
/* */
/***********************************************************************/
-/* $Id: i386.S 2553 1999-11-17 18:59:06Z xleroy $ */
+/* $Id: i386.S 10713 2010-10-08 11:53:19Z doligez $ */
/* Linux with ELF binaries does not prefix identifiers with _.
Linux with a.out binaries, FreeBSD, and NextStep do. */
;
;*********************************************************************
-; $Id: i386nt.asm 2553 1999-11-17 18:59:06Z xleroy $
+; $Id: i386nt.asm 10713 2010-10-08 11:53:19Z doligez $
.386
.MODEL FLAT
/* */
/***********************************************************************/
-/* $Id: ia64.S 3573 2001-07-12 12:54:24Z doligez $ */
+/* $Id: ia64.S 10713 2010-10-08 11:53:19Z doligez $ */
#define ST8OFF(a,b,d) st8 [a] = b, d
#define LD8OFF(a,b,d) ld8 a = [b], d
(* *)
(***********************************************************************)
-(* $Id: integr.cmm 3218 2000-06-29 11:45:24Z xleroy $ *)
+(* $Id: integr.cmm 10713 2010-10-08 11:53:19Z doligez $ *)
(function "square" (x: float)
( *f x x))
(* *)
(***********************************************************************)
-(* $Id: lexcmm.mli 2553 1999-11-17 18:59:06Z xleroy $ *)
+(* $Id: lexcmm.mli 10713 2010-10-08 11:53:19Z doligez $ *)
val token: Lexing.lexbuf -> Parsecmm.token
(* *)
(***********************************************************************)
-(* $Id: lexcmm.mll 3211 2000-06-25 19:54:50Z xleroy $ *)
+(* $Id: lexcmm.mll 10713 2010-10-08 11:53:19Z doligez $ *)
{
open Parsecmm
|* *
|***********************************************************************
-| $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
/* */
/***********************************************************************/
-/* $Id: main.c 9212 2009-03-31 09:46:08Z xleroy $ */
+/* $Id: main.c 10713 2010-10-08 11:53:19Z doligez $ */
#include <stddef.h>
#include <stdio.h>
(* *)
(***********************************************************************)
-(* $Id: main.ml 3229 2000-07-07 14:09:23Z xleroy $ *)
+(* $Id: main.ml 10713 2010-10-08 11:53:19Z doligez $ *)
open Clflags
/* */
/***********************************************************************/
-/* $Id: mainarith.c 9212 2009-03-31 09:46:08Z xleroy $ */
+/* $Id: mainarith.c 10713 2010-10-08 11:53:19Z doligez $ */
#include <stdio.h>
#include <math.h>
/* */
/***********************************************************************/
-/* $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
/* */
/***********************************************************************/
-/* $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-- */
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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 *)
#* *
#*********************************************************************
-# $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]
/* */
/*********************************************************************/
-/* $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
/* */
/*********************************************************************/
-/* $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
(* *)
(***********************************************************************)
-(* $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)
(* *)
(***********************************************************************)
-(* $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))
(* *)
(***********************************************************************)
-(* $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
/* */
/***********************************************************************/
-/* $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
(* *)
(***********************************************************************)
-(* $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)
(* *)
(***********************************************************************)
-(* $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)
(* *)
(***********************************************************************)
-(* $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)
(* *)
(***********************************************************************)
-(* $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)
(* *)
(***********************************************************************)
-(* $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)
(* *)
(*************************************************************************)
-(* $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.
-(* $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.
-(* $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.
-(* $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.
(* *)
(***********************************************************************)
-(* $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)
(* *)
(***********************************************************************)
-(* $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)
--- /dev/null
+#!/bin/sh
+
+svn propset svn:ignore -F - . <<EOF
+
+*.result
+*.byte
+*.native
+program
+
+EOF
--- /dev/null
+#!/bin/sh
+
+svn propset svn:ignore -F - . <<EOF
+
+*.result
+*.byte
+*.native
+program
+
+EOF
(* *)
(***********************************************************************)
-(* $Id: fftba.ml 2938 2000-03-10 14:54:41Z xleroy $ *)
+(* $Id: fftba.ml 10713 2010-10-08 11:53:19Z doligez $ *)
open Bigarray
--- /dev/null
+(* PR#5115 - multiple evaluation of bigarray expr *)
+
+open Bigarray
+
+let f y0 =
+ Printf.printf "***EXEC***\n%!";
+ y0
+
+let _ =
+ let y = Array1.of_array float64 fortran_layout [| 1. |] in
+ (f y).{1};
+ (f y).{1} <- 3.14
+
--- /dev/null
+***EXEC***
+***EXEC***
--- /dev/null
+#!/bin/sh
+
+svn propset svn:ignore -F - . <<EOF
+
+*.result
+*.byte
+*.native
+program
+
+EOF
+#!/bin/sh
+
+svn propset svn:ignore -F - . <<EOF
+
+*.result
+*.byte
+*.native
+program
main
static
custom
*.a
*.so
-*.result
+
+EOF
+#!/bin/sh
+
+svn propset svn:ignore -F - . <<EOF
+
+*.result
+*.byte
+*.native
+program
mypack.pack.s
result
main
*.so
*.a
+
+EOF
(* *)
(*************************************************************************)
-(* $Id: tscanf.ml 9306 2009-07-03 08:36:54Z weis $
+(* $Id: tscanf.ml 10713 2010-10-08 11:53:19Z doligez $
A testbed file for the module Scanf.
(* *)
(***********************************************************************)
-(* $Id: equations.ml 2553 1999-11-17 18:59:06Z xleroy $ *)
+(* $Id: equations.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(****************** Equation manipulations *************)
(* *)
(***********************************************************************)
-(* $Id: equations.mli 2553 1999-11-17 18:59:06Z xleroy $ *)
+(* $Id: equations.mli 10713 2010-10-08 11:53:19Z doligez $ *)
open Terms
(* *)
(***********************************************************************)
-(* $Id: kb.ml 2553 1999-11-17 18:59:06Z xleroy $ *)
+(* $Id: kb.ml 10713 2010-10-08 11:53:19Z doligez $ *)
open Terms
open Equations
(* *)
(***********************************************************************)
-(* $Id: kb.mli 2553 1999-11-17 18:59:06Z xleroy $ *)
+(* $Id: kb.mli 10713 2010-10-08 11:53:19Z doligez $ *)
open Terms
open Equations
(* *)
(***********************************************************************)
-(* $Id: kbmain.ml 7017 2005-08-12 09:22:04Z xleroy $ *)
+(* $Id: kbmain.ml 10713 2010-10-08 11:53:19Z doligez $ *)
open Terms
open Equations
(* *)
(***********************************************************************)
-(* $Id: orderings.ml 2553 1999-11-17 18:59:06Z xleroy $ *)
+(* $Id: orderings.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(*********************** Recursive Path Ordering ****************************)
(* *)
(***********************************************************************)
-(* $Id: orderings.mli 2553 1999-11-17 18:59:06Z xleroy $ *)
+(* $Id: orderings.mli 10713 2010-10-08 11:53:19Z doligez $ *)
open Terms
(* *)
(***********************************************************************)
-(* $Id: terms.ml 2553 1999-11-17 18:59:06Z xleroy $ *)
+(* $Id: terms.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(****************** Term manipulations *****************)
(* *)
(***********************************************************************)
-(* $Id: terms.mli 2553 1999-11-17 18:59:06Z xleroy $ *)
+(* $Id: terms.mli 10713 2010-10-08 11:53:19Z doligez $ *)
type term =
Var of int
(* *)
(***********************************************************************)
-(* $Id: fft.ml 7017 2005-08-12 09:22:04Z xleroy $ *)
+(* $Id: fft.ml 10713 2010-10-08 11:53:19Z doligez $ *)
let pi = 3.14159265358979323846
(* *)
(***********************************************************************)
-(* $Id: quicksort.ml 7017 2005-08-12 09:22:04Z xleroy $ *)
+(* $Id: quicksort.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(* Good test for loops. Best compiled with -unsafe. *)
(* *)
(***********************************************************************)
-(* $Id: soli.ml 2553 1999-11-17 18:59:06Z xleroy $ *)
+(* $Id: soli.ml 10713 2010-10-08 11:53:19Z doligez $ *)
type peg = Out | Empty | Peg
(* *)
(***********************************************************************)
-(* $Id: bdd.ml 7017 2005-08-12 09:22:04Z xleroy $ *)
+(* $Id: bdd.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(* Translated to Caml by Xavier Leroy *)
(* Original code written in SML by ... *)
(* *)
(***********************************************************************)
-(* $Id: boyer.ml 7017 2005-08-12 09:22:04Z xleroy $ *)
+(* $Id: boyer.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(* Manipulations over terms *)
(* *)
(***********************************************************************)
-(* $Id: fib.ml 7017 2005-08-12 09:22:04Z xleroy $ *)
+(* $Id: fib.ml 10713 2010-10-08 11:53:19Z doligez $ *)
let rec fib n =
if n < 2 then 1 else fib(n-1) + fib(n-2)
(* *)
(***********************************************************************)
-(* $Id: hamming.ml 4303 2002-01-23 17:50:20Z doligez $ *)
+(* $Id: hamming.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(* We cannot use bignums because we don't do custom runtimes, but
int64 is a bit short, so we roll our own 37-digit numbers...
(* *)
(***********************************************************************)
-(* $Id: nucleic.ml 7017 2005-08-12 09:22:04Z xleroy $ *)
+(* $Id: nucleic.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(* Use floating-point arithmetic *)
(* *)
(***********************************************************************)
-(* $Id: sieve.ml 7017 2005-08-12 09:22:04Z xleroy $ *)
+(* $Id: sieve.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(* Eratosthene's sieve *)
if not !Sys.interactive then Printexc.catch main ();;
-(* $Id: sorts.ml 4955 2002-06-26 14:55:37Z doligez $ *)
+(* $Id: sorts.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(* *)
(***********************************************************************)
-(* $Id: takc.ml 7017 2005-08-12 09:22:04Z xleroy $ *)
+(* $Id: takc.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)
(* *)
(***********************************************************************)
-(* $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))
-(* $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;;
--- /dev/null
+ADD_COMPFLAGS = -pp 'camlp4o'
+MAIN_MODULE = camlp4_class_type_plus_ok
+
+include ../../makefiles/Makefile.okbad
+include ../../makefiles/Makefile.common
--- /dev/null
+type t;;
+type xdr_value;;
+
+class type [ 't ] engine = object
+end;;
+
+module type T = sig
+class unbound_async_call : t -> [xdr_value] engine;;
+end;;
--- /dev/null
+ADD_COMPFLAGS = -pp 'camlp4o pa_macro.cmo'
+MAIN_MODULE = pr5080_notes_ok
+
+include ../../makefiles/Makefile.okbad
+include ../../makefiles/Makefile.common
--- /dev/null
+let marshal_int f =
+ match [] with
+ | _ :: `INT n :: _ -> f n
+ | _ -> failwith "marshal_int"
--- /dev/null
+#!/bin/sh
+
+svn propset svn:ignore -F - . <<EOF
+
+*.result
+*.byte
+*.native
+program
+*.bytecode
+
+EOF
+#!/bin/sh
+
+svn propset svn:ignore -F - . <<EOF
+
+*.result
+*.byte
+*.native
+program
scanner.ml
grammar.mli
grammar.ml
-*.byte
-*.native
-*.result
+
+EOF
(* *)
(***********************************************************************)
-(* $Id: gram_aux.ml,v 1.4 1999/11/17 18:58:38 xleroy Exp $ *)
+(* $Id: gram_aux.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(* Auxiliaries for the parser. *)
/* */
/***********************************************************************/
-/* $Id: grammar.mly,v 1.4 1999/11/17 18:58:38 xleroy Exp $ */
+/* $Id: grammar.mly 10713 2010-10-08 11:53:19Z doligez $ */
/* The grammar for lexer definitions */
(* *)
(***********************************************************************)
-(* $Id: scanner.mll,v 1.5 1999/11/17 18:58:39 xleroy Exp $ *)
+(* $Id: input 10713 2010-10-08 11:53:19Z doligez $ *)
(* The lexical analyzer for lexer definitions. *)
(* *)
(***********************************************************************)
-(* $Id: lexgen.ml,v 1.5 2000/12/28 13:06:39 weis Exp $ *)
+(* $Id: lexgen.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(* Compiling a lexer definition *)
(* *)
(***********************************************************************)
-(* $Id: main.ml,v 1.4 1999/11/17 18:58:39 xleroy Exp $ *)
+(* $Id: main.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(* The lexer generator. Command-line parsing. *)
(* *)
(***********************************************************************)
-(* $Id: output.ml,v 1.5 2000/12/28 13:06:41 weis Exp $ *)
+(* $Id: output.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(* Generating a DFA as a set of mutually recursive functions *)
(* *)
(***********************************************************************)
-(* $Id: scan_aux.ml,v 1.4 1999/11/17 18:58:39 xleroy Exp $ *)
+(* $Id: scan_aux.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(* Auxiliaries for the lexical analyzer *)
(* *)
(***********************************************************************)
-(* $Id: scanner.mll,v 1.5 1999/11/17 18:58:39 xleroy Exp $ *)
+(* $Id: scanner.mll 10713 2010-10-08 11:53:19Z doligez $ *)
(* The lexical analyzer for lexer definitions. *)
(* *)
(***********************************************************************)
-(* $Id: syntax.ml,v 1.4 1999/11/17 18:58:39 xleroy Exp $ *)
+(* $Id: syntax.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(* The shallow abstract syntax *)
-(* file $Id: lib.ml 6190 2004-04-06 09:11:45Z starynke $ *)
+(* file $Id: lib.ml 10713 2010-10-08 11:53:19Z doligez $ *)
external raise : exn -> 'a = "%raise"
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 $ *)
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)
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 $ *)
--- /dev/null
+#!/bin/sh
+
+svn propset svn:ignore -F - . <<EOF
+
+*.result
+*.byte
+*.native
+program
+ocamldoc.sty
+ocamldoc.out
+style.css
+*.html
+
+EOF
(* *)
(***********************************************************************)
-(* $Id: odoc_test.ml 6127 2004-02-20 16:28:27Z guesdon $ *)
+(* $Id: odoc_test.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(** Custom generator to perform test on ocamldoc. *)
--- /dev/null
+#!/bin/sh
+
+svn propset svn:ignore -F - . <<EOF
+
+*.result
+*.byte
+*.native
+program
+
+EOF
--- /dev/null
+#!/bin/sh
+
+svn propset svn:ignore -F - . <<EOF
+
+*.result
+*.byte
+*.native
+program
+
+EOF
-(* $Id: mixin.ml 5929 2003-11-19 02:36:58Z garrigue $ *)
+(* $Id: mixin.ml 10713 2010-10-08 11:53:19Z doligez $ *)
open StdLabels
open MoreLabels
-(* $Id: mixin2.ml 5929 2003-11-19 02:36:58Z garrigue $ *)
+(* $Id: mixin2.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(* Full fledge version, using objects to structure code *)
-(* $Id: mixin3.ml 5929 2003-11-19 02:36:58Z garrigue $ *)
+(* $Id: mixin3.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(* Full fledge version, using objects to structure code *)
--- /dev/null
+include ../../makefiles/Makefile.okbad
+include ../../makefiles/Makefile.common
--- /dev/null
+module type INCLUDING = sig
+ include module type of List
+ include module type of ListLabels
+end
+
+module Including_typed: INCLUDING = struct
+ include List
+ include ListLabels
+end
--- /dev/null
+include ../../makefiles/Makefile.toplevel
+include ../../makefiles/Makefile.common
+
--- /dev/null
+module type S = sig type t and s = t end;;
+module type S' = S with type t := int;;
+
+module type S = sig module rec M : sig end and N : sig end end;;
+module type S' = S with module M := String;;
--- /dev/null
+
+# module type S = sig type t and s = t end
+# module type S' = sig type s = int end
+# module type S = sig module rec M : sig end and N : sig end end
+# module type S' = sig module rec N : sig end end
+#
--- /dev/null
+class type t = object end;;
+class ['a] o1 = object (self : #t as 'a) end;;
+type 'a obj = ( < .. > 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;;
+*)
--- /dev/null
+#!/bin/sh
+
+svn propset svn:ignore -F - . <<EOF
+
+*.result
+*.byte
+*.native
+program
+
+EOF
--- /dev/null
+#!/bin/sh
+
+svn propset svn:ignore -F - . <<EOF
+
+*.result
+*.byte
+*.native
+program
+
+EOF
-(* $Id: poly.ml 9396 2009-10-26 07:11:36Z garrigue $ *)
+(* $Id: poly.ml 10713 2010-10-08 11:53:19Z doligez $ *)
(*
Polymorphic methods are now available in the main branch.
Enjoy.
--- /dev/null
+#!/bin/sh
+
+svn propset svn:ignore -F - . <<EOF
+
+*.result
+*.byte
+*.native
+program
+
+EOF
--- /dev/null
+#!/bin/sh
+
+svn propset svn:ignore -F - . <<EOF
+
+*.result
+*.byte
+*.native
+program
+
+EOF
# #
#########################################################################
-# $Id: Makefile.shared 10530 2010-06-07 06:58:41Z garrigue $
+# $Id: Makefile.shared 10718 2010-10-15 15:36:55Z doligez $
include ../config/Makefile
clean::
rm -f ocamlprof ocamlcp
-install::
- cp ocamlmktop $(BINDIR)/ocamlmktop$(EXE)
-
-clean::
- rm -f ocamlmktop
# To help building mixed-mode libraries (Caml + C)
# To make custom toplevels (see Makefile/Makefile.nt)
install::
- cp ocamlmktop $(BINDIR)/ocamlmktop$(EXE)
+ cp ocamlmktop $(BINDIR)/ # no $(EXE) here, ocamlmktop is a script
clean::
rm -f ocamlmktop
(* *)
(***********************************************************************)
-(* $Id: ocamldep.ml 10444 2010-05-20 14:06:29Z doligez $ *)
+(* $Id: ocamldep.ml 10914 2011-01-04 10:33:49Z xclerc $ *)
open Format
open Location
(* Print the dependencies *)
let load_path = ref ([] : (string * string array) list)
+let ml_synonyms = ref [".ml"]
+let mli_synonyms = ref [".mli"]
let native_only = ref false
let force_slash = ref false
let error_occurred = ref false
fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
error_occurred := true
+let add_to_synonym_list synonyms suffix =
+ if (String.length suffix) > 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 =
| 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)
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'
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) =
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 ()
"<f> Process <f> as a .ml file";
"-intf", Arg.String (file_dependencies_as MLI),
"<f> Process <f> as a .mli file";
+ "-ml-synonym", Arg.String(add_to_synonym_list ml_synonyms),
+ "<e> Consider <e> as a synonym of the .ml extension";
+ "-mli-synonym", Arg.String(add_to_synonym_list mli_synonyms),
+ "<e> Consider <e> 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,
(* *)
(***********************************************************************)
-(* $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
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 <lib> C library passed to ocamlc -a or ocamlopt -a only\n\
- -ccopt <opt> C option passed to ocamlc -a or ocamlopt -a only\n\
- -custom disable dynamic loading\n\
- -dllpath <dir> Add <dir> to the run-time search path for DLLs\n\
- -F<dir> Specify a framework directory (MacOSX)\n\
- -framework <name> Use framework <name> (MacOSX)\n\
- -help Print this help message and exit\n\
- --help Same as -help\n\
- -h Same as -help\n\
- -I <dir> Add <dir> to the path searched for Caml object files\n\
- -failsafe fall back to static linking if DLL construction failed\n\
- -ldopt <opt> C option passed to the shared linker only\n\
- -linkall Build Caml archive with link-all behavior\n\
- -l<lib> Specify a dependent C library\n\
- -L<dir> Add <dir> to the path searched for C libraries\n\
- -ocamlc <cmd> Use <cmd> in place of \"ocamlc\"\n\
- -ocamlopt <cmd> Use <cmd> in place of \"ocamlopt\"\n\
- -o <name> Generated Caml library is named <name>.cma or <name>.cmxa\n\
- -oc <name> Generated C library is named dll<name>.so or lib<name>.a\n\
- -rpath <dir> Same as -dllpath <dir>\n\
- -R<dir> 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,<dir> Same as -dllpath <dir>\n\
- -Wl,-rpath -Wl,<dir> Same as -dllpath <dir>\n\
- -Wl,-R<dir> Same as -dllpath <dir>\n\
-"
+Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|.dll files>\
+\nOptions are:\
+\n -cclib <lib> C library passed to ocamlc -a or ocamlopt -a only\
+\n -ccopt <opt> C option passed to ocamlc -a or ocamlopt -a only\
+\n -custom disable dynamic loading\
+\n -dllpath <dir> Add <dir> to the run-time search path for DLLs\
+\n -F<dir> Specify a framework directory (MacOSX)\
+\n -framework <name> Use framework <name> (MacOSX)\
+\n -help Print this help message and exit\
+\n --help Same as -help\
+\n -h Same as -help\
+\n -I <dir> Add <dir> to the path searched for Caml object files\
+\n -failsafe fall back to static linking if DLL construction failed\
+\n -ldopt <opt> C option passed to the shared linker only\
+\n -linkall Build Caml archive with link-all behavior\
+\n -l<lib> Specify a dependent C library\
+\n -L<dir> Add <dir> to the path searched for C libraries\
+\n -ocamlc <cmd> Use <cmd> in place of \"ocamlc\"\
+\n -ocamlopt <cmd> Use <cmd> in place of \"ocamlopt\"\
+\n -o <name> Generated Caml library is named <name>.cma or <name>.cmxa\
+\n -oc <name> Generated C library is named dll<name>.so or lib<name>.a\
+\n -rpath <dir> Same as -dllpath <dir>\
+\n -R<dir> 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,<dir> Same as -dllpath <dir>\
+\n -Wl,-rpath -Wl,<dir> Same as -dllpath <dir>\
+\n -Wl,-R<dir> Same as -dllpath <dir>\
+\n"
let command cmd =
if !verbose then (print_string "+ "; print_string cmd; print_newline());
(* *)
(***********************************************************************)
-(* $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 *)
(* Miscellaneous operations on object types *)
(**********************************************)
+(* Note:
+ We need to maintain some invariants:
+ * cty_self must be a Tobject
+ * ...
+*)
(**** Object field manipulation. ****)
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
(* *)
(***********************************************************************)
-(* $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 *)
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:
(* *)
(***********************************************************************)
-(* $Id: env.ml 10328 2010-04-30 01:56:21Z garrigue $ *)
+(* $Id: env.ml 11062 2011-06-01 22:23:56Z doligez $ *)
(* Environment handling *)
| Need_recursive_types(import, export) ->
fprintf ppf
"@[<hov>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"
(* *)
(***********************************************************************)
-(* $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
(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)
(* *)
(***********************************************************************)
-(* $Id: printtyp.ml 10333 2010-04-30 07:11:27Z garrigue $ *)
+(* $Id: printtyp.ml 10703 2010-10-02 08:58:23Z garrigue $ *)
(* Printing functions *)
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);
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);
(* *)
(***********************************************************************)
-(* $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
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. *)
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
(* *)
(***********************************************************************)
-(* $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 ****)
(* 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 =
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
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
(* *)
(***********************************************************************)
-(* $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 *)
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
(* *)
(***********************************************************************)
-(* $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 *)
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 =
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
| (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 _))
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
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
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
projects / ocaml.git / commitdiff