From: Samuel Mimram Date: Sun, 3 Feb 2008 19:49:32 +0000 (+0000) Subject: Imported Upstream version 3.10.1 X-Git-Tag: archive/raspbian/4.08.1-4+rpi1~3^2~63^2~32 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=c54f22d62b761b26dd37d81b049a3d8bca5bf20c;p=ocaml.git Imported Upstream version 3.10.1 --- diff --git a/Changes b/Changes index 2e06234d..7eee8820 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,89 @@ +Objective Caml 3.10.1: +---------------------- + +Bug fixes: +- PR#3830 small bugs in docs +- PR#4053 compilers: improved compilation time for large variant types +- PR#4174 ocamlopt: fixed ocamlopt -nopervasives +- PR#4199 otherlibs: documented a small problem in Unix.utimes +- PR#4280 camlp4: parsing of identifier (^) +- PR#4281 camlp4: parsing of type constraint +- PR#4285 runtime: cannot compile under AIX +- PR#4286 ocamlbuild: cannot compile under AIX and SunOS +- PR#4288 compilers: including a functor application with side effects +- PR#4295 camlp4 toplevel: synchronization after an error +- PR#4300 ocamlopt: crash with backtrace and illegal array access +- PR#4302 camlp4: list comprehension parsing problem +- PR#4304 ocamlbuild: handle -I correctly +- PR#4305 stdlib: alignment of Arg.Symbol +- PR#4307 camlp4: assertion failure +- PR#4312 camlp4: accept "let _ : int = 1" +- PR#4313 ocamlbuild: -log and missing directories +- PR#4315 camlp4: constraints in classes +- PR#4316 compilers: crash with recursive modules and Lazy +- PR#4318 ocamldoc: installation problem with Cygwin (tentative fix) +- PR#4322 ocamlopt: stack overflow under Windows +- PR#4325 compilers: wrong error message for unused var +- PR#4326 otherlibs: marshal Big_int on win64 +- PR#4327 ocamlbuild: make emacs look for .annot in _build directory +- PR#4328 camlp4: stack overflow with nil nodes +- PR#4331 camlp4: guards on fun expressions +- PR#4332 camlp4: parsing of negative 32/64 bit numbers +- PR#4336 compilers: unsafe recursive modules +- PR#4337 (note) camlp4: invalid character escapes +- PR#4339 ocamlopt: problems on HP-UX (tentative fix) +- PR#4340 camlp4: wrong pretty-printing of optional arguments +- PR#4348 ocamlopt: crash on Mac Intel +- PR#4349 camlp4: bug in private type definitions +- PR#4350 compilers: type errors with records and polymorphic variants +- PR#4352 compilers: terminal recursion under Windows (tentative fix) +- PR#4354 ocamlcp: mismatch with ocaml on polymorphic let +- PR#4358 ocamlopt: float constants wrong on ARM +- PR#4360 ocamldoc: string inside comment +- PR#4365 toplevel: wrong pretty-printing of polymorphic variants +- PR#4373 otherlibs: leaks in win32unix +- PR#4374 otherlibs: threads module not initialized +- PR#4375 configure: fails to build on bytecode-only architectures +- PR#4377 runtime: finalisation of infix pointers +- PR#4378 ocamlbuild: typo in plugin.ml +- PR#4379 ocamlbuild: problem with plugins under Windows +- PR#4382 compilers: typing of polymorphic record fields +- PR#4383 compilers: including module with private type +- PR#4385 stdlib: Int32/Int64.format are unsafe +- PR#4386 otherlibs: wrong signal numbers with Unix.sigprocmask etc. +- PR#4387 ocamlbuild: build directory not used properly +- PR#4392 ocamldep: optional argument of class +- PR#4394 otherlibs: infinite loops in Str +- PR#4397 otherlibs: wrong size for flag arrays in win32unix +- PR#4402 ocamldebug: doesn't work with -rectypes +- PR#4410 ocamlbuild: problem with plugin and -build +- PR#4411 otherlibs: crash with Unix.access under Windows +- PR#4412 stdlib: marshalling broken on 64 bit architectures +- PR#4413 ocamlopt: crash on AMD64 with out-of-bound access and reraise +- PR#4417 camlp4: pretty-printing of unary minus +- PR#4419 camlp4: problem with constraint in type class +- PR#4426 compilers: problem with optional labels +- PR#4427 camlp4: wrong pretty-printing of lists of functions +- PR#4433 ocamlopt: fails to build on MacOSX 10.5 +- PR#4435 compilers: crash with objects +- PR#4439 fails to build on MacOSX 10.5 +- PR#4441 crash when build on sparc64 linux +- PR#4442 stdlib: crash with weak pointers +- PR#4446 configure: fails to detect X11 on MacOSX 10.5 +- PR#4448 runtime: huge page table on 64-bit architectures +- PR#4450 compilers: stack overflow with recursive modules +- PR#4470 compilers: type-checking of recursive modules too restrictive +- PR#4472 configure: autodetection of libX11.so on Fedora x86_64 +- printf: removed (partially implemented) positional specifications +- polymorphic < and <= comparisons: some C compiler optimizations + were causing incorrect results when arguments are incomparable + +New features: +- made configure script work on PlayStation 3 +- ARM port: brought up-to-date for Debian 4.0 (Etch) +- many other small changes and bugfixes in camlp4, ocamlbuild, labltk, + emacs files, + Objective Caml 3.10.0: ---------------------- @@ -2150,4 +2236,4 @@ Caml Special Light 1.06: * First public release. -$Id: Changes,v 1.168.2.3 2007/03/06 15:38:21 xleroy Exp $ +$Id: Changes,v 1.168.2.7 2008/01/04 13:27:04 doligez Exp $ diff --git a/Makefile b/Makefile index 3f627404..a3da5f2f 100644 --- a/Makefile +++ b/Makefile @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.207.4.4 2007/04/16 16:01:59 pouillar Exp $ +# $Id: Makefile,v 1.207.4.5 2007/06/20 13:26:29 ertai Exp $ # The main Makefile @@ -225,7 +225,7 @@ cleanboot: # Compile the native-code compiler opt-core:runtimeopt ocamlopt libraryopt -opt: runtimeopt ocamlopt libraryopt otherlibrariesopt +opt: runtimeopt ocamlopt libraryopt otherlibrariesopt ocamlbuildlib.native # Native-code versions of the tools opt.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \ @@ -617,6 +617,8 @@ ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-partial-boot ./build/ocamlbuild-byte-only.sh ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-partial-boot ./build/ocamlbuild-native-only.sh +ocamlbuildlib.native: ocamlopt otherlibrariesopt ocamlbuild-partial-boot + ./build/ocamlbuildlib-native-only.sh .PHONY: ocamlbuild-partial-boot ocamlbuild-partial-boot: diff --git a/Makefile.nt b/Makefile.nt index 86907772..bc41849b 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.102.4.3 2007/04/16 16:01:59 pouillar Exp $ +# $Id: Makefile.nt,v 1.102.4.4 2007/06/20 13:26:29 ertai Exp $ # The main Makefile @@ -200,7 +200,7 @@ cleanboot: rm -rf boot/Saved/Saved.prev/* # Compile the native-code compiler -opt: runtimeopt ocamlopt libraryopt otherlibrariesopt +opt: runtimeopt ocamlopt libraryopt otherlibrariesopt ocamlbuildlib.native # Native-code versions of the tools opt.opt: ocamlc.opt ocamlopt.opt ocamllex.opt ocamltoolsopt.opt \ @@ -577,6 +577,9 @@ ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-partial-boot ./build/ocamlbuild-byte-only.sh ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-partial-boot ./build/ocamlbuild-native-only.sh +ocamlbuildlib.native: ocamlopt otherlibrariesopt ocamlbuild-partial-boot + ./build/ocamlbuildlib-native-only.sh + .PHONY: ocamlbuild-partial-boot ocamlbuild-partial-boot: diff --git a/README.win32 b/README.win32 index 2ab75a6f..bfdff2b0 100644 --- a/README.win32 +++ b/README.win32 @@ -89,8 +89,11 @@ THIRD-PARTY SOFTWARE: the Microsoft Windows Server 2003 SP1 Platform SDK, which can be downloaded for free from http://www.microsoft.com/. -[3] MASM version 6.11 or later. MASM can be - downloaded for free from Microsoft's Web site; for directions, see +[3] MASM version 6.11 or later. The full distribution of Visual C++ 2005 + contains MASM version 8. Users of the Express Edition of Visual C++ + 2005 can download MASM version 8 from +http://www.microsoft.com/downloads/details.aspx?FamilyID=7A1C9DA0-0510-44A2-B042-7EF370530C64&displaylang=en + To obtain MASM version 6.11, see http://users.easystreet.com/jkirwan/new/pctools.html. [4] TCL/TK version 8.4. Windows binaries are available as part of the @@ -103,7 +106,7 @@ distribution (ocaml-X.YZ.tar.gz), which also contains the files modified for Windows. You will need the following software components to perform the recompilation: -- Windows NT, 2000, or XP. +- Windows NT, 2000, XP, or Vista. - Items [1], [2], [3] and [4] from the list of recommended software above. - The Cygwin port of GNU tools, available from http://www.cygwin.com/ @@ -131,7 +134,7 @@ Finally, use "make -f Makefile.nt" to build the system, e.g. make -f Makefile.nt opt.opt make -f Makefile.nt install -Alternatively you can use the experimental build procdure using ocamlbuild: +Alternatively you can use the experimental build procedure using ocamlbuild: ./build/fastworld.sh ./build/install.sh @@ -205,7 +208,7 @@ environment variable. E.g. if Tcl/Tk was installed in C:\tcl, add RECOMPILATION FROM THE SOURCES: You will need the following software components to perform the recompilation: -- Windows NT, 2000, or XP. +- Windows NT, 2000, XP, or Vista. - Cygwin: http://sourceware.cygnus.com/cygwin/ - TCL/TK version 8.4 (see above). diff --git a/VERSION b/VERSION index f0b88bc2..e02a2ee7 100644 --- a/VERSION +++ b/VERSION @@ -1,6 +1,6 @@ -3.10.0 +3.10.1 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli -# $Id: VERSION,v 1.2.2.4 2007/05/13 15:13:25 xleroy Exp $ +# $Id: VERSION,v 1.2.2.11 2008/01/11 11:17:21 doligez Exp $ diff --git a/_tags b/_tags index 6dd67f0e..322973a9 100644 --- a/_tags +++ b/_tags @@ -16,8 +16,8 @@ true: debug # By default everything we link needs the stdlib true: use_stdlib -# The stdlib don't require the stdlib -: -use_stdlib +# The stdlib neither requires the stdlib nor debug information +: -use_stdlib, -debug <**/*.ml*>: warn_Alez @@ -30,7 +30,8 @@ true: use_stdlib "ocamldoc/odoc_opt.native": use_unix, use_str : camlp4boot, -warn_Alez, warn_Ale -: -camlp4boot +: -camlp4boot +"camlp4/Camlp4_import.ml": -warn_Ale or or "camlp4/Camlp4/Struct/Lexer.ml": -camlp4boot, -warn_Ale, warn_a "camlp4/Camlp4Bin.byte" or "camlp4/mkcamlp4.byte" or "camlp4/camlp4lib.cma": use_dynlink "camlp4/Camlp4/Printers/OCaml.ml" or "camlp4/Camlp4/Printers/OCamlr.ml": warn_Alezv diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index ae201a7a..d4961ac6 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.13 2007/01/29 12:10:50 xleroy Exp $ *) +(* $Id: emit.mlp,v 1.13.4.2 2007/10/23 09:09:43 xleroy Exp $ *) (* Emission of x86-64 (AMD 64) assembly code *) @@ -197,7 +197,7 @@ let emit_call_bound_error bd = let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; if !bound_error_call > 0 then - `{emit_label !bound_error_call}: jmp {emit_symbol "caml_ml_array_bound_error"}\n` + `{emit_label !bound_error_call}: call {emit_symbol "caml_ml_array_bound_error"}\n` (* Names for instructions *) @@ -549,8 +549,22 @@ let emit_instr fallthrough i = | Lswitch jumptbl -> let lbl = new_label() in if !pic_code then begin - ` leaq {emit_label lbl}(%rip), %r11\n`; - ` jmp *(%r11, {emit_reg i.arg.(0)}, 8)\n` + (* PR#4424: r11 is known to be clobbered by the Lswitch, + meaning that no variable that is live across the Lswitch + is assigned to r11. However, the argument to Lswitch + can still be assigned to r11, so we need to special-case + this situation. *) + if i.arg.(0).loc = Reg 9 (* ie r11, cf amd64/proc.ml *) then begin + ` salq $3, %r11\n`; + ` pushq %r11\n`; + ` leaq {emit_label lbl}(%rip), %r11\n`; + ` addq 0(%rsp), %r11\n`; + ` addq $8, %rsp\n`; + ` jmp *(%r11)\n` + end else begin + ` leaq {emit_label lbl}(%rip), %r11\n`; + ` jmp *(%r11, {emit_reg i.arg.(0)}, 8)\n` + end end else begin ` jmp *{emit_label lbl}(, {emit_reg i.arg.(0)}, 8)\n` end; diff --git a/asmcomp/amd64/emit_nt.mlp b/asmcomp/amd64/emit_nt.mlp index da7de6a6..874316b3 100644 --- a/asmcomp/amd64/emit_nt.mlp +++ b/asmcomp/amd64/emit_nt.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit_nt.mlp,v 1.6 2007/03/01 10:26:51 xleroy Exp $ *) +(* $Id: emit_nt.mlp,v 1.6.2.1 2007/10/09 14:03:01 xleroy Exp $ *) (* Emission of x86-64 (AMD 64) assembly code, MASM syntax *) @@ -217,7 +217,7 @@ let emit_call_bound_error bd = let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; if !bound_error_call > 0 then - `{emit_label !bound_error_call}: jmp caml_ml_array_bound_error\n` + `{emit_label !bound_error_call}: call caml_ml_array_bound_error\n` (* Names for instructions *) diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index d6d85d0b..7e017b56 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.18 2004/05/03 12:46:50 xleroy Exp $ *) +(* $Id: emit.mlp,v 1.18.18.1 2007/10/23 11:54:04 xleroy Exp $ *) (* Emission of ARM assembly code *) @@ -648,9 +648,6 @@ let begin_assembly() = `trap_ptr .req r11\n`; `alloc_ptr .req r8\n`; `alloc_limit .req r9\n`; - `sp .req r13\n`; - `lr .req r14\n`; - `pc .req r15\n`; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in ` .data\n`; ` .global {emit_symbol lbl_begin}\n`; diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml index ac586f9d..aa462c81 100644 --- a/asmcomp/arm/selection.ml +++ b/asmcomp/arm/selection.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: selection.ml,v 1.6 2001/03/30 12:22:32 xleroy Exp $ *) +(* $Id: selection.ml,v 1.6.36.1 2007/10/23 11:53:24 xleroy Exp $ *) (* Instruction selection for the ARM processor *) @@ -106,7 +106,7 @@ method select_operation op args = | _ -> (Iextcall("__modsi3", false), args) end - | Ccheckbound -> + | Ccheckbound _ -> begin match args with [Cop(Clsr, [arg1; Cconst_int n]); arg2] when n > 0 && n < 32 && not(is_intconst arg2) -> @@ -116,15 +116,15 @@ method select_operation op args = end | _ -> super#select_operation op args -(* In mul rd, rm, rs, rm and rd must be different. +(* In mul rd, rm, rs, the registers rm and rd must be different. We deal with this by pretending that rm is also a result of the mul operation. *) -method insert_op op rs rd = +method insert_op_debug op dbg rs rd = if op = Iintop(Imul) then begin - self#insert (Iop op) rs [| rd.(0); rs.(0) |]; rd + self#insert_debug (Iop op) dbg rs [| rd.(0); rs.(0) |]; rd end else - super#insert_op op rs rd + super#insert_op_debug op dbg rs rd end diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index ac5d676f..598722bc 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: asmlink.ml,v 1.70 2007/02/15 18:35:20 frisch Exp $ *) +(* $Id: asmlink.ml,v 1.70.2.1 2007/11/10 12:23:37 xleroy Exp $ *) (* Link a set of .cmx/.o files and produce an executable *) @@ -229,8 +229,8 @@ let call_linker file_list startup_file output_name = else "libasmrun" ^ ext_lib in let runtime_lib = try - if !Clflags.nopervasives then "" - else find_in_path !load_path libname + if !Clflags.nopervasives then None + else Some(find_in_path !load_path libname) with Not_found -> raise(Error(File_not_found libname)) in let c_lib = @@ -251,7 +251,7 @@ let call_linker file_list startup_file output_name = (List.map (fun dir -> if dir = "" then "" else "-L" ^ dir) !load_path)) (Ccomp.quote_files (List.rev !Clflags.ccobjs)) - (Filename.quote runtime_lib) + (Ccomp.quote_optfile runtime_lib) c_lib else Printf.sprintf "%s -o %s %s %s" @@ -271,7 +271,7 @@ let call_linker file_list startup_file output_name = (Ccomp.quote_files (List.rev file_list)) (Ccomp.quote_files (List.rev_map Ccomp.expand_libname !Clflags.ccobjs)) - (Filename.quote runtime_lib) + (Ccomp.quote_optfile runtime_lib) c_lib (Ccomp.make_link_options !Clflags.ccopts) in if Ccomp.command cmd <> 0 then raise(Error Linking_error); diff --git a/asmcomp/hppa/reload.ml b/asmcomp/hppa/reload.ml index aa75ee81..056f8494 100644 --- a/asmcomp/hppa/reload.ml +++ b/asmcomp/hppa/reload.ml @@ -10,9 +10,29 @@ (* *) (***********************************************************************) -(* $Id: reload.ml,v 1.3 1999/11/17 18:56:42 xleroy Exp $ *) +(* $Id: reload.ml,v 1.3.38.1 2007/12/20 08:53:03 xleroy Exp $ *) (* Reloading for the HPPA *) + +open Cmm +open Arch +open Reg +open Mach +open Proc + +class reload = object (self) + +inherit Reloadgen.reload_generic as super + +method reload_operation op arg res = + match op with + Iintop(Idiv | Imod) + | Iintop_imm((Idiv | Imod), _) -> (arg, res) + | _ -> super#reload_operation op arg res +end + + + let fundecl f = - (new Reloadgen.reload_generic)#fundecl f + (new reload)#fundecl f diff --git a/asmcomp/hppa/selection.ml b/asmcomp/hppa/selection.ml index 49a22797..8efdd3d2 100644 --- a/asmcomp/hppa/selection.ml +++ b/asmcomp/hppa/selection.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: selection.ml,v 1.5 1999/11/17 18:56:42 xleroy Exp $ *) +(* $Id: selection.ml,v 1.5.38.1 2007/10/25 09:08:20 xleroy Exp $ *) (* Instruction selection for the HPPA processor *) @@ -92,17 +92,17 @@ method select_operation op args = (* Deal with register constraints *) -method insert_op op rs rd = +method insert_op_debug op dbg rs rd = match op with Iintop(Idiv | Imod) -> (* handled via calls to millicode *) let rs' = [|phys_reg 20; phys_reg 19|] (* %r26, %r25 *) and rd' = [|phys_reg 22|] (* %r29 *) in self#insert_moves rs rs'; - self#insert (Iop op) rs' rd'; + self#insert_debug (Iop op) dbg rs' rd'; self#insert_moves rd' rd; rd | _ -> - super#insert_op op rs rd + super#insert_op_debug op dbg rs rd end diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index d13dea58..ba6e795d 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.38.4.1 2007/03/07 09:14:29 xleroy Exp $ *) +(* $Id: emit.mlp,v 1.38.4.2 2007/10/09 13:54:27 xleroy Exp $ *) (* Emission of Intel 386 assembly code *) @@ -239,7 +239,7 @@ let emit_call_bound_error bd = let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; if !bound_error_call > 0 then - `{emit_label !bound_error_call}: jmp {emit_symbol "caml_ml_array_bound_error"}\n` + `{emit_label !bound_error_call}: call {emit_symbol "caml_ml_array_bound_error"}\n` (* Names for instructions *) diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index 6699e2f3..80d874d1 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit_nt.mlp,v 1.27 2007/01/29 12:10:50 xleroy Exp $ *) +(* $Id: emit_nt.mlp,v 1.27.4.1 2007/10/09 14:04:05 xleroy Exp $ *) (* Emission of Intel 386 assembly code, MASM syntax. *) @@ -206,7 +206,7 @@ let emit_call_bound_error bd = let emit_call_bound_errors () = List.iter emit_call_bound_error !bound_error_sites; if !bound_error_call > 0 then - `{emit_label !bound_error_call}: jmp _caml_ml_array_bound_error\n` + `{emit_label !bound_error_call}: call _caml_ml_array_bound_error\n` (* Names for instructions *) diff --git a/asmcomp/i386/proc_nt.ml b/asmcomp/i386/proc_nt.ml index 4f99a99b..9d690513 100644 --- a/asmcomp/i386/proc_nt.ml +++ b/asmcomp/i386/proc_nt.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: proc_nt.ml,v 1.5 2002/03/12 16:17:52 xleroy Exp $ *) +(* $Id: proc_nt.ml,v 1.5.26.1 2007/10/09 14:11:26 xleroy Exp $ *) (* Description of the Intel 386 processor, for Windows NT *) @@ -88,12 +88,23 @@ let word_addressed = false (* Calling conventions *) +(* To supplement the processor's meagre supply of registers, we also + use some global memory locations to pass arguments beyond the 6th. + These globals are denoted by Incoming and Outgoing stack locations + with negative offsets, starting at -64. + Unlike arguments passed on stack, arguments passed in globals + do not prevent tail-call elimination. The caller stores arguments + in these globals immediately before the call, and the first thing the + callee does is copy them to registers or stack locations. + Neither GC nor thread context switches can occur between these two + times. *) + let calling_conventions first_int last_int first_float last_float make_stack arg = let loc = Array.create (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in - let ofs = ref 0 in + let ofs = ref (-64) in for i = 0 to Array.length arg - 1 do match arg.(i).typ with Int | Addr as ty -> @@ -113,7 +124,7 @@ let calling_conventions first_int last_int first_float last_float make_stack ofs := !ofs + size_float end done; - (loc, !ofs) + (loc, max 0 !ofs) let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c index 59ea0c1b..07d7f6f7 100644 --- a/asmrun/backtrace.c +++ b/asmrun/backtrace.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: backtrace.c,v 1.2 2007/01/29 12:10:52 xleroy Exp $ */ +/* $Id: backtrace.c,v 1.2.4.1 2007/10/10 08:34:34 xleroy Exp $ */ /* Stack backtrace for uncaught exceptions */ @@ -59,8 +59,8 @@ void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) h = Hash_retaddr(pc); while(1) { d = caml_frame_descriptors[h]; + if (d == 0) return; /* can happen if some code not compiled with -g */ if (d->retaddr == pc) break; - if (d->retaddr == 0) return; /* should not happen */ h = (h+1) & caml_frame_descriptors_mask; } /* Skip to next frame */ diff --git a/asmrun/i386.S b/asmrun/i386.S index 1ecdd6b0..c34f17a3 100644 --- a/asmrun/i386.S +++ b/asmrun/i386.S @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: i386.S,v 1.48 2007/01/29 15:44:42 xleroy Exp $ */ +/* $Id: i386.S,v 1.48.4.1 2007/10/09 13:32:25 xleroy Exp $ */ /* Asm part of the runtime system, Intel 386 processor */ /* Must be preprocessed by cpp */ @@ -384,9 +384,17 @@ G(caml_ml_array_bound_error): ffree %st(5) ffree %st(6) ffree %st(7) - /* Branch to [caml_array_bound_error] */ - movl $ G(caml_array_bound_error), %eax - jmp G(caml_c_call) + /* Record lowest stack address and return address */ + movl (%esp), %edx + movl %edx, G(caml_last_return_address) + leal 4(%esp), %edx + movl %edx, G(caml_bottom_of_stack) + /* For MacOS X: re-align the stack */ +#ifdef SYS_macosx + andl $-16, %esp +#endif + /* Branch to [caml_array_bound_error] (never returns) */ + call G(caml_array_bound_error) .data .globl G(caml_system__frametable) diff --git a/asmrun/roots.c b/asmrun/roots.c index d11b85c6..a0c61618 100644 --- a/asmrun/roots.c +++ b/asmrun/roots.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: roots.c,v 1.41 2007/02/15 18:35:20 frisch Exp $ */ +/* $Id: roots.c,v 1.41.2.1 2007/10/25 09:08:20 xleroy Exp $ */ /* To walk the memory roots for garbage collection */ @@ -100,7 +100,11 @@ void caml_oldify_local_roots (void) frame_descr * d; uintnat h; int i, j, n, ofs; +#ifdef Stack_grows_upwards + short * p; /* PR#4339: stack offsets are negative in this case */ +#else unsigned short * p; +#endif value glob; value * root; struct global_root * gr; diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c index 7019e0be..4e51a9ed 100644 --- a/asmrun/signals_asm.c +++ b/asmrun/signals_asm.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: signals_asm.c,v 1.2 2007/03/01 10:27:26 xleroy Exp $ */ +/* $Id: signals_asm.c,v 1.2.2.1 2007/11/06 12:26:15 xleroy Exp $ */ /* Signal handling, code specific to the native-code compiler */ @@ -238,7 +238,7 @@ void caml_init_signals(void) /* Stack overflow handling */ #ifdef HAS_STACK_OVERFLOW_DETECTION { - struct sigaltstack stk; + stack_t stk; struct sigaction act; stk.ss_sp = sig_alt_stack; stk.ss_size = SIGSTKSZ; diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index 1002bf12..95c33adc 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: signals_osdep.h,v 1.8 2007/01/29 12:10:52 xleroy Exp $ */ +/* $Id: signals_osdep.h,v 1.8.4.5 2007/11/26 16:58:51 doligez Exp $ */ /* Processor- and OS-dependent signal interface */ @@ -87,9 +87,16 @@ sigact.sa_flags = SA_SIGINFO #include + #include - #define CONTEXT_STATE (((struct ucontext *)context)->uc_mcontext->ss) - #define CONTEXT_PC (CONTEXT_STATE.eip) +#if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5 + #define CONTEXT_REG(r) r + #else + #define CONTEXT_REG(r) __##r + #endif + + #define CONTEXT_STATE (((ucontext_t *)context)->uc_mcontext->CONTEXT_REG(ss)) + #define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(eip)) #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) /****************** MIPS, all OS */ @@ -113,106 +120,43 @@ #elif defined(TARGET_power) && defined(SYS_rhapsody) -#ifdef __ppc64__ - #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, siginfo_t * info, void * context) - #define SET_SIGACT(sigact,name) \ - sigact.sa_sigaction = (name); \ - sigact.sa_flags = SA_SIGINFO | SA_64REGSET - - typedef unsigned long long context_reg; - #include - - #define CONTEXT_STATE (((struct ucontext64 *)context)->uc_mcontext64->ss) - - #define CONTEXT_PC (CONTEXT_STATE.srr0) - #define CONTEXT_EXCEPTION_POINTER (CONTEXT_STATE.r29) - #define CONTEXT_YOUNG_LIMIT (CONTEXT_STATE.r30) - #define CONTEXT_YOUNG_PTR (CONTEXT_STATE.r31) - #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) - #define CONTEXT_SP (CONTEXT_STATE.r1) - -#else - - #include - - #define DECLARE_SIGNAL_HANDLER(name) \ - static void name(int sig, siginfo_t * info, void * context) - - #define SET_SIGACT(sigact,name) \ - sigact.sa_handler = (void (*)(int)) (name); \ - sigact.sa_flags = SA_SIGINFO - - typedef unsigned long context_reg; - - #define CONTEXT_PC (*context_gpr_p(context, -2)) - #define CONTEXT_EXCEPTION_POINTER (*context_gpr_p(context, 29)) - #define CONTEXT_YOUNG_LIMIT (*context_gpr_p(context, 30)) - #define CONTEXT_YOUNG_PTR (*context_gpr_p(context, 31)) - #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) - #define CONTEXT_SP (*context_gpr_p(context, 1)) - - static int ctx_version = 0; - static void init_ctx (void) - { - struct utsname name; - if (uname (&name) == 0){ - if (name.release[1] == '.' && name.release[0] <= '5'){ - ctx_version = 1; - }else{ - ctx_version = 2; - } - }else{ - caml_fatal_error ("cannot determine SIGCONTEXT format"); - } - } - - #ifdef DARWIN_VERSION_6 - #include - static unsigned long *context_gpr_p (void *ctx, int regno) - { - unsigned long *regs; - if (ctx_version == 0) init_ctx (); - if (ctx_version == 1){ - /* old-style context (10.0 and 10.1) */ - regs = (unsigned long *)(((struct sigcontext *)ctx)->sc_regs); - }else{ - Assert (ctx_version == 2); - /* new-style context (10.2) */ - regs = (unsigned long *)&(((struct ucontext *)ctx)->uc_mcontext->ss); - } - return &(regs[2 + regno]); - } + #include + + #ifdef __LP64__ + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (name); \ + sigact.sa_flags = SA_SIGINFO | SA_64REGSET + + typedef unsigned long long context_reg; + + #define CONTEXT_MCONTEXT (((ucontext64_t *)context)->uc_mcontext64) #else - #define SA_SIGINFO 0x0040 - struct ucontext { - int uc_onstack; - sigset_t uc_sigmask; - struct sigaltstack uc_stack; - struct ucontext *uc_link; - size_t uc_mcsize; - unsigned long *uc_mcontext; - }; - static unsigned long *context_gpr_p (void *ctx, int regno) - { - unsigned long *regs; - if (ctx_version == 0) init_ctx (); - if (ctx_version == 1){ - /* old-style context (10.0 and 10.1) */ - regs = (unsigned long *)(((struct sigcontext *)ctx)->sc_regs); - }else{ - Assert (ctx_version == 2); - /* new-style context (10.2) */ - regs = (unsigned long *)((struct ucontext *)ctx)->uc_mcontext + 8; - } - return &(regs[2 + regno]); - } + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (name); \ + sigact.sa_flags = SA_SIGINFO + + typedef unsigned long context_reg; + + #define CONTEXT_MCONTEXT (((ucontext_t *)context)->uc_mcontext) + #endif + +#if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5 + #define CONTEXT_REG(r) r + #else + #define CONTEXT_REG(r) __##r #endif -#endif + #define CONTEXT_STATE (CONTEXT_MCONTEXT->CONTEXT_REG(ss)) + #define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(srr0)) + #define CONTEXT_EXCEPTION_POINTER (CONTEXT_STATE.CONTEXT_REG(r29)) + #define CONTEXT_YOUNG_LIMIT (CONTEXT_STATE.CONTEXT_REG(r30)) + #define CONTEXT_YOUNG_PTR (CONTEXT_STATE.CONTEXT_REG(r31)) + #define CONTEXT_SP (CONTEXT_STATE.CONTEXT_REG(r1)) + #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) /****************** PowerPC, ELF (Linux) */ diff --git a/boot/myocamlbuild.boot b/boot/myocamlbuild.boot index 3187433c..c97932a1 100755 Binary files a/boot/myocamlbuild.boot and b/boot/myocamlbuild.boot differ diff --git a/boot/ocamlc b/boot/ocamlc index bccf3072..63b5acdc 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep index 85d7bddf..03f28d90 100755 Binary files a/boot/ocamldep and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index ab895f36..3afd66ec 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/build/buildbot b/build/buildbot index c755852f..e9b2579e 100755 --- a/build/buildbot +++ b/build/buildbot @@ -1,5 +1,9 @@ #!/bin/sh +# If you want to help me by participating to the build/test effort: +# http://gallium.inria.fr/~pouillar/ocaml-testing.html +# -- Nicolas Pouillard + usage() { echo "Usage: $0 (make|ocb|ocamlbuild) (win (mingw|msvc|msvc64) | *)" exit 1 @@ -11,7 +15,7 @@ finish() { curl -s -0 -F "log=@$logfile" \ -F "host=`hostname`" \ -F "mode=$mode-$opt_win-$opt_win2" \ - http://weblog.feydakins.org/dropbox || : + http://buildbot.feydakins.org/dropbox || : } rm -f buildbot.failed diff --git a/build/distclean.sh b/build/distclean.sh index 5f3551a2..e564efa7 100755 --- a/build/distclean.sh +++ b/build/distclean.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: distclean.sh,v 1.4.2.5 2007/03/12 11:58:48 pouillar Exp $ +# $Id: distclean.sh,v 1.4.2.6 2007/12/18 09:03:12 ertai Exp $ cd `dirname $0`/.. set -ex (cd byterun && make clean) || : @@ -9,6 +9,7 @@ rm -rf _build rm -f boot/ocamlrun boot/ocamlrun.exe boot/camlheader \ boot/myocamlbuild boot/myocamlbuild.native boot/myocamlbuild.native.exe \ myocamlbuild_config.ml config/config.sh config/Makefile \ + boot/ocamlyacc tools/cvt_emit.bak tools/*.bak \ config/s.h config/m.h boot/*.cm* _log _*_log* # from partial boot diff --git a/build/install.sh b/build/install.sh index 13c4913b..5d2a100a 100755 --- a/build/install.sh +++ b/build/install.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: install.sh,v 1.6.2.12 2007/04/05 08:12:39 pouillar Exp $ +# $Id: install.sh,v 1.6.2.16 2007/11/27 13:27:48 ertai Exp $ set -e cd `dirname $0`/.. @@ -127,6 +127,7 @@ installdir otherlibs/"$WIN32"unix/unixsupport.h \ installdir yacc/ocamlyacc byterun/ocamlrun $BINDIR +installdir config/Makefile $LIBDIR/Makefile.config installdir byterun/ld.conf $LIBDIR cd _build @@ -462,8 +463,8 @@ echo "Installing manuals..." (cd ../man && make install) echo "Installing ocamldoc..." -installbin ocamldoc/ocamldoc$EXE $BINDIR/ocamldoc$EXE -installbin ocamldoc/ocamldoc.opt$EXE $BINDIR/ocamldoc.opt$EXE +installbin ocamldoc/ocamldoc $BINDIR/ocamldoc$EXE +installbin ocamldoc/ocamldoc.opt $BINDIR/ocamldoc.opt$EXE installdir \ ../ocamldoc/ocamldoc.hva \ @@ -510,30 +511,40 @@ installdir \ camlp4o.cma camlp4of.cma camlp4oof.cma \ camlp4orf.cma camlp4r.cma camlp4rf.cma \ Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \ - Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O \ + Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O Camlp4_import.cmi \ $CAMLP4DIR installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR cd .. echo "Installing ocamlbuild..." -installbin ocamlbuild/ocamlbuild.byte$EXE $BINDIR/ocamlbuild.byte$EXE -installbin ocamlbuild/ocamlbuild.native$EXE $BINDIR/ocamlbuild.native$EXE -installbestbin ocamlbuild/ocamlbuild.native$EXE ocamlbuild/ocamlbuild.byte$EXE $BINDIR/ocamlbuild$EXE +cd ocamlbuild +installbin ocamlbuild.byte$EXE $BINDIR/ocamlbuild.byte$EXE +installbin ocamlbuild.native$EXE $BINDIR/ocamlbuild.native$EXE +installbestbin ocamlbuild.native$EXE ocamlbuild.byte$EXE $BINDIR/ocamlbuild$EXE installlibdir \ - ocamlbuild/ocamlbuildlib.$A \ + ocamlbuildlib.$A \ $LIBDIR/ocamlbuild installdir \ - ocamlbuild/ocamlbuildlib.cmxa \ - ocamlbuild/ocamlbuildlib.cma \ - ocamlbuild/ocamlbuild_plugin.cmi \ - ocamlbuild/ocamlbuild_pack.cmi \ - ocamlbuild/ocamlbuild.cmo \ - ocamlbuild/ocamlbuild.cmx \ - ocamlbuild/ocamlbuild.$O \ + ocamlbuildlib.cmxa \ + ocamlbuildlib.cma \ + ocamlbuild_plugin.cmi \ + ocamlbuild_pack.cmi \ + ocamlbuild_unix_plugin.cmi \ + ocamlbuild_unix_plugin.cmo \ + ocamlbuild_unix_plugin.cmx \ + ocamlbuild_unix_plugin.$O \ + ocamlbuild_executor.cmi \ + ocamlbuild_executor.cmo \ + ocamlbuild_executor.cmx \ + ocamlbuild_executor.$O \ + ocamlbuild.cmo \ + ocamlbuild.cmx \ + ocamlbuild.$O \ $LIBDIR/ocamlbuild +cd .. installdir \ ../ocamlbuild/man/ocamlbuild.1 \ diff --git a/build/mkmyocamlbuild_config.sh b/build/mkmyocamlbuild_config.sh index 1156c83c..3668353c 100755 --- a/build/mkmyocamlbuild_config.sh +++ b/build/mkmyocamlbuild_config.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: mkmyocamlbuild_config.sh,v 1.5.2.1 2007/03/12 11:58:48 pouillar Exp $ +# $Id: mkmyocamlbuild_config.sh,v 1.5.2.3 2007/05/28 09:26:51 pouillar Exp $ cd `dirname $0`/.. @@ -8,13 +8,19 @@ sed \ -e 's/^\(#.*\)$/(* \1 *)/' \ -e 's/^\(.*\$([0-9]).*\)$/(* \1 *)/' \ -e 's/^\([^(=]*\)=\([^"]*\)$/let <:lower<\1>> = "\2";;/' \ + -e 's/\$(AS)/as/g' \ -e 's/\$(\([^)]*\))/"\^<:lower<\1>>\^"/g' \ -e 's/""\^//g' \ -e 's/\^""//g' \ - -e 's/^let <:lower<\(MAKE\|DO\).*$//g' \ + -e 's/^let <:lower myocamlbuild_config.ml + config/Makefile \ + | sed -f build/tolower.sed \ + | sed -f build/tolower.sed \ + | sed -f build/tolower.sed \ + | sed -f build/tolower.sed \ + | sed -f build/tolower.sed \ + | sed -f build/tolower.sed \ + > myocamlbuild_config.ml diff --git a/build/ocamlbuildlib-native-only.sh b/build/ocamlbuildlib-native-only.sh new file mode 100755 index 00000000..007da913 --- /dev/null +++ b/build/ocamlbuildlib-native-only.sh @@ -0,0 +1,9 @@ +#!/bin/sh +# $Id: ocamlbuildlib-native-only.sh,v 1.1.2.1 2007/06/20 13:34:03 ertai Exp $ +set -e +OCAMLBUILD_PARTIAL="true" +export OCAMLBUILD_PARTIAL +cd `dirname $0`/.. +. build/targets.sh +set -x +$OCAMLBUILD $@ native_stdlib_partial_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $OCAMLBUILDLIB_NATIVE diff --git a/build/partial-boot.sh b/build/partial-boot.sh index 639284a2..6af42249 100755 --- a/build/partial-boot.sh +++ b/build/partial-boot.sh @@ -1,14 +1,11 @@ #!/bin/sh -# $Id: partial-boot.sh,v 1.2.4.8 2007/03/12 11:58:48 pouillar Exp $ +# $Id: partial-boot.sh,v 1.2.4.9 2007/05/22 10:54:59 pouillar Exp $ set -ex cd `dirname $0`/.. OCAMLBUILD_PARTIAL="true" export OCAMLBUILD_PARTIAL mkdir -p _build cp -rf boot _build/ -cp parsing/location.ml parsing/location.mli camlp4/build -cp parsing/linenum.mll parsing/linenum.mli camlp4/build -cp utils/terminfo.ml utils/terminfo.mli camlp4/build ./build/mkconfig.sh ./build/mkmyocamlbuild_config.sh ./build/boot.sh diff --git a/build/partial-install.sh b/build/partial-install.sh index 03eddbb2..b7c68496 100755 --- a/build/partial-install.sh +++ b/build/partial-install.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: partial-install.sh,v 1.5.2.9 2007/04/05 08:12:39 pouillar Exp $ +# $Id: partial-install.sh,v 1.5.2.11 2007/11/22 18:45:18 ertai Exp $ ###################################### ######### Copied from build/install.sh @@ -134,7 +134,7 @@ installdir \ camlp4o.cma camlp4of.cma camlp4oof.cma \ camlp4orf.cma camlp4r.cma camlp4rf.cma \ Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \ - Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O \ + Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O Camlp4_import.cmi \ $CAMLP4DIR installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR cd .. @@ -154,6 +154,14 @@ installdir \ ocamlbuildlib.cma \ ocamlbuild_plugin.cmi \ ocamlbuild_pack.cmi \ + ocamlbuild_unix_plugin.cmi \ + ocamlbuild_unix_plugin.cmo \ + ocamlbuild_unix_plugin.cmx \ + ocamlbuild_unix_plugin.$O \ + ocamlbuild_executor.cmi \ + ocamlbuild_executor.cmo \ + ocamlbuild_executor.cmx \ + ocamlbuild_executor.$O \ ocamlbuild.cmo \ ocamlbuild.cmx \ ocamlbuild.$O \ diff --git a/build/targets.sh b/build/targets.sh index 1ef9f33a..ec18a2f6 100644 --- a/build/targets.sh +++ b/build/targets.sh @@ -1,4 +1,4 @@ -# $Id: targets.sh,v 1.2.4.6 2007/03/12 11:58:48 pouillar Exp $ +# $Id: targets.sh,v 1.2.4.7 2007/06/20 13:26:29 ertai Exp $ . config/config.sh . build/otherlibs-targets.sh . build/camlp4-targets.sh @@ -38,8 +38,9 @@ OCAMLOPT_NATIVE=ocamlopt.opt$EXE OCAMLLEX_NATIVE=lex/ocamllex.opt$EXE TOOLS_NATIVE=tools/ocamldep.native$EXE OCAMLDOC_NATIVE="ocamldoc/ocamldoc.opt$EXE ocamldoc/odoc_info.cmxa ocamldoc/stdlib_man/Pervasives.3o" -OCAMLBUILD_NATIVE="ocamlbuild/ocamlbuildlib.cmxa \ - ocamlbuild/ocamlbuildlightlib.cmxa \ +OCAMLBUILDLIB_NATIVE="ocamlbuild/ocamlbuildlib.cmxa \ + ocamlbuild/ocamlbuildlightlib.cmxa" +OCAMLBUILD_NATIVE="$OCAMLBUILDLIB_NATIVE \ ocamlbuild/ocamlbuild.native$EXE \ ocamlbuild/ocamlbuildlight.native$EXE" if [ -x boot/myocamlbuild.native ]; then diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 87649916..11b443c7 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: matching.ml,v 1.67 2005/09/07 16:07:48 maranget Exp $ *) +(* $Id: matching.ml,v 1.67.12.1 2007/06/08 08:03:16 garrigue Exp $ *) (* Compilation of pattern matching *) @@ -2337,8 +2337,8 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with ctx pm | Tpat_variant(lab, _, row) -> compile_test (compile_match repr partial) partial - (divide_variant row) - (combine_variant row arg partial) + (divide_variant !row) + (combine_variant !row arg partial) ctx pm | _ -> assert false end diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index f785abbe..2e268f8c 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translclass.ml,v 1.41 2006/07/06 07:32:28 garrigue Exp $ *) +(* $Id: translclass.ml,v 1.41.8.4 2007/10/29 06:56:26 garrigue Exp $ *) open Misc open Asttypes @@ -71,10 +71,10 @@ let transl_val tbl create name = Lapply (oo_prim (if create then "new_variable" else "get_variable"), [Lvar tbl; transl_label name]) -let transl_vals tbl create vals rem = +let transl_vals tbl create strict vals rem = List.fold_right (fun (name, id) rem -> - Llet(StrictOpt, id, transl_val tbl create name, rem)) + Llet(strict, id, transl_val tbl create name, rem)) vals rem let meths_super tbl meths inh_meths = @@ -88,7 +88,7 @@ let meths_super tbl meths inh_meths = inh_meths [] let bind_super tbl (vals, meths) cl_init = - transl_vals tbl false vals + transl_vals tbl false StrictOpt vals (List.fold_right (fun (nm, id, def) rem -> Llet(StrictOpt, id, def, rem)) meths cl_init) @@ -203,22 +203,22 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = let bind_method tbl lab id cl_init = - Llet(StrictOpt, id, Lapply (oo_prim "get_method_label", - [Lvar tbl; transl_label lab]), + Llet(Strict, id, Lapply (oo_prim "get_method_label", + [Lvar tbl; transl_label lab]), cl_init) let bind_methods tbl meths vals cl_init = let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in let len = List.length methl and nvals = List.length vals in if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else - if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else + if len = 0 && nvals < 2 then transl_vals tbl true Strict vals cl_init else let ids = Ident.create "ids" in let i = ref (len + nvals) in let getter, names = if nvals = 0 then "get_method_labels", [] else "new_methods_variables", [transl_meth_list (List.map fst vals)] in - Llet(StrictOpt, ids, + Llet(Strict, ids, Lapply (oo_prim getter, [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), List.fold_right @@ -246,6 +246,8 @@ let rec index a = function | b :: l -> if b = a then 0 else 1 + index a l +let bind_id_as_val (id, _) = ("", id) + let rec build_class_init cla cstr super inh_init cl_init msubst top cl = match cl.cl_desc with Tclass_ident path -> @@ -308,16 +310,16 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in - let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in - (inh_init, transl_vals cla true vals cl_init) + let vals = List.map bind_id_as_val vals in + (inh_init, transl_vals cla true StrictOpt vals cl_init) | Tclass_apply (cl, exprs) -> build_class_init cla cstr super inh_init cl_init msubst top cl | Tclass_let (rec_flag, defs, vals, cl) -> let (inh_init, cl_init) = build_class_init cla cstr super inh_init cl_init msubst top cl in - let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in - (inh_init, transl_vals cla true vals cl_init) + let vals = List.map bind_id_as_val vals in + (inh_init, transl_vals cla true StrictOpt vals cl_init) | Tclass_constraint (cl, vals, meths, concr_meths) -> let virt_meths = List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in @@ -583,6 +585,9 @@ open M Si ids=0 (objet immediat), alors on ne conserve que env_init. *) +let prerr_ids msg ids = + let names = List.map Ident.unique_toplevel_name ids in + prerr_endline (String.concat " " (msg :: names)) let transl_class ids cl_id arity pub_meths cl vflag = (* First check if it is not only a rebind *) @@ -600,10 +605,6 @@ let transl_class ids cl_id arity pub_meths cl vflag = let subst env lam i0 new_ids' = let fv = free_variables lam in let fv = List.fold_right IdentSet.remove !new_ids' fv in - (* IdentSet.iter - (fun id -> - if not (List.mem id new_ids) then prerr_endline (Ident.name id)) - fv; *) let fv = IdentSet.filter (fun id -> List.mem id new_ids) fv in (* need to handle methods specially (PR#3576) *) let fm = IdentSet.diff (free_methods lam) meth_ids in diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index eac0c639..24aa6343 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translmod.ml,v 1.52 2006/04/05 02:28:12 garrigue Exp $ *) +(* $Id: translmod.ml,v 1.52.8.1 2007/11/10 14:32:43 xleroy Exp $ *) (* Translation from typed abstract syntax to lambda terms, for the module language *) @@ -333,7 +333,7 @@ and transl_structure fields cc rootpath = function | id :: ids -> Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]), rebind_idents (pos + 1) (id :: newfields) ids) in - Llet(Alias, mid, transl_module Tcoerce_none None modl, + Llet(Strict, mid, transl_module Tcoerce_none None modl, rebind_idents 0 fields ids) (* Update forward declaration in Translcore *) diff --git a/byterun/compare.c b/byterun/compare.c index 9d59107b..8f4a5d75 100644 --- a/byterun/compare.c +++ b/byterun/compare.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: compare.c,v 1.36 2007/02/09 13:31:15 doligez Exp $ */ +/* $Id: compare.c,v 1.36.4.1 2008/01/03 09:54:17 xleroy Exp $ */ #include #include @@ -269,14 +269,14 @@ CAMLprim value caml_lessthan(value v1, value v2) { intnat res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); - return Val_int(res - 1 < -1); + return Val_int(res < 0 && res != UNORDERED); } CAMLprim value caml_lessequal(value v1, value v2) { intnat res = compare_val(v1, v2, 0); if (compare_stack != compare_stack_init) compare_free_stack(); - return Val_int(res - 1 <= -1); + return Val_int(res <= 0 && res != UNORDERED); } CAMLprim value caml_greaterthan(value v1, value v2) diff --git a/byterun/finalise.c b/byterun/finalise.c index b8426ae2..ed1e91bc 100644 --- a/byterun/finalise.c +++ b/byterun/finalise.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: finalise.c,v 1.19 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: finalise.c,v 1.19.10.1 2007/11/19 17:15:53 doligez Exp $ */ /* Handling of finalised values. */ @@ -24,6 +24,7 @@ struct final { value fun; value val; + int offset; }; static struct final *final_table = NULL; @@ -67,7 +68,7 @@ void caml_final_update (void) { uintnat i, j, k; uintnat todo_count = 0; - + Assert (young == old); for (i = 0; i < old; i++){ Assert (Is_block (final_table[i].val)); @@ -84,6 +85,7 @@ void caml_final_update (void) Assert (Is_in_heap (final_table[i].val)); if (Is_white_val (final_table[i].val)){ if (Tag_val (final_table[i].val) == Forward_tag){ + Assert (final_table[i].offset == 0); value fv = Forward_val (final_table[i].val); if (Is_block (fv) && (Is_young (fv) || Is_in_heap (fv)) && (Tag_val (fv) == Forward_tag || Tag_val (fv) == Lazy_tag @@ -136,7 +138,7 @@ void caml_final_do_calls (void) -- to_do_hd->size; f = to_do_hd->item[to_do_hd->size]; running_finalisation_function = 1; - caml_callback (f.fun, f.val); + caml_callback (f.fun, f.val + f.offset); running_finalisation_function = 0; } caml_gc_message (0x80, "Done calling finalisation functions.\n", 0); @@ -159,7 +161,7 @@ void caml_final_do_strong_roots (scanning_action f) Assert (old == young); for (i = 0; i < old; i++) Call_action (f, final_table[i].fun); - + for (todo = to_do_hd; todo != NULL; todo = todo->next){ for (i = 0; i < todo->size; i++){ Call_action (f, todo->item[i].fun); @@ -186,7 +188,7 @@ void caml_final_do_weak_roots (scanning_action f) void caml_final_do_young_roots (scanning_action f) { uintnat i; - + Assert (old <= young); for (i = old; i < young; i++){ Call_action (f, final_table[i].fun); @@ -210,7 +212,7 @@ CAMLprim value caml_final_register (value f, value v) caml_invalid_argument ("Gc.finalise"); } Assert (old <= young); - + if (young >= size){ if (final_table == NULL){ uintnat new_size = 30; @@ -227,8 +229,13 @@ CAMLprim value caml_final_register (value f, value v) } Assert (young < size); final_table[young].fun = f; - if (Tag_val (v) == Infix_tag) v -= Infix_offset_val (v); - final_table[young].val = v; + if (Tag_val (v) == Infix_tag){ + final_table[young].offset = Infix_offset_val (v); + final_table[young].val = v - Infix_offset_val (v); + }else{ + final_table[young].offset = 0; + final_table[young].val = v; + } ++ young; return Val_unit; diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index 2273399f..fa5c7034 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: gc_ctrl.c,v 1.50 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: gc_ctrl.c,v 1.50.10.1 2007/11/20 18:27:06 doligez Exp $ */ #include "alloc.h" #include "compact.h" @@ -78,7 +78,7 @@ static void check_block (char *hp) mlsize_t i; value v = Val_hp (hp); value f; - + check_head (v); switch (Tag_hp (hp)){ case Abstract_tag: break; @@ -93,7 +93,7 @@ static void check_block (char *hp) case Custom_tag: Assert (!Is_in_heap (Custom_ops_val (v))); break; - + case Infix_tag: Assert (0); break; @@ -102,7 +102,10 @@ static void check_block (char *hp) Assert (Tag_hp (hp) < No_scan_tag); for (i = 0; i < Wosize_hp (hp); i++){ f = Field (v, i); - if (Is_block (f) && Is_in_heap (f)) check_head (f); + if (Is_block (f) && Is_in_heap (f)){ + check_head (f); + Assert (Color_val (f) != Caml_blue); + } } } } diff --git a/byterun/intern.c b/byterun/intern.c index c340b1b6..fbc4fe14 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: intern.c,v 1.60 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: intern.c,v 1.60.10.1 2007/10/09 12:48:54 xleroy Exp $ */ /* Structured input, compact format */ @@ -76,7 +76,7 @@ static value intern_block; (Sign_extend(intern_src[-2]) << 8) + intern_src[-1]) #define read32u() \ (intern_src += 4, \ - (intern_src[-4] << 24) + (intern_src[-3] << 16) + \ + ((uintnat)(intern_src[-4]) << 24) + (intern_src[-3] << 16) + \ (intern_src[-2] << 8) + intern_src[-1]) #define read32s() \ (intern_src += 4, \ diff --git a/byterun/ints.c b/byterun/ints.c index 063b75f0..d953374b 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: ints.c,v 1.50 2006/05/05 13:50:45 xleroy Exp $ */ +/* $Id: ints.c,v 1.50.6.1 2007/10/25 11:39:45 xleroy Exp $ */ #include #include @@ -551,15 +551,21 @@ CAMLprim value caml_int64_of_string(value s) CAMLprim value caml_int64_bits_of_float(value vd) { - union { double d; int64 i; } u; + union { double d; int64 i; int32 h[2]; } u; u.d = Double_val(vd); +#if defined(__arm__) && !defined(__ARM_EABI__) + { int32 t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } +#endif return caml_copy_int64(u.i); } CAMLprim value caml_int64_float_of_bits(value vi) { - union { double d; int64 i; } u; + union { double d; int64 i; int32 h[2]; } u; u.i = Int64_val(vi); +#if defined(__arm__) && !defined(__ARM_EABI__) + { int32 t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } +#endif return caml_copy_double(u.d); } diff --git a/byterun/io.h b/byterun/io.h index d67ceb4f..749027aa 100644 --- a/byterun/io.h +++ b/byterun/io.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: io.h,v 1.30 2006/09/20 17:37:08 xleroy Exp $ */ +/* $Id: io.h,v 1.30.6.1 2007/05/21 13:17:47 doligez Exp $ */ /* Buffered input/output */ @@ -52,7 +52,7 @@ struct channel { }; enum { - CHANNEL_FLAG_FROM_SOCKET = 1, /* For Windows */ + CHANNEL_FLAG_FROM_SOCKET = 1 /* For Windows */ }; /* For an output channel: diff --git a/byterun/major_gc.c b/byterun/major_gc.c index 8474e791..1f3ce458 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: major_gc.c,v 1.58 2005/10/25 16:24:13 doligez Exp $ */ +/* $Id: major_gc.c,v 1.58.10.2 2007/11/26 16:11:49 doligez Exp $ */ #include @@ -50,12 +50,17 @@ extern char *caml_fl_merge; /* Defined in freelist.c. */ static char *markhp, *chunk, *limit; -static int gc_subphase; /* Subphase_main, Subphase_weak, Subphase_final */ +static int gc_subphase; /* Subphase_main Subphase_weak[12] Subphase_final */ #define Subphase_main 10 -#define Subphase_weak 11 -#define Subphase_final 12 +#define Subphase_weak1 11 +#define Subphase_weak2 12 +#define Subphase_final 13 static value *weak_prev; +#ifdef DEBUG +static unsigned long major_gc_counter = 0; +#endif + static void realloc_gray_vals (void) { value *new; @@ -116,6 +121,7 @@ static void start_cycle (void) gc_subphase = Subphase_main; markhp = NULL; #ifdef DEBUG + ++ major_gc_counter; caml_heap_check (); #endif } @@ -128,6 +134,7 @@ static void mark_slice (intnat work) mlsize_t size, i; caml_gc_message (0x40, "Marking %ld words\n", work); + caml_gc_message (0x40, "Subphase = %ld\n", gc_subphase); gray_vals_ptr = gray_vals_cur; while (work > 0){ if (gray_vals_ptr > gray_vals){ @@ -189,27 +196,27 @@ static void mark_slice (intnat work) chunk = caml_heap_start; markhp = chunk; limit = chunk + Chunk_size (chunk); - }else if (gc_subphase == Subphase_main){ - /* The main marking phase is over. Start removing weak pointers to - dead values. */ - gc_subphase = Subphase_weak; - weak_prev = &caml_weak_list_head; - }else if (gc_subphase == Subphase_weak){ - value cur, curfield; - mlsize_t sz, i; - header_t hd; - - cur = *weak_prev; - if (cur != (value) NULL){ - hd = Hd_val (cur); - if (Color_hd (hd) == Caml_white){ - /* The whole array is dead, remove it from the list. */ - *weak_prev = Field (cur, 0); - }else{ + }else{ + switch (gc_subphase){ + case Subphase_main: { + /* The main marking phase is over. Start removing weak pointers to + dead values. */ + gc_subphase = Subphase_weak1; + weak_prev = &caml_weak_list_head; + } + break; + case Subphase_weak1: { + value cur, curfield; + mlsize_t sz, i; + header_t hd; + + cur = *weak_prev; + if (cur != (value) NULL){ + hd = Hd_val (cur); sz = Wosize_hd (hd); for (i = 1; i < sz; i++){ curfield = Field (cur, i); - weak_again: + weak_again: if (curfield != caml_weak_none && Is_block (curfield) && Is_in_heap (curfield)){ if (Tag_val (curfield) == Forward_tag){ @@ -230,27 +237,52 @@ static void mark_slice (intnat work) } } weak_prev = &Field (cur, 0); + work -= Whsize_hd (hd); + }else{ + /* Subphase_weak1 is done. Start removing dead weak arrays. */ + gc_subphase = Subphase_weak2; + weak_prev = &caml_weak_list_head; } - work -= Whsize_hd (hd); - }else{ - /* Subphase_weak is done. Handle finalised values. */ + } + break; + case Subphase_weak2: { + value cur; + header_t hd; + + cur = *weak_prev; + if (cur != (value) NULL){ + hd = Hd_val (cur); + if (Color_hd (hd) == Caml_white){ + /* The whole array is dead, remove it from the list. */ + *weak_prev = Field (cur, 0); + }else{ + weak_prev = &Field (cur, 0); + } + work -= 1; + }else{ + /* Subphase_weak2 is done. Handle finalised values. */ + gray_vals_cur = gray_vals_ptr; + caml_final_update (); + gray_vals_ptr = gray_vals_cur; + gc_subphase = Subphase_final; + } + } + break; + case Subphase_final: { + /* Initialise the sweep phase. */ gray_vals_cur = gray_vals_ptr; - caml_final_update (); - gray_vals_ptr = gray_vals_cur; - gc_subphase = Subphase_final; + caml_gc_sweep_hp = caml_heap_start; + caml_fl_init_merge (); + caml_gc_phase = Phase_sweep; + chunk = caml_heap_start; + caml_gc_sweep_hp = chunk; + limit = chunk + Chunk_size (chunk); + work = 0; + caml_fl_size_at_phase_change = caml_fl_cur_size; + } + break; + default: Assert (0); } - }else{ - Assert (gc_subphase == Subphase_final); - /* Initialise the sweep phase. */ - gray_vals_cur = gray_vals_ptr; - caml_gc_sweep_hp = caml_heap_start; - caml_fl_init_merge (); - caml_gc_phase = Phase_sweep; - chunk = caml_heap_start; - caml_gc_sweep_hp = chunk; - limit = chunk + Chunk_size (chunk); - work = 0; - caml_fl_size_at_phase_change = caml_fl_cur_size; } } gray_vals_cur = gray_vals_ptr; @@ -354,7 +386,7 @@ intnat caml_major_collection_slice (intnat howmuch) if (p < dp) p = dp; if (p < caml_extra_heap_resources) p = caml_extra_heap_resources; - caml_gc_message (0x40, "allocated_words = %" + caml_gc_message (0x40, "allocated_words = %" ARCH_INTNAT_PRINTF_FORMAT "u\n", caml_allocated_words); caml_gc_message (0x40, "extra_heap_resources = %" diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c index 71b1b38f..96904671 100644 --- a/byterun/minor_gc.c +++ b/byterun/minor_gc.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: minor_gc.c,v 1.43 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: minor_gc.c,v 1.43.10.1 2007/11/20 18:27:06 doligez Exp $ */ #include #include "config.h" @@ -35,6 +35,10 @@ CAMLexport value **caml_ref_table_ptr = NULL, **caml_ref_table_limit; static asize_t ref_table_size, ref_table_reserve; int caml_in_minor_collection = 0; +#ifdef DEBUG +static unsigned long minor_gc_counter = 0; +#endif + void caml_set_minor_heap_size (asize_t size) { char *new_heap; @@ -207,6 +211,7 @@ void caml_empty_minor_heap (void) for (p = (value *) caml_young_start; p < (value *) caml_young_end; ++p){ *p = Debug_free_minor; } + ++ minor_gc_counter; } #endif } @@ -254,7 +259,7 @@ void caml_realloc_ref_table (void) ref_table_size *= 2; sz = (ref_table_size + ref_table_reserve) * sizeof (value *); - caml_gc_message (0x08, "Growing ref_table to %" + caml_gc_message (0x08, "Growing ref_table to %" ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n", (intnat) sz/1024); ref_table = (value **) realloc ((char *) ref_table, sz); diff --git a/byterun/unix.c b/byterun/unix.c index 1198d4e0..d8466d3a 100644 --- a/byterun/unix.c +++ b/byterun/unix.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: unix.c,v 1.28 2007/02/12 07:57:25 weis Exp $ */ +/* $Id: unix.c,v 1.28.4.1 2007/11/20 15:47:41 xleroy Exp $ */ /* Unix-specific stuff */ @@ -350,10 +350,13 @@ char *caml_aligned_mmap (asize_t size, int modulo, void **block) { char *raw_mem; uintnat aligned_mem; + static char * last_addr = NULL; /* hint, see PR#4448 */ + Assert (modulo < Page_size); - raw_mem = (char *) mmap(NULL, size + Page_size, PROT_READ | PROT_WRITE, + raw_mem = (char *) mmap(last_addr, size + Page_size, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); if (raw_mem == MAP_FAILED) return NULL; + last_addr = raw_mem + size + 2 * Page_size; *block = raw_mem; raw_mem += modulo; /* Address to be aligned */ aligned_mem = (((uintnat) raw_mem / Page_size + 1) * Page_size); diff --git a/camlp4/Camlp4/Camlp4Ast.partial.ml b/camlp4/Camlp4/Camlp4Ast.partial.ml index 7a902376..5d9da823 100644 --- a/camlp4/Camlp4/Camlp4Ast.partial.ml +++ b/camlp4/Camlp4/Camlp4Ast.partial.ml @@ -1,348 +1,345 @@ - - type meta_bool = + type loc = Loc.t + and meta_bool = [ BTrue | BFalse - | BAnt of string ]; - type meta_option 'a = + | BAnt of string ] + and meta_option 'a = [ ONone | OSome of 'a - | OAnt of string ]; - type meta_list 'a = + | OAnt of string ] + and meta_list 'a = [ LNil | LCons of 'a and meta_list 'a - | LAnt of string ]; - type ident = - [ IdAcc of Loc.t and ident and ident (* i . i *) - | IdApp of Loc.t and ident and ident (* i i *) - | IdLid of Loc.t and string (* foo *) - | IdUid of Loc.t and string (* Bar *) - | IdAnt of Loc.t and string (* $s$ *) ]; - type ctyp = - [ TyNil of Loc.t - | TyAli of Loc.t and ctyp and ctyp (* t as t *) (* list 'a as 'a *) - | TyAny of Loc.t (* _ *) - | TyApp of Loc.t and ctyp and ctyp (* t t *) (* list 'a *) - | TyArr of Loc.t and ctyp and ctyp (* t -> t *) (* int -> string *) - | TyCls of Loc.t and ident (* #i *) (* #point *) - | TyLab of Loc.t and string and ctyp (* ~s *) - | TyId of Loc.t and ident (* i *) (* Lazy.t *) - | TyMan of Loc.t and ctyp and ctyp (* t == t *) (* type t = [ A | B ] == Foo.t *) + | LAnt of string ] + and ident = + [ IdAcc of loc and ident and ident (* i . i *) + | IdApp of loc and ident and ident (* i i *) + | IdLid of loc and string (* foo *) + | IdUid of loc and string (* Bar *) + | IdAnt of loc and string (* $s$ *) ] + and ctyp = + [ TyNil of loc + | TyAli of loc and ctyp and ctyp (* t as t *) (* list 'a as 'a *) + | TyAny of loc (* _ *) + | TyApp of loc and ctyp and ctyp (* t t *) (* list 'a *) + | TyArr of loc and ctyp and ctyp (* t -> t *) (* int -> string *) + | TyCls of loc and ident (* #i *) (* #point *) + | TyLab of loc and string and ctyp (* ~s:t *) + | TyId of loc and ident (* i *) (* Lazy.t *) + | TyMan of loc and ctyp and ctyp (* t == t *) (* type t = [ A | B ] == Foo.t *) (* type t 'a 'b 'c = t constraint t = t constraint t = t *) - | TyDcl of Loc.t and string and list ctyp and ctyp and list (ctyp * ctyp) + | TyDcl of loc and string and list ctyp and ctyp and list (ctyp * ctyp) (* < (t)? (..)? > *) (* < move : int -> 'a .. > as 'a *) - | TyObj of Loc.t and ctyp and meta_bool - | TyOlb of Loc.t and string and ctyp (* ?s *) - | TyPol of Loc.t and ctyp and ctyp (* ! t . t *) (* ! 'a . list 'a -> 'a *) - | TyQuo of Loc.t and string (* 's *) - | TyQuP of Loc.t and string (* +'s *) - | TyQuM of Loc.t and string (* -'s *) - | TyVrn of Loc.t and string (* `s *) - | TyRec of Loc.t and ctyp (* { t } *) (* { foo : int ; bar : mutable string } *) - | TyCol of Loc.t and ctyp and ctyp (* t : t *) - | TySem of Loc.t and ctyp and ctyp (* t; t *) - | TyCom of Loc.t and ctyp and ctyp (* t, t *) - | TySum of Loc.t and ctyp (* [ t ] *) (* [ A of int and string | B ] *) - | TyOf of Loc.t and ctyp and ctyp (* t of t *) (* A of int *) - | TyAnd of Loc.t and ctyp and ctyp (* t and t *) - | TyOr of Loc.t and ctyp and ctyp (* t | t *) - | TyPrv of Loc.t and ctyp (* private t *) - | TyMut of Loc.t and ctyp (* mutable t *) - | TyTup of Loc.t and ctyp (* ( t ) *) (* (int * string) *) - | TySta of Loc.t and ctyp and ctyp (* t * t *) - | TyVrnEq of Loc.t and ctyp (* [ = t ] *) - | TyVrnSup of Loc.t and ctyp (* [ > t ] *) - | TyVrnInf of Loc.t and ctyp (* [ < t ] *) - | TyVrnInfSup of Loc.t and ctyp and ctyp (* [ < t > t ] *) - | TyAmp of Loc.t and ctyp and ctyp (* t & t *) - | TyOfAmp of Loc.t and ctyp and ctyp (* t of & t *) - | TyAnt of Loc.t and string (* $s$ *) + | TyObj of loc and ctyp and meta_bool + | TyOlb of loc and string and ctyp (* ?s:t *) + | TyPol of loc and ctyp and ctyp (* ! t . t *) (* ! 'a . list 'a -> 'a *) + | TyQuo of loc and string (* 's *) + | TyQuP of loc and string (* +'s *) + | TyQuM of loc and string (* -'s *) + | TyVrn of loc and string (* `s *) + | TyRec of loc and ctyp (* { t } *) (* { foo : int ; bar : mutable string } *) + | TyCol of loc and ctyp and ctyp (* t : t *) + | TySem of loc and ctyp and ctyp (* t; t *) + | TyCom of loc and ctyp and ctyp (* t, t *) + | TySum of loc and ctyp (* [ t ] *) (* [ A of int and string | B ] *) + | TyOf of loc and ctyp and ctyp (* t of t *) (* A of int *) + | TyAnd of loc and ctyp and ctyp (* t and t *) + | TyOr of loc and ctyp and ctyp (* t | t *) + | TyPrv of loc and ctyp (* private t *) + | TyMut of loc and ctyp (* mutable t *) + | TyTup of loc and ctyp (* ( t ) *) (* (int * string) *) + | TySta of loc and ctyp and ctyp (* t * t *) + | TyVrnEq of loc and ctyp (* [ = t ] *) + | TyVrnSup of loc and ctyp (* [ > t ] *) + | TyVrnInf of loc and ctyp (* [ < t ] *) + | TyVrnInfSup of loc and ctyp and ctyp (* [ < t > t ] *) + | TyAmp of loc and ctyp and ctyp (* t & t *) + | TyOfAmp of loc and ctyp and ctyp (* t of & t *) + | TyAnt of loc and string (* $s$ *) ] - ; - type patt = - [ PaNil of Loc.t - | PaId of Loc.t and ident (* i *) - | PaAli of Loc.t and patt and patt (* p as p *) (* (Node x y as n) *) - | PaAnt of Loc.t and string (* $s$ *) - | PaAny of Loc.t (* _ *) - | PaApp of Loc.t and patt and patt (* p p *) (* fun x y -> *) - | PaArr of Loc.t and patt (* [| p |] *) - | PaCom of Loc.t and patt and patt (* p, p *) - | PaSem of Loc.t and patt and patt (* p; p *) - | PaChr of Loc.t and string (* c *) (* 'x' *) - | PaInt of Loc.t and string - | PaInt32 of Loc.t and string - | PaInt64 of Loc.t and string - | PaNativeInt of Loc.t and string - | PaFlo of Loc.t and string - | PaLab of Loc.t and string and patt (* ~s or ~s:(p) *) - (* ?s or ?s:(p = e) or ?(p = e) *) - (* | PaOlb of Loc.t and string and meta_option(*FIXME*) (patt * meta_option(*FIXME*) expr) *) + and patt = + [ PaNil of loc + | PaId of loc and ident (* i *) + | PaAli of loc and patt and patt (* p as p *) (* (Node x y as n) *) + | PaAnt of loc and string (* $s$ *) + | PaAny of loc (* _ *) + | PaApp of loc and patt and patt (* p p *) (* fun x y -> *) + | PaArr of loc and patt (* [| p |] *) + | PaCom of loc and patt and patt (* p, p *) + | PaSem of loc and patt and patt (* p; p *) + | PaChr of loc and string (* c *) (* 'x' *) + | PaInt of loc and string + | PaInt32 of loc and string + | PaInt64 of loc and string + | PaNativeInt of loc and string + | PaFlo of loc and string + | PaLab of loc and string and patt (* ~s or ~s:(p) *) (* ?s or ?s:(p) *) - | PaOlb of Loc.t and string and patt + | PaOlb of loc and string and patt (* ?s:(p = e) or ?(p = e) *) - | PaOlbi of Loc.t and string and patt and expr - | PaOrp of Loc.t and patt and patt (* p | p *) - | PaRng of Loc.t and patt and patt (* p .. p *) - | PaRec of Loc.t and patt (* { p } *) - | PaEq of Loc.t and ident and patt (* i = p *) - | PaStr of Loc.t and string (* s *) - | PaTup of Loc.t and patt (* ( p ) *) - | PaTyc of Loc.t and patt and ctyp (* (p : t) *) - | PaTyp of Loc.t and ident (* #i *) - | PaVrn of Loc.t and string (* `s *) ] + | PaOlbi of loc and string and patt and expr + | PaOrp of loc and patt and patt (* p | p *) + | PaRng of loc and patt and patt (* p .. p *) + | PaRec of loc and patt (* { p } *) + | PaEq of loc and ident and patt (* i = p *) + | PaStr of loc and string (* s *) + | PaTup of loc and patt (* ( p ) *) + | PaTyc of loc and patt and ctyp (* (p : t) *) + | PaTyp of loc and ident (* #i *) + | PaVrn of loc and string (* `s *) ] and expr = - [ ExNil of Loc.t - | ExId of Loc.t and ident (* i *) - | ExAcc of Loc.t and expr and expr (* e.e *) - | ExAnt of Loc.t and string (* $s$ *) - | ExApp of Loc.t and expr and expr (* e e *) - | ExAre of Loc.t and expr and expr (* e.(e) *) - | ExArr of Loc.t and expr (* [| e |] *) - | ExSem of Loc.t and expr and expr (* e; e *) - | ExAsf of Loc.t (* assert False *) - | ExAsr of Loc.t and expr (* assert e *) - | ExAss of Loc.t and expr and expr (* e := e *) - | ExChr of Loc.t and string (* 'c' *) - | ExCoe of Loc.t and expr and ctyp and ctyp (* (e : t) or (e : t :> t) *) - | ExFlo of Loc.t and string (* 3.14 *) + [ ExNil of loc + | ExId of loc and ident (* i *) + | ExAcc of loc and expr and expr (* e.e *) + | ExAnt of loc and string (* $s$ *) + | ExApp of loc and expr and expr (* e e *) + | ExAre of loc and expr and expr (* e.(e) *) + | ExArr of loc and expr (* [| e |] *) + | ExSem of loc and expr and expr (* e; e *) + | ExAsf of loc (* assert False *) + | ExAsr of loc and expr (* assert e *) + | ExAss of loc and expr and expr (* e := e *) + | ExChr of loc and string (* 'c' *) + | ExCoe of loc and expr and ctyp and ctyp (* (e : t) or (e : t :> t) *) + | ExFlo of loc and string (* 3.14 *) (* for s = e to/downto e do { e } *) - | ExFor of Loc.t and string and expr and expr and meta_bool and expr - | ExFun of Loc.t and match_case (* fun [ a ] *) - | ExIfe of Loc.t and expr and expr and expr (* if e then e else e *) - | ExInt of Loc.t and string (* 42 *) - | ExInt32 of Loc.t and string - | ExInt64 of Loc.t and string - | ExNativeInt of Loc.t and string - | ExLab of Loc.t and string and expr (* ~s or ~s:e *) - | ExLaz of Loc.t and expr (* lazy e *) + | ExFor of loc and string and expr and expr and meta_bool and expr + | ExFun of loc and match_case (* fun [ mc ] *) + | ExIfe of loc and expr and expr and expr (* if e then e else e *) + | ExInt of loc and string (* 42 *) + | ExInt32 of loc and string + | ExInt64 of loc and string + | ExNativeInt of loc and string + | ExLab of loc and string and expr (* ~s or ~s:e *) + | ExLaz of loc and expr (* lazy e *) (* let b in e or let rec b in e *) - | ExLet of Loc.t and meta_bool and binding and expr + | ExLet of loc and meta_bool and binding and expr (* let module s = me in e *) - | ExLmd of Loc.t and string and module_expr and expr - (* match e with [ a ] *) - | ExMat of Loc.t and expr and match_case + | ExLmd of loc and string and module_expr and expr + (* match e with [ mc ] *) + | ExMat of loc and expr and match_case (* new i *) - | ExNew of Loc.t and ident + | ExNew of loc and ident (* object ((p))? (cst)? end *) - | ExObj of Loc.t and patt and class_str_item + | ExObj of loc and patt and class_str_item (* ?s or ?s:e *) - | ExOlb of Loc.t and string and expr - (* {< b >} *) - | ExOvr of Loc.t and rec_binding - (* { b } or { (e) with b } *) - | ExRec of Loc.t and rec_binding and expr + | ExOlb of loc and string and expr + (* {< rb >} *) + | ExOvr of loc and rec_binding + (* { rb } or { (e) with rb } *) + | ExRec of loc and rec_binding and expr (* do { e } *) - | ExSeq of Loc.t and expr + | ExSeq of loc and expr (* e#s *) - | ExSnd of Loc.t and expr and string + | ExSnd of loc and expr and string (* e.[e] *) - | ExSte of Loc.t and expr and expr + | ExSte of loc and expr and expr (* s *) (* "foo" *) - | ExStr of Loc.t and string - (* try e with [ a ] *) - | ExTry of Loc.t and expr and match_case + | ExStr of loc and string + (* try e with [ mc ] *) + | ExTry of loc and expr and match_case (* (e) *) - | ExTup of Loc.t and expr + | ExTup of loc and expr (* e, e *) - | ExCom of Loc.t and expr and expr + | ExCom of loc and expr and expr (* (e : t) *) - | ExTyc of Loc.t and expr and ctyp + | ExTyc of loc and expr and ctyp (* `s *) - | ExVrn of Loc.t and string + | ExVrn of loc and string (* while e do { e } *) - | ExWhi of Loc.t and expr and expr ] + | ExWhi of loc and expr and expr ] and module_type = - [ MtNil of Loc.t + [ MtNil of loc (* i *) (* A.B.C *) - | MtId of Loc.t and ident + | MtId of loc and ident (* functor (s : mt) -> mt *) - | MtFun of Loc.t and string and module_type and module_type + | MtFun of loc and string and module_type and module_type (* 's *) - | MtQuo of Loc.t and string - (* sig (sg)? end *) - | MtSig of Loc.t and sig_item + | MtQuo of loc and string + (* sig sg end *) + | MtSig of loc and sig_item (* mt with wc *) - | MtWit of Loc.t and module_type and with_constr - | MtAnt of Loc.t and string (* $s$ *) ] + | MtWit of loc and module_type and with_constr + | MtAnt of loc and string (* $s$ *) ] and sig_item = - [ SgNil of Loc.t + [ SgNil of loc (* class cict *) - | SgCls of Loc.t and class_type + | SgCls of loc and class_type (* class type cict *) - | SgClt of Loc.t and class_type + | SgClt of loc and class_type (* sg ; sg *) - | SgSem of Loc.t and sig_item and sig_item + | SgSem of loc and sig_item and sig_item (* # s or # s e *) - | SgDir of Loc.t and string and expr + | SgDir of loc and string and expr (* exception t *) - | SgExc of Loc.t and ctyp + | SgExc of loc and ctyp (* external s : t = s ... s *) - | SgExt of Loc.t and string and ctyp and meta_list string + | SgExt of loc and string and ctyp and meta_list string (* include mt *) - | SgInc of Loc.t and module_type + | SgInc of loc and module_type (* module s : mt *) - | SgMod of Loc.t and string and module_type + | SgMod of loc and string and module_type (* module rec mb *) - | SgRecMod of Loc.t and module_binding + | SgRecMod of loc and module_binding (* module type s = mt *) - | SgMty of Loc.t and string and module_type + | SgMty of loc and string and module_type (* open i *) - | SgOpn of Loc.t and ident + | SgOpn of loc and ident (* type t *) - | SgTyp of Loc.t and ctyp + | SgTyp of loc and ctyp (* value s : t *) - | SgVal of Loc.t and string and ctyp - | SgAnt of Loc.t and string (* $s$ *) ] + | SgVal of loc and string and ctyp + | SgAnt of loc and string (* $s$ *) ] and with_constr = - [ WcNil of Loc.t + [ WcNil of loc (* type t = t *) - | WcTyp of Loc.t and ctyp and ctyp + | WcTyp of loc and ctyp and ctyp (* module i = i *) - | WcMod of Loc.t and ident and ident + | WcMod of loc and ident and ident (* wc and wc *) - | WcAnd of Loc.t and with_constr and with_constr - | WcAnt of Loc.t and string (* $s$ *) ] + | WcAnd of loc and with_constr and with_constr + | WcAnt of loc and string (* $s$ *) ] and binding = - [ BiNil of Loc.t - (* b and b *) (* let a = 42 and c = 43 *) - | BiAnd of Loc.t and binding and binding + [ BiNil of loc + (* bi and bi *) (* let a = 42 and c = 43 *) + | BiAnd of loc and binding and binding (* p = e *) (* let patt = expr *) - | BiEq of Loc.t and patt and expr - | BiAnt of Loc.t and string (* $s$ *) ] + | BiEq of loc and patt and expr + | BiAnt of loc and string (* $s$ *) ] and rec_binding = - [ RbNil of Loc.t - (* b ; b *) - | RbSem of Loc.t and rec_binding and rec_binding + [ RbNil of loc + (* rb ; rb *) + | RbSem of loc and rec_binding and rec_binding (* i = e *) - | RbEq of Loc.t and ident and expr - | RbAnt of Loc.t and string (* $s$ *) ] + | RbEq of loc and ident and expr + | RbAnt of loc and string (* $s$ *) ] and module_binding = - [ MbNil of Loc.t + [ MbNil of loc (* mb and mb *) (* module rec (s : mt) = me and (s : mt) = me *) - | MbAnd of Loc.t and module_binding and module_binding + | MbAnd of loc and module_binding and module_binding (* s : mt = me *) - | MbColEq of Loc.t and string and module_type and module_expr + | MbColEq of loc and string and module_type and module_expr (* s : mt *) - | MbCol of Loc.t and string and module_type - | MbAnt of Loc.t and string (* $s$ *) ] + | MbCol of loc and string and module_type + | MbAnt of loc and string (* $s$ *) ] and match_case = - [ McNil of Loc.t + [ McNil of loc (* a | a *) - | McOr of Loc.t and match_case and match_case + | McOr of loc and match_case and match_case (* p (when e)? -> e *) - | McArr of Loc.t and patt and expr and expr - | McAnt of Loc.t and string (* $s$ *) ] + | McArr of loc and patt and expr and expr + | McAnt of loc and string (* $s$ *) ] and module_expr = - [ MeNil of Loc.t + [ MeNil of loc (* i *) - | MeId of Loc.t and ident + | MeId of loc and ident (* me me *) - | MeApp of Loc.t and module_expr and module_expr + | MeApp of loc and module_expr and module_expr (* functor (s : mt) -> me *) - | MeFun of Loc.t and string and module_type and module_expr - (* struct (st)? end *) - | MeStr of Loc.t and str_item + | MeFun of loc and string and module_type and module_expr + (* struct st end *) + | MeStr of loc and str_item (* (me : mt) *) - | MeTyc of Loc.t and module_expr and module_type - | MeAnt of Loc.t and string (* $s$ *) ] + | MeTyc of loc and module_expr and module_type + | MeAnt of loc and string (* $s$ *) ] and str_item = - [ StNil of Loc.t + [ StNil of loc (* class cice *) - | StCls of Loc.t and class_expr + | StCls of loc and class_expr (* class type cict *) - | StClt of Loc.t and class_type + | StClt of loc and class_type (* st ; st *) - | StSem of Loc.t and str_item and str_item + | StSem of loc and str_item and str_item (* # s or # s e *) - | StDir of Loc.t and string and expr + | StDir of loc and string and expr (* exception t or exception t = i *) - | StExc of Loc.t and ctyp and meta_option(*FIXME*) ident + | StExc of loc and ctyp and meta_option(*FIXME*) ident (* e *) - | StExp of Loc.t and expr + | StExp of loc and expr (* external s : t = s ... s *) - | StExt of Loc.t and string and ctyp and meta_list string + | StExt of loc and string and ctyp and meta_list string (* include me *) - | StInc of Loc.t and module_expr + | StInc of loc and module_expr (* module s = me *) - | StMod of Loc.t and string and module_expr + | StMod of loc and string and module_expr (* module rec mb *) - | StRecMod of Loc.t and module_binding + | StRecMod of loc and module_binding (* module type s = mt *) - | StMty of Loc.t and string and module_type + | StMty of loc and string and module_type (* open i *) - | StOpn of Loc.t and ident + | StOpn of loc and ident (* type t *) - | StTyp of Loc.t and ctyp - (* value b or value rec b *) - | StVal of Loc.t and meta_bool and binding - | StAnt of Loc.t and string (* $s$ *) ] + | StTyp of loc and ctyp + (* value (rec)? bi *) + | StVal of loc and meta_bool and binding + | StAnt of loc and string (* $s$ *) ] and class_type = - [ CtNil of Loc.t + [ CtNil of loc (* (virtual)? i ([ t ])? *) - | CtCon of Loc.t and meta_bool and ident and ctyp + | CtCon of loc and meta_bool and ident and ctyp (* [t] -> ct *) - | CtFun of Loc.t and ctyp and class_type + | CtFun of loc and ctyp and class_type (* object ((t))? (csg)? end *) - | CtSig of Loc.t and ctyp and class_sig_item + | CtSig of loc and ctyp and class_sig_item (* ct and ct *) - | CtAnd of Loc.t and class_type and class_type + | CtAnd of loc and class_type and class_type (* ct : ct *) - | CtCol of Loc.t and class_type and class_type + | CtCol of loc and class_type and class_type (* ct = ct *) - | CtEq of Loc.t and class_type and class_type + | CtEq of loc and class_type and class_type (* $s$ *) - | CtAnt of Loc.t and string ] + | CtAnt of loc and string ] and class_sig_item = - [ CgNil of Loc.t + [ CgNil of loc (* type t = t *) - | CgCtr of Loc.t and ctyp and ctyp + | CgCtr of loc and ctyp and ctyp (* csg ; csg *) - | CgSem of Loc.t and class_sig_item and class_sig_item + | CgSem of loc and class_sig_item and class_sig_item (* inherit ct *) - | CgInh of Loc.t and class_type + | CgInh of loc and class_type (* method s : t or method private s : t *) - | CgMth of Loc.t and string and meta_bool and ctyp + | CgMth of loc and string and meta_bool and ctyp (* value (virtual)? (mutable)? s : t *) - | CgVal of Loc.t and string and meta_bool and meta_bool and ctyp + | CgVal of loc and string and meta_bool and meta_bool and ctyp (* method virtual (mutable)? s : t *) - | CgVir of Loc.t and string and meta_bool and ctyp - | CgAnt of Loc.t and string (* $s$ *) ] + | CgVir of loc and string and meta_bool and ctyp + | CgAnt of loc and string (* $s$ *) ] and class_expr = - [ CeNil of Loc.t + [ CeNil of loc (* ce e *) - | CeApp of Loc.t and class_expr and expr + | CeApp of loc and class_expr and expr (* (virtual)? i ([ t ])? *) - | CeCon of Loc.t and meta_bool and ident and ctyp + | CeCon of loc and meta_bool and ident and ctyp (* fun p -> ce *) - | CeFun of Loc.t and patt and class_expr - (* let (rec)? b in ce *) - | CeLet of Loc.t and meta_bool and binding and class_expr + | CeFun of loc and patt and class_expr + (* let (rec)? bi in ce *) + | CeLet of loc and meta_bool and binding and class_expr (* object ((p))? (cst)? end *) - | CeStr of Loc.t and patt and class_str_item + | CeStr of loc and patt and class_str_item (* ce : ct *) - | CeTyc of Loc.t and class_expr and class_type + | CeTyc of loc and class_expr and class_type (* ce and ce *) - | CeAnd of Loc.t and class_expr and class_expr + | CeAnd of loc and class_expr and class_expr (* ce = ce *) - | CeEq of Loc.t and class_expr and class_expr + | CeEq of loc and class_expr and class_expr (* $s$ *) - | CeAnt of Loc.t and string ] + | CeAnt of loc and string ] and class_str_item = - [ CrNil of Loc.t + [ CrNil of loc (* cst ; cst *) - | CrSem of Loc.t and class_str_item and class_str_item + | CrSem of loc and class_str_item and class_str_item (* type t = t *) - | CrCtr of Loc.t and ctyp and ctyp + | CrCtr of loc and ctyp and ctyp (* inherit ce or inherit ce as s *) - | CrInh of Loc.t and class_expr and string + | CrInh of loc and class_expr and string (* initializer e *) - | CrIni of Loc.t and expr + | CrIni of loc and expr (* method (private)? s : t = e or method (private)? s = e *) - | CrMth of Loc.t and string and meta_bool and expr and ctyp + | CrMth of loc and string and meta_bool and expr and ctyp (* value (mutable)? s = e *) - | CrVal of Loc.t and string and meta_bool and expr + | CrVal of loc and string and meta_bool and expr (* method virtual (private)? s : t *) - | CrVir of Loc.t and string and meta_bool and ctyp + | CrVir of loc and string and meta_bool and ctyp (* value virtual (private)? s : t *) - | CrVvr of Loc.t and string and meta_bool and ctyp - | CrAnt of Loc.t and string (* $s$ *) ]; + | CrVvr of loc and string and meta_bool and ctyp + | CrAnt of loc and string (* $s$ *) ]; diff --git a/camlp4/Camlp4/OCamlInitSyntax.ml b/camlp4/Camlp4/OCamlInitSyntax.ml index 21862359..e36dc24d 100644 --- a/camlp4/Camlp4/OCamlInitSyntax.ml +++ b/camlp4/Camlp4/OCamlInitSyntax.ml @@ -24,7 +24,6 @@ module Make (Ast : Sig.Camlp4Ast) and module Ast = Ast and module Token = Gram.Token and module Gram = Gram - and module AntiquotSyntax.Ast = Sig.Camlp4AstToAst Ast and module Quotation = Quotation = struct diff --git a/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml b/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml index 629f8e05..b9438a22 100644 --- a/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml +++ b/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml @@ -19,7 +19,7 @@ module Id = struct value name = "Camlp4Printers.DumpCamlp4Ast"; - value version = "$Id: DumpCamlp4Ast.ml,v 1.5.4.1 2007/03/30 15:50:12 pouillar Exp $"; + value version = "$Id: DumpCamlp4Ast.ml,v 1.5.4.2 2007/05/22 09:05:39 pouillar Exp $"; end; module Make (Syntax : Sig.Syntax) @@ -29,7 +29,8 @@ module Make (Syntax : Sig.Syntax) value with_open_out_file x f = match x with - [ Some file -> do { let oc = open_out_bin file in f oc; + [ Some file -> do { let oc = open_out_bin file; + f oc; flush oc; close_out oc } | None -> do { set_binary_mode_out stdout True; f stdout; flush stdout } ]; diff --git a/camlp4/Camlp4/Printers/DumpOCamlAst.ml b/camlp4/Camlp4/Printers/DumpOCamlAst.ml index e32cb77e..02091fd1 100644 --- a/camlp4/Camlp4/Printers/DumpOCamlAst.ml +++ b/camlp4/Camlp4/Printers/DumpOCamlAst.ml @@ -19,7 +19,7 @@ module Id : Sig.Id = struct value name = "Camlp4Printers.DumpOCamlAst"; - value version = "$Id: DumpOCamlAst.ml,v 1.5.4.1 2007/03/30 15:50:12 pouillar Exp $"; + value version = "$Id: DumpOCamlAst.ml,v 1.5.4.2 2007/05/22 09:05:39 pouillar Exp $"; end; module Make (Syntax : Sig.Camlp4Syntax) @@ -30,7 +30,8 @@ module Make (Syntax : Sig.Camlp4Syntax) value with_open_out_file x f = match x with - [ Some file -> do { let oc = open_out_bin file in f oc; + [ Some file -> do { let oc = open_out_bin file; + f oc; flush oc; close_out oc } | None -> do { set_binary_mode_out stdout True; f stdout; flush stdout } ]; diff --git a/camlp4/Camlp4/Printers/OCaml.ml b/camlp4/Camlp4/Printers/OCaml.ml index 6b372129..593cd276 100644 --- a/camlp4/Camlp4/Printers/OCaml.ml +++ b/camlp4/Camlp4/Printers/OCaml.ml @@ -20,12 +20,14 @@ open Format; module Id = struct value name = "Camlp4.Printers.OCaml"; - value version = "$Id: OCaml.ml,v 1.21.2.9 2007/05/12 22:44:55 pouillar Exp $"; + value version = "$Id: OCaml.ml,v 1.21.2.24 2007/11/27 14:35:12 ertai Exp $"; end; module Make (Syntax : Sig.Camlp4Syntax) = struct include Syntax; + type sep = format unit formatter unit; + value pp = fprintf; value cut f = fprintf f "@ "; @@ -65,23 +67,23 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct module StringSet = Set.Make String; + value infix_lidents = ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"]; + value is_infix = let first_chars = ['='; '<'; '>'; '|'; '&'; '$'; '@'; '^'; '+'; '-'; '*'; '/'; '%'; '\\'] and infixes = - List.fold_right StringSet.add - ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"] StringSet.empty + List.fold_right StringSet.add infix_lidents StringSet.empty in fun s -> (StringSet.mem s infixes || (s <> "" && List.mem s.[0] first_chars)); value is_keyword = - let keywords = + let keywords = (* without infix_lidents *) List.fold_right StringSet.add - ["and"; "as"; "assert"; "asr"; "begin"; "class"; "constraint"; "do"; - "done"; "downto"; "else"; "end"; "exception"; "external"; "false"; - "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; - "inherit"; "initializer"; "land"; "lazy"; "let"; "lor"; "lsl"; "lsr"; - "lxor"; "match"; "method"; "mod"; "module"; "mutable"; "new"; - "object"; "of"; "open"; "or"; "parser"; "private"; "rec"; "sig"; + ["and"; "as"; "assert"; "begin"; "class"; "constraint"; "do"; + "done"; "downto"; "else"; "end"; "exception"; "external"; "false"; + "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; + "inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module"; + "mutable"; "new"; "object"; "of"; "open"; "parser"; "private"; "rec"; "sig"; "struct"; "then"; "to"; "true"; "try"; "type"; "val"; "virtual"; "when"; "while"; "with"] StringSet.empty in fun s -> StringSet.mem s keywords; @@ -95,7 +97,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct try match lexer str with parser [: `(tok, _); `(EOI, _) :] -> tok with - [ Stream.Failure -> + [ Stream.Failure | Stream.Error _ -> failwith (sprintf "Cannot print %S this string contains more than one token" str) | Lexer.Error.E exn -> @@ -162,8 +164,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct method reset_semi = {< semi = False >}; method reset = {< pipe = False; semi = False >}; - value semisep = ";;"; - value andsep : format unit formatter unit = "@]@ @[<2>and@ "; + value semisep : sep = ";;"; + value andsep : sep = "@]@ @[<2>and@ "; value value_val = "val"; value value_let = "let"; value mode = if comments then `comments else `no_comments; @@ -203,7 +205,9 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | _ -> match lex_string v with [ (LIDENT s | UIDENT s | ESCAPED_IDENT s) when is_keyword s -> - pp f "%s__" s + pp f "%s__" s + | (LIDENT s | ESCAPED_IDENT s) when List.mem s infix_lidents -> + pp f "( %s )" s | SYMBOL s -> pp f "( %s )" s | LIDENT s | UIDENT s | ESCAPED_IDENT s -> @@ -295,9 +299,6 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct o#under_semi#record_binding f b2 } | <:rec_binding< $anti:s$ >> -> o#anti f s ]; - method object_dup f = - list (fun f (s, e) -> pp f "@[<2>%a =@ %a@]" o#var s o#expr e) ";@ " f; - method mk_patt_list = fun [ <:patt< [$p1$ :: $p2$] >> -> @@ -317,8 +318,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct method expr_list f = fun [ [] -> pp f "[]" - | [e] -> pp f "[ %a ]" o#expr e - | el -> pp f "@[<2>[ %a@] ]" (list o#expr ";@ ") el ]; + | [e] -> pp f "[ %a ]" o#under_semi#expr e + | el -> pp f "@[<2>[ %a@] ]" (list o#under_semi#expr ";@ ") el ]; method expr_list_cons simple f e = let (el, c) = o#mk_expr_list e in @@ -326,7 +327,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct [ None -> o#expr_list f el | Some x -> (if simple then pp f "@[<2>(%a)@]" else pp f "@[<2>%a@]") - (list o#dot_expr " ::@ ") (el @ [x]) ]; + (list o#under_semi#dot_expr " ::@ ") (el @ [x]) ]; method patt_expr_fun_args f (p, e) = let (pl, e) = expr_fun_args e @@ -339,15 +340,17 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct method constrain f (t1, t2) = pp f "@[<2>constraint@ %a =@ %a@]" o#ctyp t1 o#ctyp t2; - method sum_type f t = do { - (* FIXME pp_print_if_newline f (); *) - pp_print_string f "| "; - o#ctyp f t; - }; + method sum_type f t = + match Ast.list_of_ctyp t [] with + [ [] -> () + | ts -> + pp f "@[| %a@]" (list o#ctyp "@ | ") ts ]; + method string f = pp f "%s"; method quoted_string f = pp f "%S"; - method intlike f s = if s.[0] = '-' then pp f "(%s)" s else pp f "%s" s; + method numeric f num suff = + if num.[0] = '-' then pp f "(%s%s)" num suff else pp f "%s%s" num suff; method module_expr_get_functor_args accu = fun @@ -413,9 +416,10 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct pp f "(%a)" o#reset#expr e | <:expr< - $x$ >> -> - pp f "@[<2>-@,%a@]" o#expr x + (* If you want to remove the space take care of - !r *) + pp f "@[<2>-@ %a@]" o#dot_expr x | <:expr< -. $x$ >> -> - pp f "@[<2>-.@,%a@]" o#expr x + pp f "@[<2>-.@ %a@]" o#dot_expr x (* same note as above *) | <:expr< [$_$ :: $_$] >> -> o#expr_list_cons False f e | <:expr@_loc< $lid:n$ $x$ $y$ >> when is_infix n -> pp f "@[<2>%a@ %s@ %a@]" o#apply_expr x n o#apply_expr y @@ -431,9 +435,9 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct (list o#under_pipe#expr ",@ ") al ] else pp f "@[<2>%a@]" (list o#apply_expr "@ ") [a::al] | <:expr< $e1$.val := $e2$ >> -> - pp f "@[<2>%a :=@ %a@]" o#expr e1 o#expr e2 + pp f "@[<2>%a :=@ %a@]" o#dot_expr e1 o#expr e2 | <:expr< $e1$ := $e2$ >> -> - pp f "@[<2>%a@ <-@ %a@]" o#expr e1 o#expr e2 + pp f "@[<2>%a@ <-@ %a@]" o#dot_expr e1 o#expr e2 | <:expr@loc< fun [] >> -> pp f "@[<2>fun@ _@ ->@ %a@]" o#raise_match_failure loc | <:expr< fun $p$ -> $e$ >> when is_irrefut_patt p -> @@ -461,7 +465,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:expr< assert False >> -> pp f "@[<2>assert@ false@]" | <:expr< assert $e$ >> -> pp f "@[<2>assert@ %a@]" o#dot_expr e | <:expr< let module $s$ = $me$ in $e$ >> -> - pp f "@[<2>let module %a =@ %a@]@ @[<2>in@ %a@]" o#var s o#module_expr me o#expr e + pp f "@[<2>let module %a =@ %a@]@ @[<2>in@ %a@]" o#var s o#module_expr me o#reset_semi#expr e | e -> o#apply_expr f e ]; method apply_expr f e = @@ -503,11 +507,11 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:expr< for $s$ = $e1$ $to:df$ $e2$ do { $e3$ } >> -> pp f "@[@[@[<2>for %a =@ %a@ %a@ %a@ do@]@ %a@]@ done@]" o#var s o#expr e1 o#direction_flag df o#expr e2 o#seq e3 - | <:expr< $int:s$ >> -> pp f "%a" o#intlike s - | <:expr< $nativeint:s$ >> -> pp f "%an" o#intlike s - | <:expr< $int64:s$ >> -> pp f "%aL" o#intlike s - | <:expr< $int32:s$ >> -> pp f "%al" o#intlike s - | <:expr< $flo:s$ >> -> pp f "%s" s + | <:expr< $int:s$ >> -> o#numeric f s "" + | <:expr< $nativeint:s$ >> -> o#numeric f s "n" + | <:expr< $int64:s$ >> -> o#numeric f s "L" + | <:expr< $int32:s$ >> -> o#numeric f s "l" + | <:expr< $flo:s$ >> -> o#numeric f s "" | <:expr< $chr:s$ >> -> pp f "'%s'" (ocaml_char s) | <:expr< $id:i$ >> -> o#var_ident f i | <:expr< { $b$ } >> -> @@ -587,15 +591,17 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct [ <:patt< [$_$ :: $_$] >> as p -> o#simple_patt f p | <:patt< $x$ $y$ >> -> let (a, al) = get_patt_args x [y] in - if (not curry_constr) && Ast.is_patt_constructor a then + if not (Ast.is_patt_constructor a) then + Format.eprintf "WARNING: strange pattern application of a non constructor@." + else if curry_constr then + pp f "@[<2>%a@]" (list o#simple_patt "@ ") [a::al] + else match al with [ [ <:patt< ($tup:_$) >> ] -> pp f "@[<2>%a@ (%a)@]" o#simple_patt x o#patt y | [_] -> pp f "@[<2>%a@ %a@]" o#patt5 x o#simple_patt y | al -> pp f "@[<2>%a@ (%a)@]" o#patt5 a (list o#simple_patt ",@ ") al ] - else - pp f "@[<2>%a@]" (list o#simple_patt "@ ") [a::al] | p -> o#simple_patt f p ]; method simple_patt f p = @@ -609,11 +615,11 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:patt< { $p$ } >> -> pp f "@[{@ %a@]@ }" o#patt p | <:patt< $str:s$ >> -> pp f "\"%s\"" s | <:patt< ( $p$ : $t$ ) >> -> pp f "@[<1>(%a :@ %a)@]" o#patt p o#ctyp t - | <:patt< $nativeint:s$ >> -> pp f "%an" o#intlike s - | <:patt< $int64:s$ >> -> pp f "%aL" o#intlike s - | <:patt< $int32:s$ >> -> pp f "%al" o#intlike s - | <:patt< $int:s$ >> -> pp f "%a" o#intlike s - | <:patt< $flo:s$ >> -> pp f "%s" s + | <:patt< $nativeint:s$ >> -> o#numeric f s "n" + | <:patt< $int64:s$ >> -> o#numeric f s "L" + | <:patt< $int32:s$ >> -> o#numeric f s "l" + | <:patt< $int:s$ >> -> o#numeric f s "" + | <:patt< $flo:s$ >> -> o#numeric f s "" | <:patt< $chr:s$ >> -> pp f "'%s'" (ocaml_char s) | <:patt< ~ $s$ >> -> pp f "~%s" s | <:patt< ` $uid:s$ >> -> pp f "`%a" o#var s @@ -622,18 +628,23 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:patt< ~ $s$ : ($p$) >> -> pp f "@[<2>~%s:@ (%a)@]" s o#patt p | <:patt< ? $s$ >> -> pp f "?%s" s | <:patt< ?($p$) >> -> - pp f "@[<2>?(%a)@]" o#patt p + pp f "@[<2>?(%a)@]" o#patt_tycon p | <:patt< ? $s$ : ($p$) >> -> - pp f "@[<2>?%s:@,@[<1>(%a)@]@]" s o#patt p + pp f "@[<2>?%s:@,@[<1>(%a)@]@]" s o#patt_tycon p | <:patt< ?($p$ = $e$) >> -> - pp f "@[<2>?(%a =@ %a)@]" o#patt p o#expr e + pp f "@[<2>?(%a =@ %a)@]" o#patt_tycon p o#expr e | <:patt< ? $s$ : ($p$ = $e$) >> -> - pp f "@[<2>?%s:@,@[<1>(%a =@ %a)@]@]" s o#patt p o#expr e + pp f "@[<2>?%s:@,@[<1>(%a =@ %a)@]@]" s o#patt_tycon p o#expr e | <:patt< $_$ $_$ >> | <:patt< ($_$ as $_$) >> | <:patt< $_$ | $_$ >> | <:patt< $_$ .. $_$ >> | <:patt< $_$, $_$ >> | <:patt< $_$; $_$ >> | <:patt< $_$ = $_$ >> as p -> pp f "@[<1>(%a)@]" o#patt p ]; + method patt_tycon f = + fun + [ <:patt< ( $p$ : $t$ ) >> -> pp f "%a :@ %a" o#patt p o#ctyp t + | p -> o#patt f p ]; + method simple_ctyp f t = let () = o#node f t Ast.loc_of_ctyp in match t with @@ -650,16 +661,19 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:ctyp< { $t$ } >> -> pp f "@[<2>{@ %a@]@ }" o#ctyp t | <:ctyp< [ $t$ ] >> -> pp f "@[<0>%a@]" o#sum_type t | <:ctyp< ( $tup:t$ ) >> -> pp f "@[<1>(%a)@]" o#ctyp t - | <:ctyp< [ = $t$ ] >> -> pp f "@[<2>[@ %a@]@ ]" o#ctyp t - | <:ctyp< [ < $t$ ] >> -> pp f "@[<2>[<@ %a@]@,]" o#ctyp t + | <:ctyp< [ = $t$ ] >> -> pp f "@[<2>[@ %a@]@ ]" o#sum_type t + | <:ctyp< [ < $t$ ] >> -> pp f "@[<2>[<@ %a@]@,]" o#sum_type t | <:ctyp< [ < $t1$ > $t2$ ] >> -> - pp f "@[<2>[<@ %a@ >@ %a@]@ ]" o#ctyp t1 o#ctyp t2 - | <:ctyp< [ > $t$ ] >> -> pp f "@[<2>[>@ %a@]@,]" o#ctyp t + let (a, al) = get_ctyp_args t2 [] in + pp f "@[<2>[<@ %a@ >@ %a@]@ ]" o#sum_type t1 + (list o#simple_ctyp "@ ") [a::al] + | <:ctyp< [ > $t$ ] >> -> pp f "@[<2>[>@ %a@]@,]" o#sum_type t | <:ctyp< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i | <:ctyp< $t1$ == $t2$ >> -> pp f "@[<2>%a =@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2 | <:ctyp< `$s$ >> -> pp f "`%a" o#var s | <:ctyp< $t1$ * $t2$ >> -> pp f "%a *@ %a" o#simple_ctyp t1 o#simple_ctyp t2 + | <:ctyp<>> -> assert False | t -> pp f "@[<1>(%a)@]" o#ctyp t ]; method ctyp f t = @@ -721,9 +735,9 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:sig_item< $sg1$; $sg2$ >> -> do { o#sig_item f sg1; cut f; o#sig_item f sg2 } | <:sig_item< exception $t$ >> -> - pp f "@[<2>exception@ %a%s@]" o#ctyp t semisep + pp f "@[<2>exception@ %a%(%)@]" o#ctyp t semisep | <:sig_item< external $s$ : $t$ = $sl$ >> -> - pp f "@[<2>external@ %a :@ %a =@ %a%s@]" + pp f "@[<2>external@ %a :@ %a =@ %a%(%)@]" o#var s o#ctyp t (meta_list o#quoted_string "@ ") sl semisep | <:sig_item< module $s1$ ($s2$ : $mt1$) : $mt2$ >> -> let rec loop accu = @@ -732,35 +746,35 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct loop [(s, mt1)::accu] mt2 | mt -> (List.rev accu, mt) ] in let (al, mt) = loop [(s2, mt1)] mt2 in - pp f "@[<2>module %a@ @[<0>%a@] :@ %a%s@]" + pp f "@[<2>module %a@ @[<0>%a@] :@ %a%(%)@]" o#var s1 o#functor_args al o#module_type mt semisep | <:sig_item< module $s$ : $mt$ >> -> - pp f "@[<2>module %a :@ %a%s@]" + pp f "@[<2>module %a :@ %a%(%)@]" o#var s o#module_type mt semisep | <:sig_item< module type $s$ = $ <:module_type<>> $ >> -> - pp f "@[<2>module type %a%s@]" o#var s semisep + pp f "@[<2>module type %a%(%)@]" o#var s semisep | <:sig_item< module type $s$ = $mt$ >> -> - pp f "@[<2>module type %a =@ %a%s@]" + pp f "@[<2>module type %a =@ %a%(%)@]" o#var s o#module_type mt semisep | <:sig_item< open $sl$ >> -> - pp f "@[<2>open@ %a%s@]" o#ident sl semisep + pp f "@[<2>open@ %a%(%)@]" o#ident sl semisep | <:sig_item< type $t$ >> -> - pp f "@[@[type %a@]%s@]" o#ctyp t semisep + pp f "@[@[type %a@]%(%)@]" o#ctyp t semisep | <:sig_item< value $s$ : $t$ >> -> - pp f "@[<2>%s %a :@ %a%s@]" + pp f "@[<2>%s %a :@ %a%(%)@]" value_val o#var s o#ctyp t semisep | <:sig_item< include $mt$ >> -> - pp f "@[<2>include@ %a%s@]" o#module_type mt semisep + pp f "@[<2>include@ %a%(%)@]" o#module_type mt semisep | <:sig_item< class type $ct$ >> -> - pp f "@[<2>class type %a%s@]" o#class_type ct semisep + pp f "@[<2>class type %a%(%)@]" o#class_type ct semisep | <:sig_item< class $ce$ >> -> - pp f "@[<2>class %a%s@]" o#class_type ce semisep + pp f "@[<2>class %a%(%)@]" o#class_type ce semisep | <:sig_item< module rec $mb$ >> -> - pp f "@[<2>module rec %a%s@]" + pp f "@[<2>module rec %a%(%)@]" o#module_rec_binding mb semisep | <:sig_item< # $_$ $_$ >> -> () | <:sig_item< $anti:s$ >> -> - pp f "%a%s" o#anti s semisep ]; + pp f "%a%(%)" o#anti s semisep ]; method str_item f st = let () = o#node f st Ast.loc_of_str_item in @@ -772,47 +786,47 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:str_item< $st1$; $st2$ >> -> do { o#str_item f st1; cut f; o#str_item f st2 } | <:str_item< exception $t$ >> -> - pp f "@[<2>exception@ %a%s@]" o#ctyp t semisep + pp f "@[<2>exception@ %a%(%)@]" o#ctyp t semisep | <:str_item< exception $t$ = $sl$ >> -> - pp f "@[<2>exception@ %a =@ %a%s@]" o#ctyp t o#ident sl semisep + pp f "@[<2>exception@ %a =@ %a%(%)@]" o#ctyp t o#ident sl semisep | <:str_item< external $s$ : $t$ = $sl$ >> -> - pp f "@[<2>external@ %a :@ %a =@ %a%s@]" + pp f "@[<2>external@ %a :@ %a =@ %a%(%)@]" o#var s o#ctyp t (meta_list o#quoted_string "@ ") sl semisep | <:str_item< module $s1$ ($s2$ : $mt1$) = $me$ >> -> match o#module_expr_get_functor_args [(s2, mt1)] me with [ (al, me, Some mt2) -> - pp f "@[<2>module %a@ @[<0>%a@] :@ %a =@ %a%s@]" + pp f "@[<2>module %a@ @[<0>%a@] :@ %a =@ %a%(%)@]" o#var s1 o#functor_args al o#module_type mt2 o#module_expr me semisep | (al, me, _) -> - pp f "@[<2>module %a@ @[<0>%a@] =@ %a%s@]" + pp f "@[<2>module %a@ @[<0>%a@] =@ %a%(%)@]" o#var s1 o#functor_args al o#module_expr me semisep ] | <:str_item< module $s$ : $mt$ = $me$ >> -> - pp f "@[<2>module %a :@ %a =@ %a%s@]" + pp f "@[<2>module %a :@ %a =@ %a%(%)@]" o#var s o#module_type mt o#module_expr me semisep | <:str_item< module $s$ = $me$ >> -> - pp f "@[<2>module %a =@ %a%s@]" o#var s o#module_expr me semisep + pp f "@[<2>module %a =@ %a%(%)@]" o#var s o#module_expr me semisep | <:str_item< module type $s$ = $mt$ >> -> - pp f "@[<2>module type %a =@ %a%s@]" + pp f "@[<2>module type %a =@ %a%(%)@]" o#var s o#module_type mt semisep | <:str_item< open $sl$ >> -> - pp f "@[<2>open@ %a%s@]" o#ident sl semisep + pp f "@[<2>open@ %a%(%)@]" o#ident sl semisep | <:str_item< type $t$ >> -> - pp f "@[@[type %a@]%s@]" o#ctyp t semisep + pp f "@[@[type %a@]%(%)@]" o#ctyp t semisep | <:str_item< value $rec:r$ $bi$ >> -> - pp f "@[<2>%s %a%a%s@]" value_let o#rec_flag r o#binding bi semisep + pp f "@[<2>%s %a%a%(%)@]" value_let o#rec_flag r o#binding bi semisep | <:str_item< $exp:e$ >> -> - pp f "@[<2>let _ =@ %a%s@]" o#expr e semisep + pp f "@[<2>let _ =@ %a%(%)@]" o#expr e semisep | <:str_item< include $me$ >> -> - pp f "@[<2>include@ %a%s@]" o#module_expr me semisep + pp f "@[<2>include@ %a%(%)@]" o#module_expr me semisep | <:str_item< class type $ct$ >> -> - pp f "@[<2>class type %a%s@]" o#class_type ct semisep + pp f "@[<2>class type %a%(%)@]" o#class_type ct semisep | <:str_item< class $ce$ >> -> - pp f "@[class %a%s@]" o#class_declaration ce semisep + pp f "@[class %a%(%)@]" o#class_declaration ce semisep | <:str_item< module rec $mb$ >> -> - pp f "@[<2>module rec %a%s@]" o#module_rec_binding mb semisep + pp f "@[<2>module rec %a%(%)@]" o#module_rec_binding mb semisep | <:str_item< # $_$ $_$ >> -> () - | <:str_item< $anti:s$ >> -> pp f "%a%s" o#anti s semisep + | <:str_item< $anti:s$ >> -> pp f "%a%(%)" o#anti s semisep | Ast.StExc _ _ (Ast.OAnt _) -> assert False ]; method module_type f mt = @@ -931,22 +945,22 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct o#class_sig_item f csg | <:class_sig_item< $csg1$; $csg2$ >> -> do { o#class_sig_item f csg1; cut f; o#class_sig_item f csg2 } - | <:class_sig_item< type $t1$ = $t2$ >> -> - pp f "@[<2>type@ %a =@ %a%s@]" o#ctyp t1 o#ctyp t2 semisep + | <:class_sig_item< constraint $t1$ = $t2$ >> -> + pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 semisep | <:class_sig_item< inherit $ct$ >> -> - pp f "@[<2>inherit@ %a%s@]" o#class_type ct semisep + pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct semisep | <:class_sig_item< method $private:pr$ $s$ : $t$ >> -> - pp f "@[<2>method %a%a :@ %a%s@]" o#private_flag pr o#var s + pp f "@[<2>method %a%a :@ %a%(%)@]" o#private_flag pr o#var s o#ctyp t semisep | <:class_sig_item< method virtual $private:pr$ $s$ : $t$ >> -> - pp f "@[<2>method virtual %a%a :@ %a%s@]" + pp f "@[<2>method virtual %a%a :@ %a%(%)@]" o#private_flag pr o#var s o#ctyp t semisep | <:class_sig_item< value $mutable:mu$ $virtual:vi$ $s$ : $t$ >> -> - pp f "@[<2>%s %a%a%a :@ %a%s@]" + pp f "@[<2>%s %a%a%a :@ %a%(%)@]" value_val o#mutable_flag mu o#virtual_flag vi o#var s o#ctyp t semisep | <:class_sig_item< $anti:s$ >> -> - pp f "%a%s" o#anti s semisep ]; + pp f "%a%(%)" o#anti s semisep ]; method class_str_item f cst = let () = o#node f cst Ast.loc_of_class_str_item in @@ -957,35 +971,35 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct o#class_str_item f cst | <:class_str_item< $cst1$; $cst2$ >> -> do { o#class_str_item f cst1; cut f; o#class_str_item f cst2 } - | <:class_str_item< type $t1$ = $t2$ >> -> - pp f "@[<2>type %a =@ %a%s@]" o#ctyp t1 o#ctyp t2 semisep + | <:class_str_item< constraint $t1$ = $t2$ >> -> + pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 semisep | <:class_str_item< inherit $ce$ >> -> - pp f "@[<2>inherit@ %a%s@]" o#class_expr ce semisep + pp f "@[<2>inherit@ %a%(%)@]" o#class_expr ce semisep | <:class_str_item< inherit $ce$ as $lid:s$ >> -> - pp f "@[<2>inherit@ %a as@ %a%s@]" o#class_expr ce o#var s semisep + pp f "@[<2>inherit@ %a as@ %a%(%)@]" o#class_expr ce o#var s semisep | <:class_str_item< initializer $e$ >> -> - pp f "@[<2>initializer@ %a%s@]" o#expr e semisep + pp f "@[<2>initializer@ %a%(%)@]" o#expr e semisep | <:class_str_item< method $private:pr$ $s$ = $e$ >> -> - pp f "@[<2>method %a%a =@ %a%s@]" + pp f "@[<2>method %a%a =@ %a%(%)@]" o#private_flag pr o#var s o#expr e semisep | <:class_str_item< method $private:pr$ $s$ : $t$ = $e$ >> -> - pp f "@[<2>method %a%a :@ %a =@ %a%s@]" + pp f "@[<2>method %a%a :@ %a =@ %a%(%)@]" o#private_flag pr o#var s o#ctyp t o#expr e semisep | <:class_str_item< method virtual $private:pr$ $s$ : $t$ >> -> - pp f "@[<2>method virtual@ %a%a :@ %a%s@]" + pp f "@[<2>method virtual@ %a%a :@ %a%(%)@]" o#private_flag pr o#var s o#ctyp t semisep | <:class_str_item< value virtual $mutable:mu$ $s$ : $t$ >> -> - pp f "@[<2>%s virtual %a%a :@ %a%s@]" + pp f "@[<2>%s virtual %a%a :@ %a%(%)@]" value_val o#mutable_flag mu o#var s o#ctyp t semisep | <:class_str_item< value $mutable:mu$ $s$ = $e$ >> -> - pp f "@[<2>%s %a%a =@ %a%s@]" + pp f "@[<2>%s %a%a =@ %a%(%)@]" value_val o#mutable_flag mu o#var s o#expr e semisep | <:class_str_item< $anti:s$ >> -> - pp f "%a%s" o#anti s semisep ]; + pp f "%a%(%)" o#anti s semisep ]; method implem f st = match st with - [ <:str_item< $exp:e$ >> -> pp f "@[<0>%a%s@]@." o#expr e semisep + [ <:str_item< $exp:e$ >> -> pp f "@[<0>%a%(%)@]@." o#expr e semisep | st -> pp f "@[%a@]@." o#str_item st ]; method interf f sg = pp f "@[%a@]@." o#sig_item sg; @@ -1021,7 +1035,7 @@ module MakeMore (Syntax : Sig.Camlp4Syntax) include Make Syntax; - value semisep = ref False; + value semisep : ref sep = ref ("@\n" : sep); value margin = ref 78; value comments = ref True; value locations = ref False; @@ -1030,7 +1044,7 @@ module MakeMore (Syntax : Sig.Camlp4Syntax) value print output_file fct = let o = new printer ~comments:comments.val ~curry_constr:curry_constr.val () in - let o = if semisep.val then o#set_semisep ";;" else o#set_semisep "" in + let o = o#set_semisep semisep.val in let o = if locations.val then o#set_loc_and_comments else o in with_outfile output_file (fun f -> @@ -1043,15 +1057,23 @@ module MakeMore (Syntax : Sig.Camlp4Syntax) value print_implem ?input_file:(_) ?output_file st = print output_file (fun o -> o#implem) st; + value check_sep s = + if String.contains s '%' then failwith "-sep Format error, % found in string" + else (Obj.magic (Struct.Token.Eval.string s : string) : sep); + Options.add "-l" (Arg.Int (fun i -> margin.val := i)) " line length for pretty printing."; - Options.add "-ss" (Arg.Set semisep) "Print double semicolons."; + Options.add "-ss" (Arg.Unit (fun () -> semisep.val := ";;")) + " Print double semicolons."; - Options.add "-curry-constr" (Arg.Set curry_constr) "Use currified constructors."; + Options.add "-no_ss" (Arg.Unit (fun () -> semisep.val := "")) + " Do not print double semicolons (default)."; - Options.add "-no_ss" (Arg.Clear semisep) - "Do not print double semicolons (default)."; + Options.add "-sep" (Arg.String (fun s -> semisep.val := check_sep s)) + " Use this string between phrases."; + + Options.add "-curry-constr" (Arg.Set curry_constr) "Use currified constructors."; Options.add "-no_comments" (Arg.Clear comments) "Do not add comments."; diff --git a/camlp4/Camlp4/Printers/OCaml.mli b/camlp4/Camlp4/Printers/OCaml.mli index a856529d..e24eca78 100644 --- a/camlp4/Camlp4/Printers/OCaml.mli +++ b/camlp4/Camlp4/Printers/OCaml.mli @@ -26,6 +26,8 @@ module Make (Syntax : Sig.Camlp4Syntax) : sig and module Ast = Syntax.Ast and module Gram = Syntax.Gram; + type sep = format unit formatter unit; + value list' : (formatter -> 'a -> unit) -> format 'b formatter unit -> @@ -64,7 +66,7 @@ module Make (Syntax : Sig.Camlp4Syntax) : sig value pipe : bool; value semi : bool; - value semisep : string; + value semisep : sep; value value_val : string; value value_let : string; method anti : formatter -> string -> unit; @@ -92,7 +94,7 @@ module Make (Syntax : Sig.Camlp4Syntax) : sig formatter -> list (string * Ast.module_type) -> unit; method ident : formatter -> Ast.ident -> unit; - method intlike : formatter -> string -> unit; + method numeric : formatter -> string -> string -> unit; method binding : formatter -> Ast.binding -> unit; method record_binding : formatter -> Ast.rec_binding -> unit; method match_case : formatter -> Ast.match_case -> unit; @@ -113,14 +115,13 @@ module Make (Syntax : Sig.Camlp4Syntax) : sig method rec_flag : formatter -> Ast.meta_bool -> unit; method flag : formatter -> Ast.meta_bool -> string -> unit; method node : formatter -> 'b -> ('b -> Loc.t) -> unit; - method object_dup : - formatter -> list (string * Ast.expr) -> unit; method patt : formatter -> Ast.patt -> unit; method patt1 : formatter -> Ast.patt -> unit; method patt2 : formatter -> Ast.patt -> unit; method patt3 : formatter -> Ast.patt -> unit; method patt4 : formatter -> Ast.patt -> unit; method patt5 : formatter -> Ast.patt -> unit; + method patt_tycon : formatter -> Ast.patt -> unit; method patt_expr_fun_args : formatter -> (Ast.patt * Ast.expr) -> unit; method patt_class_expr_fun_args : @@ -132,11 +133,11 @@ module Make (Syntax : Sig.Camlp4Syntax) : sig method raise_match_failure : formatter -> Loc.t -> unit; method reset : 'a; method reset_semi : 'a; - method semisep : string; + method semisep : sep; method set_comments : bool -> 'a; method set_curry_constr : bool -> 'a; method set_loc_and_comments : 'a; - method set_semisep : string -> 'a; + method set_semisep : sep -> 'a; method simple_ctyp : formatter -> Ast.ctyp -> unit; method simple_expr : formatter -> Ast.expr -> unit; method simple_patt : formatter -> Ast.patt -> unit; diff --git a/camlp4/Camlp4/Printers/OCamlr.ml b/camlp4/Camlp4/Printers/OCamlr.ml index cd2638e5..b0887a01 100644 --- a/camlp4/Camlp4/Printers/OCamlr.ml +++ b/camlp4/Camlp4/Printers/OCamlr.ml @@ -20,7 +20,7 @@ open Format; module Id = struct value name = "Camlp4.Printers.OCamlr"; - value version = "$Id: OCamlr.ml,v 1.17.4.4 2007/05/10 22:43:18 pouillar Exp $"; + value version = "$Id: OCamlr.ml,v 1.17.4.6 2007/11/27 14:35:13 ertai Exp $"; end; module Make (Syntax : Sig.Camlp4Syntax) = struct @@ -43,8 +43,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct object (o) inherit PP_o.printer ~curry_constr:init_curry_constr ~comments () as super; - value semisep = ";"; - value andsep : format unit formatter unit = "@]@ @[<2>and@ "; + value semisep : sep = ";"; + value andsep : sep = "@]@ @[<2>and@ "; value value_val = "value"; value value_let = "value"; value mode = if comments then `comments else `no_comments; @@ -157,7 +157,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct let () = o#node f e Ast.loc_of_expr in match e with [ <:expr< $e1$ := $e2$ >> -> - pp f "@[<2>%a@ :=@ %a@]" o#expr e1 o#expr e2 + pp f "@[<2>%a@ :=@ %a@]" o#dot_expr e1 o#expr e2 | <:expr< fun $p$ -> $e$ >> when Ast.is_irrefut_patt p -> pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (p, e) | <:expr< fun [ $a$ ] >> -> @@ -217,7 +217,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct method str_item f st = match st with - [ <:str_item< $exp:e$ >> -> pp f "@[<2>%a%s@]" o#expr e semisep + [ <:str_item< $exp:e$ >> -> pp f "@[<2>%a%(%)@]" o#expr e semisep | st -> super#str_item f st ]; method module_expr f me = diff --git a/camlp4/Camlp4/Sig.ml b/camlp4/Camlp4/Sig.ml index 989ca93b..3e8274fa 100644 --- a/camlp4/Camlp4/Sig.ml +++ b/camlp4/Camlp4/Sig.ml @@ -18,6 +18,11 @@ * - Nicolas Pouillard: refactoring *) +(** Camlp4 signature repository *) + +(** {6 Basic signatures} *) + +(** Signature with just a type. *) module type Type = sig type t; end; @@ -37,11 +42,24 @@ module type Id = sig (** The name of the extension, typically the module name. *) value name : string; - (** The version of the extension, typically $Id: Sig.ml,v 1.2.2.10 2007/05/10 22:43:18 pouillar Exp $ with a versionning system. *) + (** The version of the extension, typically $Id: Sig.ml,v 1.2.2.13 2007/06/23 16:00:09 ertai Exp $ with a versionning system. *) value version : string; end; +(** A signature for warnings abstract from locations. *) +module Warning (Loc : Type) = struct + module type S = sig + type warning = Loc.t -> string -> unit; + value default_warning : warning; + value current_warning : ref warning; + value print_warning : warning; + end; +end; + +(** {6 Advanced signatures} *) + +(** A signature for locations. *) module type Loc = sig type t; @@ -60,10 +78,10 @@ module type Loc = sig value of_lexing_position : Lexing.position -> t; (** Return an OCaml location. *) - value to_ocaml_location : t -> Location.t; + value to_ocaml_location : t -> Camlp4_import.Location.t; (** Return a location from an OCaml location. *) - value of_ocaml_location : Location.t -> t; + value of_ocaml_location : Camlp4_import.Location.t -> t; (** Return a location from ocamllex buffer. *) value of_lexbuf : Lexing.lexbuf -> t; @@ -97,7 +115,7 @@ module type Loc = sig The "begin of line" of both positions become the current offset. *) value move_line : int -> t -> t; - (** Accessors *) + (** {6 Accessors} *) (** Return the file name *) value file_name : t -> string; @@ -174,47 +192,14 @@ module type Loc = sig end; -module Warning (Loc : Loc) = struct - module type S = sig - type warning = Loc.t -> string -> unit; - value default_warning : warning; - value current_warning : ref warning; - value print_warning : warning; - end; -end; - -(** Base class for map traversal, it includes some builtin types. *) -class mapper : object - method string : string -> string; - method int : int -> int; - method float : float -> float; - method bool : bool -> bool; - method list : ! 'a 'b . ('a -> 'b) -> list 'a -> list 'b; - method option : ! 'a 'b . ('a -> 'b) -> option 'a -> option 'b; - method array : ! 'a 'b . ('a -> 'b) -> array 'a -> array 'b; - method ref : ! 'a 'b . ('a -> 'b) -> ref 'a -> ref 'b; -end = object - method string x : string = x; - method int x : int = x; - method float x : float = x; - method bool x : bool = x; - method list : ! 'a 'b . ('a -> 'b) -> list 'a -> list 'b = - List.map; - method option : ! 'a 'b . ('a -> 'b) -> option 'a -> option 'b = - fun f -> fun [ None -> None | Some x -> Some (f x) ]; - method array : ! 'a 'b . ('a -> 'b) -> array 'a -> array 'b = - Array.map; - method ref : ! 'a 'b . ('a -> 'b) -> ref 'a -> ref 'b = - fun f { val = x } -> { val = f x }; -end; - (** Abstract syntax tree minimal signature. Types of this signature are abstract. See the {!Camlp4Ast} signature for a concrete definition. *) module type Ast = sig - module Loc : Loc; + (** {6 Syntactic categories as abstract types} *) + type loc; type meta_bool; type meta_option 'a; type meta_list 'a; @@ -236,23 +221,27 @@ module type Ast = sig type rec_binding; type module_binding; - value loc_of_ctyp : ctyp -> Loc.t; - value loc_of_patt : patt -> Loc.t; - value loc_of_expr : expr -> Loc.t; - value loc_of_module_type : module_type -> Loc.t; - value loc_of_module_expr : module_expr -> Loc.t; - value loc_of_sig_item : sig_item -> Loc.t; - value loc_of_str_item : str_item -> Loc.t; - value loc_of_class_type : class_type -> Loc.t; - value loc_of_class_sig_item : class_sig_item -> Loc.t; - value loc_of_class_expr : class_expr -> Loc.t; - value loc_of_class_str_item : class_str_item -> Loc.t; - value loc_of_with_constr : with_constr -> Loc.t; - value loc_of_binding : binding -> Loc.t; - value loc_of_rec_binding : rec_binding -> Loc.t; - value loc_of_module_binding : module_binding -> Loc.t; - value loc_of_match_case : match_case -> Loc.t; - value loc_of_ident : ident -> Loc.t; + (** {6 Location accessors} *) + + value loc_of_ctyp : ctyp -> loc; + value loc_of_patt : patt -> loc; + value loc_of_expr : expr -> loc; + value loc_of_module_type : module_type -> loc; + value loc_of_module_expr : module_expr -> loc; + value loc_of_sig_item : sig_item -> loc; + value loc_of_str_item : str_item -> loc; + value loc_of_class_type : class_type -> loc; + value loc_of_class_sig_item : class_sig_item -> loc; + value loc_of_class_expr : class_expr -> loc; + value loc_of_class_str_item : class_str_item -> loc; + value loc_of_with_constr : with_constr -> loc; + value loc_of_binding : binding -> loc; + value loc_of_rec_binding : rec_binding -> loc; + value loc_of_module_binding : module_binding -> loc; + value loc_of_match_case : match_case -> loc; + value loc_of_ident : ident -> loc; + + (** {6 Traversals} *) (** This class is the base class for map traversal on the Ast. To make a custom traversal class one just extend it like that: @@ -270,12 +259,13 @@ module type Ast = sig value map = (new swap)#expr; assert (map <:expr< fun x -> (x, 42) >> = <:expr< fun x -> (42, x) >>);] *) - class map : object - inherit mapper; + class map : object ('self_type) + method string : string -> string; + method list : ! 'a 'b . ('self_type -> 'a -> 'b) -> list 'a -> list 'b; method meta_bool : meta_bool -> meta_bool; - method meta_option : ! 'a 'b . ('a -> 'b) -> meta_option 'a -> meta_option 'b; - method meta_list : ! 'a 'b . ('a -> 'b) -> meta_list 'a -> meta_list 'b; - method _Loc_t : Loc.t -> Loc.t; + method meta_option : ! 'a 'b . ('self_type -> 'a -> 'b) -> meta_option 'a -> meta_option 'b; + method meta_list : ! 'a 'b . ('self_type -> 'a -> 'b) -> meta_list 'a -> meta_list 'b; + method loc : loc -> loc; method expr : expr -> expr; method patt : patt -> patt; method ctyp : ctyp -> ctyp; @@ -294,21 +284,18 @@ module type Ast = sig method module_binding : module_binding -> module_binding; method match_case : match_case -> match_case; method ident : ident -> ident; + + method unknown : ! 'a. 'a -> 'a; end; + (** Fold style traversal *) class fold : object ('self_type) method string : string -> 'self_type; - method int : int -> 'self_type; - method float : float -> 'self_type; - method bool : bool -> 'self_type; method list : ! 'a . ('self_type -> 'a -> 'self_type) -> list 'a -> 'self_type; - method option : ! 'a . ('self_type -> 'a -> 'self_type) -> option 'a -> 'self_type; - method array : ! 'a . ('self_type -> 'a -> 'self_type) -> array 'a -> 'self_type; - method ref : ! 'a . ('self_type -> 'a -> 'self_type) -> ref 'a -> 'self_type; method meta_bool : meta_bool -> 'self_type; method meta_option : ! 'a . ('self_type -> 'a -> 'self_type) -> meta_option 'a -> 'self_type; method meta_list : ! 'a . ('self_type -> 'a -> 'self_type) -> meta_list 'a -> 'self_type; - method _Loc_t : Loc.t -> 'self_type; + method loc : loc -> 'self_type; method expr : expr -> 'self_type; method patt : patt -> 'self_type; method ctyp : ctyp -> 'self_type; @@ -326,163 +313,153 @@ module type Ast = sig method module_binding : module_binding -> 'self_type; method match_case : match_case -> 'self_type; method ident : ident -> 'self_type; + + method unknown : ! 'a. 'a -> 'self_type; end; end; -(** The AntiquotSyntax signature describe the minimal interface needed - for antiquotation handling. *) -module type AntiquotSyntax = sig - module Ast : Ast; - - (** The parse function for expressions. - The underlying expression grammar entry is generally "expr; EOI". *) - value parse_expr : Ast.Loc.t -> string -> Ast.expr; - - (** The parse function for patterns. - The underlying pattern grammar entry is generally "patt; EOI". *) - value parse_patt : Ast.Loc.t -> string -> Ast.patt; -end; - -(** Signature for OCaml syntax trees. +(** Signature for OCaml syntax trees. *) (* This signature is an extension of {!Ast} It provides: - Types for all kinds of structure. - Map: A base class for map traversals. - Map classes and functions for common kinds. - (* Core language *) - ctyp (* Representaion of types *) - patt (* The type of patterns *) - expr (* The type of expressions *) - match_case (* The type of cases for match/function/try constructions *) - ident (* The type of identifiers (including path like Foo(X).Bar.y) *) - binding (* The type of let bindings *) - rec_binding (* The type of record definitions *) - - (* Modules *) - module_type (* The type of module types *) - sig_item (* The type of signature items *) - str_item (* The type of structure items *) - module_expr (* The type of module expressions *) - module_binding (* The type of recursive module definitions *) - with_constr (* The type of `with' constraints *) - - (* Classes *) - class_type (* The type of class types *) - class_sig_item (* The type of class signature items *) - class_expr (* The type of class expressions *) - class_str_item (* The type of class structure items *) + == Core language == + ctyp :: Representaion of types + patt :: The type of patterns + expr :: The type of expressions + match_case :: The type of cases for match/function/try constructions + ident :: The type of identifiers (including path like Foo(X).Bar.y) + binding :: The type of let bindings + rec_binding :: The type of record definitions + + == Modules == + module_type :: The type of module types + sig_item :: The type of signature items + str_item :: The type of structure items + module_expr :: The type of module expressions + module_binding :: The type of recursive module definitions + with_constr :: The type of `with' constraints + + == Classes == + class_type :: The type of class types + class_sig_item :: The type of class signature items + class_expr :: The type of class expressions + class_str_item :: The type of class structure items *) module type Camlp4Ast = sig + (** The inner module for locations *) module Loc : Loc; INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml"; - value loc_of_ctyp : ctyp -> Loc.t; - value loc_of_patt : patt -> Loc.t; - value loc_of_expr : expr -> Loc.t; - value loc_of_module_type : module_type -> Loc.t; - value loc_of_module_expr : module_expr -> Loc.t; - value loc_of_sig_item : sig_item -> Loc.t; - value loc_of_str_item : str_item -> Loc.t; - value loc_of_class_type : class_type -> Loc.t; - value loc_of_class_sig_item : class_sig_item -> Loc.t; - value loc_of_class_expr : class_expr -> Loc.t; - value loc_of_class_str_item : class_str_item -> Loc.t; - value loc_of_with_constr : with_constr -> Loc.t; - value loc_of_binding : binding -> Loc.t; - value loc_of_rec_binding : rec_binding -> Loc.t; - value loc_of_module_binding : module_binding -> Loc.t; - value loc_of_match_case : match_case -> Loc.t; - value loc_of_ident : ident -> Loc.t; + value loc_of_ctyp : ctyp -> loc; + value loc_of_patt : patt -> loc; + value loc_of_expr : expr -> loc; + value loc_of_module_type : module_type -> loc; + value loc_of_module_expr : module_expr -> loc; + value loc_of_sig_item : sig_item -> loc; + value loc_of_str_item : str_item -> loc; + value loc_of_class_type : class_type -> loc; + value loc_of_class_sig_item : class_sig_item -> loc; + value loc_of_class_expr : class_expr -> loc; + value loc_of_class_str_item : class_str_item -> loc; + value loc_of_with_constr : with_constr -> loc; + value loc_of_binding : binding -> loc; + value loc_of_rec_binding : rec_binding -> loc; + value loc_of_module_binding : module_binding -> loc; + value loc_of_match_case : match_case -> loc; + value loc_of_ident : ident -> loc; module Meta : sig module type META_LOC = sig - (** The first location is where to put the returned pattern. + (* The first location is where to put the returned pattern. Generally it's _loc to match with <:patt< ... >> quotations. The second location is the one to treat. *) - value meta_loc_patt : Loc.t -> Loc.t -> patt; - (** The first location is where to put the returned expression. + value meta_loc_patt : loc -> loc -> patt; + (* The first location is where to put the returned expression. Generally it's _loc to match with <:expr< ... >> quotations. The second location is the one to treat. *) - value meta_loc_expr : Loc.t -> Loc.t -> expr; + value meta_loc_expr : loc -> loc -> expr; end; module MetaLoc : sig - value meta_loc_patt : Loc.t -> Loc.t -> patt; - value meta_loc_expr : Loc.t -> Loc.t -> expr; + value meta_loc_patt : loc -> loc -> patt; + value meta_loc_expr : loc -> loc -> expr; end; module MetaGhostLoc : sig - value meta_loc_patt : Loc.t -> 'a -> patt; - value meta_loc_expr : Loc.t -> 'a -> expr; + value meta_loc_patt : loc -> 'a -> patt; + value meta_loc_expr : loc -> 'a -> expr; end; module MetaLocVar : sig - value meta_loc_patt : Loc.t -> 'a -> patt; - value meta_loc_expr : Loc.t -> 'a -> expr; + value meta_loc_patt : loc -> 'a -> patt; + value meta_loc_expr : loc -> 'a -> expr; end; module Make (MetaLoc : META_LOC) : sig module Expr : sig - value meta_string : Loc.t -> string -> expr; - value meta_int : Loc.t -> string -> expr; - value meta_float : Loc.t -> string -> expr; - value meta_char : Loc.t -> string -> expr; - value meta_bool : Loc.t -> bool -> expr; - value meta_list : (Loc.t -> 'a -> expr) -> Loc.t -> list 'a -> expr; - value meta_binding : Loc.t -> binding -> expr; - value meta_rec_binding : Loc.t -> rec_binding -> expr; - value meta_class_expr : Loc.t -> class_expr -> expr; - value meta_class_sig_item : Loc.t -> class_sig_item -> expr; - value meta_class_str_item : Loc.t -> class_str_item -> expr; - value meta_class_type : Loc.t -> class_type -> expr; - value meta_ctyp : Loc.t -> ctyp -> expr; - value meta_expr : Loc.t -> expr -> expr; - value meta_ident : Loc.t -> ident -> expr; - value meta_match_case : Loc.t -> match_case -> expr; - value meta_module_binding : Loc.t -> module_binding -> expr; - value meta_module_expr : Loc.t -> module_expr -> expr; - value meta_module_type : Loc.t -> module_type -> expr; - value meta_patt : Loc.t -> patt -> expr; - value meta_sig_item : Loc.t -> sig_item -> expr; - value meta_str_item : Loc.t -> str_item -> expr; - value meta_with_constr : Loc.t -> with_constr -> expr; + value meta_string : loc -> string -> expr; + value meta_int : loc -> string -> expr; + value meta_float : loc -> string -> expr; + value meta_char : loc -> string -> expr; + value meta_bool : loc -> bool -> expr; + value meta_list : (loc -> 'a -> expr) -> loc -> list 'a -> expr; + value meta_binding : loc -> binding -> expr; + value meta_rec_binding : loc -> rec_binding -> expr; + value meta_class_expr : loc -> class_expr -> expr; + value meta_class_sig_item : loc -> class_sig_item -> expr; + value meta_class_str_item : loc -> class_str_item -> expr; + value meta_class_type : loc -> class_type -> expr; + value meta_ctyp : loc -> ctyp -> expr; + value meta_expr : loc -> expr -> expr; + value meta_ident : loc -> ident -> expr; + value meta_match_case : loc -> match_case -> expr; + value meta_module_binding : loc -> module_binding -> expr; + value meta_module_expr : loc -> module_expr -> expr; + value meta_module_type : loc -> module_type -> expr; + value meta_patt : loc -> patt -> expr; + value meta_sig_item : loc -> sig_item -> expr; + value meta_str_item : loc -> str_item -> expr; + value meta_with_constr : loc -> with_constr -> expr; end; module Patt : sig - value meta_string : Loc.t -> string -> patt; - value meta_int : Loc.t -> string -> patt; - value meta_float : Loc.t -> string -> patt; - value meta_char : Loc.t -> string -> patt; - value meta_bool : Loc.t -> bool -> patt; - value meta_list : (Loc.t -> 'a -> patt) -> Loc.t -> list 'a -> patt; - value meta_binding : Loc.t -> binding -> patt; - value meta_rec_binding : Loc.t -> rec_binding -> patt; - value meta_class_expr : Loc.t -> class_expr -> patt; - value meta_class_sig_item : Loc.t -> class_sig_item -> patt; - value meta_class_str_item : Loc.t -> class_str_item -> patt; - value meta_class_type : Loc.t -> class_type -> patt; - value meta_ctyp : Loc.t -> ctyp -> patt; - value meta_expr : Loc.t -> expr -> patt; - value meta_ident : Loc.t -> ident -> patt; - value meta_match_case : Loc.t -> match_case -> patt; - value meta_module_binding : Loc.t -> module_binding -> patt; - value meta_module_expr : Loc.t -> module_expr -> patt; - value meta_module_type : Loc.t -> module_type -> patt; - value meta_patt : Loc.t -> patt -> patt; - value meta_sig_item : Loc.t -> sig_item -> patt; - value meta_str_item : Loc.t -> str_item -> patt; - value meta_with_constr : Loc.t -> with_constr -> patt; + value meta_string : loc -> string -> patt; + value meta_int : loc -> string -> patt; + value meta_float : loc -> string -> patt; + value meta_char : loc -> string -> patt; + value meta_bool : loc -> bool -> patt; + value meta_list : (loc -> 'a -> patt) -> loc -> list 'a -> patt; + value meta_binding : loc -> binding -> patt; + value meta_rec_binding : loc -> rec_binding -> patt; + value meta_class_expr : loc -> class_expr -> patt; + value meta_class_sig_item : loc -> class_sig_item -> patt; + value meta_class_str_item : loc -> class_str_item -> patt; + value meta_class_type : loc -> class_type -> patt; + value meta_ctyp : loc -> ctyp -> patt; + value meta_expr : loc -> expr -> patt; + value meta_ident : loc -> ident -> patt; + value meta_match_case : loc -> match_case -> patt; + value meta_module_binding : loc -> module_binding -> patt; + value meta_module_expr : loc -> module_expr -> patt; + value meta_module_type : loc -> module_type -> patt; + value meta_patt : loc -> patt -> patt; + value meta_sig_item : loc -> sig_item -> patt; + value meta_str_item : loc -> str_item -> patt; + value meta_with_constr : loc -> with_constr -> patt; end; end; end; (** See {!Ast.map}. *) - class map : object - inherit mapper; + class map : object ('self_type) + method string : string -> string; + method list : ! 'a 'b . ('self_type -> 'a -> 'b) -> list 'a -> list 'b; method meta_bool : meta_bool -> meta_bool; - method meta_option : ! 'a 'b . ('a -> 'b) -> meta_option 'a -> meta_option 'b; - method meta_list : ! 'a 'b . ('a -> 'b) -> meta_list 'a -> meta_list 'b; - method _Loc_t : Loc.t -> Loc.t; + method meta_option : ! 'a 'b . ('self_type -> 'a -> 'b) -> meta_option 'a -> meta_option 'b; + method meta_list : ! 'a 'b . ('self_type -> 'a -> 'b) -> meta_list 'a -> meta_list 'b; + method loc : loc -> loc; method expr : expr -> expr; method patt : patt -> patt; method ctyp : ctyp -> ctyp; @@ -501,22 +478,18 @@ module type Camlp4Ast = sig method module_binding : module_binding -> module_binding; method match_case : match_case -> match_case; method ident : ident -> ident; + + method unknown : ! 'a. 'a -> 'a; end; (** See {!Ast.fold}. *) class fold : object ('self_type) method string : string -> 'self_type; - method int : int -> 'self_type; - method float : float -> 'self_type; - method bool : bool -> 'self_type; method list : ! 'a . ('self_type -> 'a -> 'self_type) -> list 'a -> 'self_type; - method option : ! 'a . ('self_type -> 'a -> 'self_type) -> option 'a -> 'self_type; - method array : ! 'a . ('self_type -> 'a -> 'self_type) -> array 'a -> 'self_type; - method ref : ! 'a . ('self_type -> 'a -> 'self_type) -> ref 'a -> 'self_type; method meta_bool : meta_bool -> 'self_type; method meta_option : ! 'a . ('self_type -> 'a -> 'self_type) -> meta_option 'a -> 'self_type; method meta_list : ! 'a . ('self_type -> 'a -> 'self_type) -> meta_list 'a -> 'self_type; - method _Loc_t : Loc.t -> 'self_type; + method loc : loc -> 'self_type; method expr : expr -> 'self_type; method patt : patt -> 'self_type; method ctyp : ctyp -> 'self_type; @@ -534,6 +507,8 @@ module type Camlp4Ast = sig method module_binding : module_binding -> 'self_type; method match_case : match_case -> 'self_type; method ident : ident -> 'self_type; + + method unknown : ! 'a. 'a -> 'self_type; end; value map_expr : (expr -> expr) -> map; @@ -541,7 +516,7 @@ module type Camlp4Ast = sig value map_ctyp : (ctyp -> ctyp) -> map; value map_str_item : (str_item -> str_item) -> map; value map_sig_item : (sig_item -> sig_item) -> map; - value map_loc : (Loc.t -> Loc.t) -> map; + value map_loc : (loc -> loc) -> map; value ident_of_expr : expr -> ident; value ident_of_patt : patt -> ident; @@ -614,7 +589,7 @@ end; Typical use is for [with] constraints. Example: ... with module Ast = Camlp4.Sig.Camlp4AstToAst Camlp4Ast *) module Camlp4AstToAst (M : Camlp4Ast) : Ast - with module Loc = M.Loc + with type loc = M.loc and type meta_bool = M.meta_bool and type meta_option 'a = M.meta_option 'a and type meta_list 'a = M.meta_list 'a @@ -637,7 +612,8 @@ module Camlp4AstToAst (M : Camlp4Ast) : Ast and type ident = M.ident = M; -(** Since the Ast contains locations. This functor produces Ast types +(** Concrete definition of Camlp4 ASTs abstracted from locations. + Since the Ast contains locations, this functor produces Ast types for a given location type. *) module MakeCamlp4Ast (Loc : Type) = struct @@ -645,6 +621,11 @@ module MakeCamlp4Ast (Loc : Type) = struct end; +(** {6 Filters} *) + +(** A type for stream filters. *) +type stream_filter 'a 'loc = Stream.t ('a * 'loc) -> Stream.t ('a * 'loc); + (** Registerinng and folding of Ast filters. Two kinds of filters must be handled: - Implementation filters: str_item -> str_item. @@ -653,8 +634,6 @@ module type AstFilters = sig module Ast : Camlp4Ast; - (** {6 Filters} *) - type filter 'a = 'a -> 'a; value register_sig_item_filter : (filter Ast.sig_item) -> unit; @@ -665,8 +644,7 @@ module type AstFilters = sig end; -(** Ast as one single type *) - +(** ASTs as one single dynamic type *) module type DynAst = sig module Ast : Ast; type tag 'a; @@ -700,22 +678,27 @@ module type DynAst = sig end; -(** Quotation operations. *) +(** {6 Quotation operations} *) +(** The generic quotation type. + To see how fields are used here is an example: + <:q_name@q_loc> + The last one, q_shift is equal to the length of "<:q_name@q_loc<". *) type quotation = { q_name : string ; q_loc : string ; q_shift : int ; q_contents : string }; +(** The signature for a quotation expander registery. *) module type Quotation = sig module Ast : Ast; module DynAst : DynAst with module Ast = Ast; open Ast; - (** The Loc.t is the initial location. The option string is the optional name + (** The [loc] is the initial location. The option string is the optional name for the location variable. The string is the quotation contents. *) - type expand_fun 'a = Loc.t -> option string -> string -> 'a; + type expand_fun 'a = loc -> option string -> string -> 'a; (** [add name exp] adds the quotation [name] associated with the expander [exp]. *) @@ -730,12 +713,12 @@ module type Quotation = sig (** [parse_quotation_result parse_function loc position_tag quotation quotation_result] It's a parser wrapper, this function handles the error reporting for you. *) value parse_quotation_result : - (Loc.t -> string -> 'a) -> Loc.t -> quotation -> string -> string -> 'a; + (loc -> string -> 'a) -> loc -> quotation -> string -> string -> 'a; (** function translating quotation names; default = identity *) value translate : ref (string -> string); - value expand : Loc.t -> quotation -> DynAst.tag 'a -> 'a; + value expand : loc -> quotation -> DynAst.tag 'a -> 'a; (** [dump_file] optionally tells Camlp4 to dump the result of an expander if this result is syntactically incorrect. @@ -747,8 +730,9 @@ module type Quotation = sig end; -type stream_filter 'a 'loc = Stream.t ('a * 'loc) -> Stream.t ('a * 'loc); +(** {6 Tokens} *) +(** A signature for tokens. *) module type Token = sig module Loc : Loc; @@ -807,17 +791,17 @@ end; ("42", "4_2", "0000042", "0b0101010"...). The meaning of the tokens are: -- * [KEYWORD s] is the keyword [s]. -- * [LIDENT s] is the ident [s] starting with a lowercase letter. -- * [UIDENT s] is the ident [s] starting with an uppercase letter. -- * [INT i s] (resp. [INT32 i s], [INT64 i s] and [NATIVEINT i s]) - is the integer constant [i] whose string source is [s]. -- * [FLOAT f s] is the float constant [f] whose string source is [s]. -- * [STRING s s'] is the string constant [s] whose string source is [s']. -- * [CHAR c s] is the character constant [c] whose string source is [s]. -- * [QUOTATION q] is a quotation [q], see {!Quotation.t} for more information. -- * [ANTIQUOT n s] is an antiquotation [n] holding the string [s]. -- * [EOI] is the end of input. +- [KEYWORD s] is the keyword [s]. +- [LIDENT s] is the ident [s] starting with a lowercase letter. +- [UIDENT s] is the ident [s] starting with an uppercase letter. +- [INT i s] (resp. [INT32 i s], [INT64 i s] and [NATIVEINT i s]) + the integer constant [i] whose string source is [s]. +- [FLOAT f s] is the float constant [f] whose string source is [s]. +- [STRING s s'] is the string constant [s] whose string source is [s']. +- [CHAR c s] is the character constant [c] whose string source is [s]. +- [QUOTATION q] is a quotation [q], see {!Quotation.t} for more information. +- [ANTIQUOT n s] is an antiquotation [n] holding the string [s]. +- [EOI] is the end of input. Warning: the second string associated with the constructor [STRING] is the string found in the source without any interpretation. In particular, @@ -827,7 +811,6 @@ end; ["n"]. To interpret a string use the first string of the [STRING] constructor (or if you need to compute it use the module {!Camlp4.Struct.Token.Eval}. Same thing for the constructor [CHAR]. *) - type camlp4_token = [ KEYWORD of string | SYMBOL of string @@ -851,8 +834,12 @@ type camlp4_token = | LINE_DIRECTIVE of int and option string | EOI ]; +(** A signature for specialized tokens. *) module type Camlp4Token = Token with type t = camlp4_token; +(** {6 Dynamic loaders} *) + +(** A signature for dynamic loaders. *) module type DynLoader = sig type t; exception Error of string and string; @@ -878,6 +865,7 @@ module type DynLoader = sig value find_in_path : t -> string -> string; end; +(** A signature for grammars. *) module Grammar = struct (** Internal signature for sematantic actions of grammars, @@ -981,9 +969,10 @@ module Grammar = struct (** Same as {!print} but show the left-factorization. *) value dump : Format.formatter -> t 'a -> unit; - (*/*) + (**/**) value obj : t 'a -> internal_entry; value clear : t 'a -> unit; + (**/**) end; (** [get_filter g] Get the {!Token.Filter} associated to the [g]. *) @@ -1062,9 +1051,10 @@ module Grammar = struct (** Same as {!print} but show the left-factorization. *) value dump : Format.formatter -> t 'a -> unit; - (*/*) + (**/**) value obj : t 'a -> internal_entry; value clear : t 'a -> unit; + (**/**) end; (** Get the {!Token.Filter} associated to the grammar module. *) @@ -1112,6 +1102,7 @@ module Grammar = struct end; +(** A signature for lexers. *) module type Lexer = sig module Loc : Loc; module Token : Token with module Loc = Loc; @@ -1126,8 +1117,18 @@ module type Lexer = sig end; -(** {6 Parser} *) +(** A signature for parsers abstract from ASTs. *) module Parser (Ast : Ast) = struct + module type SIMPLE = sig + (** The parse function for expressions. + The underlying expression grammar entry is generally "expr; EOI". *) + value parse_expr : Ast.loc -> string -> Ast.expr; + + (** The parse function for patterns. + The underlying pattern grammar entry is generally "patt; EOI". *) + value parse_patt : Ast.loc -> string -> Ast.patt; + end; + module type S = sig (** Called when parsing an implementation (ml file) to build the syntax @@ -1137,16 +1138,15 @@ module Parser (Ast : Ast) = struct syntax), the given [directive_handler] function evaluates it and the parsing starts again. *) value parse_implem : ?directive_handler:(Ast.str_item -> option Ast.str_item) -> - Ast.Loc.t -> Stream.t char -> Ast.str_item; + Ast.loc -> Stream.t char -> Ast.str_item; (** Same as {!parse_implem} but for interface (mli file). *) value parse_interf : ?directive_handler:(Ast.sig_item -> option Ast.sig_item) -> - Ast.Loc.t -> Stream.t char -> Ast.sig_item; + Ast.loc -> Stream.t char -> Ast.sig_item; end; end; -(** {6 Printer} *) - +(** A signature for printers abstract from ASTs. *) module Printer (Ast : Ast) = struct module type S = sig @@ -1164,13 +1164,13 @@ end; There is also the main grammar entries. *) module type Syntax = sig module Loc : Loc; - module Ast : Ast with module Loc = Loc; + module Ast : Ast with type loc = Loc.t; module Token : Token with module Loc = Loc; module Gram : Grammar.Static with module Loc = Loc and module Token = Token; - module AntiquotSyntax : AntiquotSyntax with module Ast = Ast; - (* Gram is not constrained here for flexibility *) module Quotation : Quotation with module Ast = Ast; + module AntiquotSyntax : (Parser Ast).SIMPLE; + include (Warning Loc).S; include (Parser Ast).S; include (Printer Ast).S; @@ -1187,10 +1187,10 @@ module type Camlp4Syntax = sig module Token : Camlp4Token with module Loc = Loc; module Gram : Grammar.Static with module Loc = Loc and module Token = Token; - module AntiquotSyntax : AntiquotSyntax with module Ast = Camlp4AstToAst Ast; - (* Gram is not constrained here for flexibility *) module Quotation : Quotation with module Ast = Camlp4AstToAst Ast; + module AntiquotSyntax : (Parser Ast).SIMPLE; + include (Warning Loc).S; include (Parser Ast).S; include (Printer Ast).S; @@ -1347,11 +1347,11 @@ module type Camlp4Syntax = sig value infixop4 : Gram.Entry.t Ast.expr; end; +(** A signature for syntax extension (syntax -> syntax functors). *) module type SyntaxExtension = functor (Syn : Syntax) -> (Syntax with module Loc = Syn.Loc and module Ast = Syn.Ast and module Token = Syn.Token and module Gram = Syn.Gram - and module AntiquotSyntax = Syn.AntiquotSyntax and module Quotation = Syn.Quotation); diff --git a/camlp4/Camlp4/Struct/Camlp4Ast.mlast b/camlp4/Camlp4/Struct/Camlp4Ast.mlast index b7a8b4ff..0a34532a 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast.mlast +++ b/camlp4/Camlp4/Struct/Camlp4Ast.mlast @@ -108,7 +108,7 @@ module Make (Loc : Sig.Loc) | <:patt< _ >> -> True | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y | <:patt< { $p$ } >> -> is_irrefut_patt p - | <:patt< $lid:_$ = $p$ >> -> is_irrefut_patt p + | <:patt< $_$ = $p$ >> -> is_irrefut_patt p | <:patt< $p1$; $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 | <:patt< $p1$, $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p @@ -450,6 +450,10 @@ module Make (Loc : Sig.Loc) list_of_module_binding x (list_of_module_binding y acc) | x -> [x :: acc] ]; + module Camlp4Trash = struct + INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml"; + end; + module Meta = struct module type META_LOC = sig @@ -491,17 +495,17 @@ module Make (Loc : Sig.Loc) module Make (MetaLoc : META_LOC) = struct open MetaLoc; - value meta_acc_Loc_t = meta_loc_expr; + value meta_loc = meta_loc_expr; module Expr = Camlp4Filters.MetaGeneratorExpr Ast; - value meta_acc_Loc_t = meta_loc_patt; + value meta_loc = meta_loc_patt; module Patt = Camlp4Filters.MetaGeneratorPatt Ast; end; end; - class map = Camlp4Filters.GenerateMap.generated; + class map = Camlp4MapGenerator.generated; - class fold = Camlp4Filters.GenerateFold.generated; + class fold = Camlp4FoldGenerator.generated; value map_expr f = object inherit map as super; @@ -525,11 +529,6 @@ module Make (Loc : Sig.Loc) end; value map_loc f = object inherit map as super; - method _Loc_t x = f (super#_Loc_t x); + method loc x = f (super#loc x); end; end; - -module Camlp4Trash = struct -(* #use "camlp4/Camlp4/Camlp4Ast.partial.ml"; *) - INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml"; -end; diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml index fd2c38a7..1b26866d 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -18,13 +18,13 @@ * - Nicolas Pouillard: refactoring *) -(* $Id: Camlp4Ast2OCamlAst.ml,v 1.15.2.4 2007/05/10 13:31:20 pouillar Exp $ *) +(* $Id: Camlp4Ast2OCamlAst.ml,v 1.15.2.8 2007/09/19 13:20:33 ertai Exp $ *) module Make (Ast : Sig.Camlp4Ast) = struct open Format; - open Parsetree; - open Longident; - open Asttypes; + open Camlp4_import.Parsetree; + open Camlp4_import.Longident; + open Camlp4_import.Asttypes; open Ast; value constructors_arity () = @@ -227,8 +227,6 @@ module Make (Ast : Sig.Camlp4Ast) = struct let t1 = TyApp loc1 <:ctyp@loc1< option >> t1 in mktyp loc (Ptyp_arrow ("?" ^ lab) (ctyp t1) (ctyp t2)) | TyArr loc t1 t2 -> mktyp loc (Ptyp_arrow "" (ctyp t1) (ctyp t2)) - | <:ctyp@loc< < > >> -> mktyp loc (Ptyp_object []) - | <:ctyp@loc< < .. > >> -> mktyp loc (Ptyp_object [mkfield loc Pfield_var]) | <:ctyp@loc< < $fl$ > >> -> mktyp loc (Ptyp_object (meth_list fl [])) | <:ctyp@loc< < $fl$ .. > >> -> mktyp loc (Ptyp_object (meth_list fl [mkfield loc Pfield_var])) @@ -261,7 +259,8 @@ module Make (Ast : Sig.Camlp4Ast) = struct TyObj _ _ (BAnt _) | TyNil _ | TyTup _ _ -> assert False ] and row_field = fun - [ <:ctyp< `$i$ >> -> [Rtag i True []] + [ <:ctyp<>> -> [] + | <:ctyp< `$i$ >> -> [Rtag i True []] | <:ctyp< `$i$ of & $t$ >> -> [Rtag i True (List.map ctyp (list_of_ctyp t []))] | <:ctyp< `$i$ of $t$ >> -> [Rtag i False (List.map ctyp (list_of_ctyp t []))] | <:ctyp< $t1$ | $t2$ >> -> row_field t1 @ row_field t2 @@ -272,7 +271,8 @@ module Make (Ast : Sig.Camlp4Ast) = struct | _ -> assert False ] and meth_list fl acc = match fl with - [ <:ctyp< $t1$; $t2$ >> -> meth_list t1 (meth_list t2 acc) + [ <:ctyp<>> -> acc + | <:ctyp< $t1$; $t2$ >> -> meth_list t1 (meth_list t2 acc) | <:ctyp@loc< $lid:lab$ : $t$ >> -> [mkfield loc (Pfield lab (mkpolytype (ctyp t))) :: acc] | _ -> assert False ] @@ -772,7 +772,8 @@ module Make (Ast : Sig.Camlp4Ast) = struct | _ -> assert False ] and mkideexp x acc = match x with - [ <:rec_binding< $x$; $y$ >> -> + [ <:rec_binding<>> -> acc + | <:rec_binding< $x$; $y$ >> -> mkideexp x (mkideexp y acc) | <:rec_binding< $lid:s$ = $e$ >> -> [(s, expr e) :: acc] | _ -> assert False ] diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli index 2ebcf43d..e790f630 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli @@ -19,15 +19,15 @@ *) -(* $Id: Camlp4Ast2OCamlAst.mli,v 1.3 2007/02/07 10:09:21 ertai Exp $ *) +(* $Id: Camlp4Ast2OCamlAst.mli,v 1.3.4.1 2007/05/22 09:09:45 pouillar Exp $ *) module Make (Camlp4Ast : Sig.Camlp4Ast) : sig open Camlp4Ast; (** {6 Useful functions} *) - value sig_item : sig_item -> Parsetree.signature; - value str_item : str_item -> Parsetree.structure; - value phrase : str_item -> Parsetree.toplevel_phrase; + value sig_item : sig_item -> Camlp4_import.Parsetree.signature; + value str_item : str_item -> Camlp4_import.Parsetree.structure; + value phrase : str_item -> Camlp4_import.Parsetree.toplevel_phrase; end; diff --git a/camlp4/Camlp4/Struct/CleanAst.ml b/camlp4/Camlp4/Struct/CleanAst.ml index bd1cac2f..ab925054 100644 --- a/camlp4/Camlp4/Struct/CleanAst.ml +++ b/camlp4/Camlp4/Struct/CleanAst.ml @@ -19,111 +19,126 @@ (** This module is suppose to contain nils elimination. *) module Make (Ast : Sig.Camlp4Ast) = struct - class clean_ast = object (self) + class clean_ast = object inherit Ast.map as super; - method with_constr = fun - [ <:with_constr< $ <:with_constr<>> $ and $wc$ >> | - <:with_constr< $wc$ and $ <:with_constr<>> $ >> -> self#with_constr wc - | wc -> super#with_constr wc ]; - - method expr = fun - [ <:expr< let $rec:_$ $ <:binding<>> $ in $e$ >> | - <:expr< { ($e$) with $ <:rec_binding<>> $ } >> | - <:expr< $ <:expr<>> $, $e$ >> | - <:expr< $e$, $ <:expr<>> $ >> | - <:expr< $ <:expr<>> $; $e$ >> | - <:expr< $e$; $ <:expr<>> $ >> -> self#expr e - | e -> super#expr e ]; - - method patt = fun - [ <:patt< ( $p$ as $ <:patt<>> $ ) >> | - <:patt< $ <:patt<>> $ | $p$ >> | - <:patt< $p$ | $ <:patt<>> $ >> | - <:patt< $ <:patt<>> $, $p$ >> | - <:patt< $p$, $ <:patt<>> $ >> | - <:patt< $ <:patt<>> $; $p$ >> | - <:patt< $p$; $ <:patt<>> $ >> -> self#patt p - | p -> super#patt p ]; - - method match_case = fun - [ <:match_case< $ <:match_case<>> $ | $mc$ >> | - <:match_case< $mc$ | $ <:match_case<>> $ >> -> self#match_case mc - | mc -> super#match_case mc ]; - - method binding = fun - [ <:binding< $ <:binding<>> $ and $bi$ >> | - <:binding< $bi$ and $ <:binding<>> $ >> -> self#binding bi - | bi -> super#binding bi ]; - - method rec_binding = fun - [ <:rec_binding< $ <:rec_binding<>> $ ; $bi$ >> | - <:rec_binding< $bi$ ; $ <:rec_binding<>> $ >> -> self#rec_binding bi - | bi -> super#rec_binding bi ]; - - method module_binding = fun - [ <:module_binding< $ <:module_binding<>> $ and $mb$ >> | - <:module_binding< $mb$ and $ <:module_binding<>> $ >> -> - self#module_binding mb - | mb -> super#module_binding mb ]; - - method ctyp = fun - [ <:ctyp< ! $ <:ctyp<>> $ . $t$ >> | - <:ctyp< $ <:ctyp<>> $ as $t$ >> | - <:ctyp< $t$ as $ <:ctyp<>> $ >> | - <:ctyp< $t$ -> $ <:ctyp<>> $ >> | - <:ctyp< $ <:ctyp<>> $ -> $t$ >> | - <:ctyp< $ <:ctyp<>> $ | $t$ >> | - <:ctyp< $t$ | $ <:ctyp<>> $ >> | - <:ctyp< $t$ of $ <:ctyp<>> $ >> | - <:ctyp< $ <:ctyp<>> $ and $t$ >> | - <:ctyp< $t$ and $ <:ctyp<>> $ >> | - <:ctyp< $t$; $ <:ctyp<>> $ >> | - <:ctyp< $ <:ctyp<>> $; $t$ >> | - <:ctyp< $ <:ctyp<>> $, $t$ >> | - <:ctyp< $t$, $ <:ctyp<>> $ >> | - <:ctyp< $t$ & $ <:ctyp<>> $ >> | - <:ctyp< $ <:ctyp<>> $ & $t$ >> | - <:ctyp< $ <:ctyp<>> $ * $t$ >> | - <:ctyp< $t$ * $ <:ctyp<>> $ >> -> self#ctyp t - | t -> super#ctyp t ]; - - method sig_item = fun - [ <:sig_item< $ <:sig_item<>> $; $sg$ >> | - <:sig_item< $sg$; $ <:sig_item<>> $ >> -> self#sig_item sg - | sg -> super#sig_item sg ]; - - method str_item = fun - [ <:str_item< $ <:str_item<>> $; $st$ >> | - <:str_item< $st$; $ <:str_item<>> $ >> -> self#str_item st - | st -> super#str_item st ]; - - method module_type = fun - [ <:module_type< $mt$ with $ <:with_constr<>> $ >> -> self#module_type mt - | mt -> super#module_type mt ]; - - method class_expr = fun - [ <:class_expr< $ <:class_expr<>> $ and $ce$ >> | - <:class_expr< $ce$ and $ <:class_expr<>> $ >> -> self#class_expr ce - | ce -> super#class_expr ce ]; - - method class_type = fun - [ <:class_type< $ <:class_type<>> $ and $ct$ >> | - <:class_type< $ct$ and $ <:class_type<>> $ >> -> self#class_type ct - | ct -> super#class_type ct ]; - - method class_sig_item = fun - [ <:class_sig_item< $ <:class_sig_item<>> $; $csg$ >> | - <:class_sig_item< $csg$; $ <:class_sig_item<>> $ >> -> - self#class_sig_item csg - | csg -> super#class_sig_item csg ]; - - method class_str_item = fun - [ <:class_str_item< $ <:class_str_item<>> $; $cst$ >> | - <:class_str_item< $cst$; $ <:class_str_item<>> $ >> -> - self#class_str_item cst - | cst -> super#class_str_item cst ]; + method with_constr wc = + match super#with_constr wc with + [ <:with_constr< $ <:with_constr<>> $ and $wc$ >> | + <:with_constr< $wc$ and $ <:with_constr<>> $ >> -> wc + | wc -> wc ]; + + method expr e = + match super#expr e with + [ <:expr< let $rec:_$ $ <:binding<>> $ in $e$ >> | + <:expr< { ($e$) with $ <:rec_binding<>> $ } >> | + <:expr< $ <:expr<>> $, $e$ >> | + <:expr< $e$, $ <:expr<>> $ >> | + <:expr< $ <:expr<>> $; $e$ >> | + <:expr< $e$; $ <:expr<>> $ >> -> e + | e -> e ]; + + method patt p = + match super#patt p with + [ <:patt< ( $p$ as $ <:patt<>> $ ) >> | + <:patt< $ <:patt<>> $ | $p$ >> | + <:patt< $p$ | $ <:patt<>> $ >> | + <:patt< $ <:patt<>> $, $p$ >> | + <:patt< $p$, $ <:patt<>> $ >> | + <:patt< $ <:patt<>> $; $p$ >> | + <:patt< $p$; $ <:patt<>> $ >> -> p + | p -> p ]; + + method match_case mc = + match super#match_case mc with + [ <:match_case< $ <:match_case<>> $ | $mc$ >> | + <:match_case< $mc$ | $ <:match_case<>> $ >> -> mc + | mc -> mc ]; + + method binding bi = + match super#binding bi with + [ <:binding< $ <:binding<>> $ and $bi$ >> | + <:binding< $bi$ and $ <:binding<>> $ >> -> bi + | bi -> bi ]; + + method rec_binding rb = + match super#rec_binding rb with + [ <:rec_binding< $ <:rec_binding<>> $ ; $bi$ >> | + <:rec_binding< $bi$ ; $ <:rec_binding<>> $ >> -> bi + | bi -> bi ]; + + method module_binding mb = + match super#module_binding mb with + [ <:module_binding< $ <:module_binding<>> $ and $mb$ >> | + <:module_binding< $mb$ and $ <:module_binding<>> $ >> -> mb + | mb -> mb ]; + + method ctyp t = + match super#ctyp t with + [ <:ctyp< ! $ <:ctyp<>> $ . $t$ >> | + <:ctyp< $ <:ctyp<>> $ as $t$ >> | + <:ctyp< $t$ as $ <:ctyp<>> $ >> | + <:ctyp< $t$ -> $ <:ctyp<>> $ >> | + <:ctyp< $ <:ctyp<>> $ -> $t$ >> | + <:ctyp< $ <:ctyp<>> $ | $t$ >> | + <:ctyp< $t$ | $ <:ctyp<>> $ >> | + <:ctyp< $t$ of $ <:ctyp<>> $ >> | + <:ctyp< $ <:ctyp<>> $ and $t$ >> | + <:ctyp< $t$ and $ <:ctyp<>> $ >> | + <:ctyp< $t$; $ <:ctyp<>> $ >> | + <:ctyp< $ <:ctyp<>> $; $t$ >> | + <:ctyp< $ <:ctyp<>> $, $t$ >> | + <:ctyp< $t$, $ <:ctyp<>> $ >> | + <:ctyp< $t$ & $ <:ctyp<>> $ >> | + <:ctyp< $ <:ctyp<>> $ & $t$ >> | + <:ctyp< $ <:ctyp<>> $ * $t$ >> | + <:ctyp< $t$ * $ <:ctyp<>> $ >> -> t + | t -> t ]; + + method sig_item sg = + match super#sig_item sg with + [ <:sig_item< $ <:sig_item<>> $; $sg$ >> | + <:sig_item< $sg$; $ <:sig_item<>> $ >> -> sg + | <:sig_item@loc< type $ <:ctyp<>> $ >> -> <:sig_item@loc<>> + | sg -> sg ]; + + method str_item st = + match super#str_item st with + [ <:str_item< $ <:str_item<>> $; $st$ >> | + <:str_item< $st$; $ <:str_item<>> $ >> -> st + | <:str_item@loc< type $ <:ctyp<>> $ >> -> <:str_item@loc<>> + | <:str_item@loc< value $rec:_$ $ <:binding<>> $ >> -> <:str_item@loc<>> + | st -> st ]; + + method module_type mt = + match super#module_type mt with + [ <:module_type< $mt$ with $ <:with_constr<>> $ >> -> mt + | mt -> mt ]; + + method class_expr ce = + match super#class_expr ce with + [ <:class_expr< $ <:class_expr<>> $ and $ce$ >> | + <:class_expr< $ce$ and $ <:class_expr<>> $ >> -> ce + | ce -> ce ]; + + method class_type ct = + match super#class_type ct with + [ <:class_type< $ <:class_type<>> $ and $ct$ >> | + <:class_type< $ct$ and $ <:class_type<>> $ >> -> ct + | ct -> ct ]; + + method class_sig_item csg = + match super#class_sig_item csg with + [ <:class_sig_item< $ <:class_sig_item<>> $; $csg$ >> | + <:class_sig_item< $csg$; $ <:class_sig_item<>> $ >> -> csg + | csg -> csg ]; + + method class_str_item cst = + match super#class_str_item cst with + [ <:class_str_item< $ <:class_str_item<>> $; $cst$ >> | + <:class_str_item< $cst$; $ <:class_str_item<>> $ >> -> cst + | cst -> cst ]; end; diff --git a/camlp4/Camlp4/Struct/Grammar/Failed.ml b/camlp4/Camlp4/Struct/Grammar/Failed.ml index 907d3378..ee3eff5a 100644 --- a/camlp4/Camlp4/Struct/Grammar/Failed.ml +++ b/camlp4/Camlp4/Struct/Grammar/Failed.ml @@ -109,8 +109,8 @@ value tree_failed entry prev_symb_result prev_symb tree = in do { if entry.egram.error_verbose.val then do { - let tree = Search.tree_in_entry prev_symb tree entry.edesc in - let ppf = err_formatter in + let tree = Search.tree_in_entry prev_symb tree entry.edesc; + let ppf = err_formatter; fprintf ppf "@[@,"; fprintf ppf "----------------------------------@,"; fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename; diff --git a/camlp4/Camlp4/Struct/Grammar/Insert.ml b/camlp4/Camlp4/Struct/Grammar/Insert.ml index 62d8a972..fc506a70 100644 --- a/camlp4/Camlp4/Struct/Grammar/Insert.ml +++ b/camlp4/Camlp4/Struct/Grammar/Insert.ml @@ -299,7 +299,7 @@ module Make (Structure : Structure.S) = struct let symbols = List.map (change_to_self entry) symbols in do { List.iter (check_gram entry) symbols; - let (e1, symbols) = get_initial symbols in + let (e1, symbols) = get_initial symbols; insert_tokens entry.egram symbols; insert_level entry e1 symbols action lev }) diff --git a/camlp4/Camlp4/Struct/Lexer.mll b/camlp4/Camlp4/Struct/Lexer.mll index 3844ff56..dfc9a719 100644 --- a/camlp4/Camlp4/Struct/Lexer.mll +++ b/camlp4/Camlp4/Struct/Lexer.mll @@ -18,7 +18,7 @@ *) -(* $Id: Lexer.mll,v 1.6.4.7 2007/05/10 22:43:18 pouillar Exp $ *) +(* $Id: Lexer.mll,v 1.6.4.11 2007/11/27 14:38:03 ertai Exp $ *) (* The lexer definition *) @@ -201,6 +201,8 @@ module Make (Token : Sig.Camlp4Token) let not_star_symbolchar = ['$' '!' '%' '&' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~' '\\'] let symbolchar = '*' | not_star_symbolchar + let quotchar = + ['!' '%' '&' '+' '-' '.' '/' ':' '=' '?' '@' '^' '|' '~' '\\' '*'] let hexa_char = ['0'-'9' 'A'-'F' 'a'-'f'] let decimal_literal = ['0'-'9'] ['0'-'9' '_']* @@ -220,17 +222,17 @@ module Make (Token : Sig.Camlp4Token) (* Delimitors are extended (from 3.09) in a conservative way *) (* These chars that can't start an expression or a pattern: *) - let safe_delimchars = ['%' '&' '.' '/' '@' '^'] + let safe_delimchars = ['%' '&' '/' '@' '^'] (* These symbols are unsafe since "[<", "[|", etc. exsist. *) - let delimchars = safe_delimchars | ['|' '<' '>' ':' '='] + let delimchars = safe_delimchars | ['|' '<' '>' ':' '=' '.'] let left_delims = ['(' '[' '{'] let right_delims = [')' ']' '}'] let left_delimitor = (* At least a safe_delimchars *) - left_delims (delimchars|left_delims)* safe_delimchars (delimchars|left_delims)* + left_delims delimchars* safe_delimchars (delimchars|left_delims)* (* A '(' or a new super '(' without "(<" *) | '(' (['|' ':'] delimchars*)? @@ -296,10 +298,11 @@ module Make (Token : Sig.Camlp4Token) | "*)" { warn Comment_not_end (Loc.of_lexbuf lexbuf) ; move_start_p (-1) c; SYMBOL "*" } - | "<<" + | "<<" (quotchar* as beginning) { if quotations c - then mk_quotation quotation c "" "" 2 - else parse (symbolchar_star "<<") c } + then (move_start_p (-String.length beginning); + mk_quotation quotation c "" "" 2) + else parse (symbolchar_star ("<<" ^ beginning)) c } | "<<>>" { if quotations c then QUOTATION { q_name = ""; q_loc = ""; q_shift = 2; q_contents = "" } @@ -395,15 +398,15 @@ module Make (Token : Sig.Camlp4Token) and maybe_quotation_at c = parse | (ident as loc) '<' - { mk_quotation quotation c "" loc (3 + String.length loc) } + { mk_quotation quotation c "" loc (1 + String.length loc) } | symbolchar* as tok { SYMBOL("<@" ^ tok) } and maybe_quotation_colon c = parse | (ident as name) '<' - { mk_quotation quotation c name "" (3 + String.length name) } + { mk_quotation quotation c name "" (1 + String.length name) } | (ident as name) '@' (locname as loc) '<' { mk_quotation quotation c name loc - (4 + String.length loc + String.length name) } + (2 + String.length loc + String.length name) } | symbolchar* as tok { SYMBOL("<:" ^ tok) } and quotation c = parse diff --git a/camlp4/Camlp4/Struct/Loc.ml b/camlp4/Camlp4/Struct/Loc.ml index 49fa71e0..48974d82 100644 --- a/camlp4/Camlp4/Struct/Loc.ml +++ b/camlp4/Camlp4/Struct/Loc.ml @@ -173,18 +173,17 @@ value of_lexing_position pos = value to_ocaml_location x = debug loc "to_ocaml_location: %a@\n" dump x in - { Location. + { Camlp4_import.Location. loc_start = pos_to_lexing_position x.start x.file_name; loc_end = pos_to_lexing_position x.stop x.file_name; loc_ghost = x.ghost }; -value of_ocaml_location x = - let (a, b) = (x.Location.loc_start, x.Location.loc_end) in +value of_ocaml_location { Camlp4_import.Location.loc_start = a; loc_end = b; loc_ghost = g } = let res = { file_name = better_file_name a.Lexing.pos_fname b.Lexing.pos_fname; start = pos_of_lexing_position a; stop = pos_of_lexing_position b; - ghost = x.Location.loc_ghost } in + ghost = g } in debug loc "of_ocaml_location: %a@\n" dump res in res; diff --git a/camlp4/Camlp4/Struct/Quotation.ml b/camlp4/Camlp4/Struct/Quotation.ml index d150b951..349c6850 100644 --- a/camlp4/Camlp4/Struct/Quotation.ml +++ b/camlp4/Camlp4/Struct/Quotation.ml @@ -18,9 +18,9 @@ * - Nicolas Pouillard: refactoring *) -(* $Id: Quotation.ml,v 1.4.4.1 2007/03/29 14:31:04 pouillar Exp $ *) +(* $Id: Quotation.ml,v 1.4.4.3 2007/06/23 16:00:09 ertai Exp $ *) -module Make (Ast : Sig.Ast) +module Make (Ast : Sig.Camlp4Ast) : Sig.Quotation with module Ast = Ast = struct module Ast = Ast; @@ -74,15 +74,20 @@ module Make (Ast : Sig.Ast) let pp x = fprintf ppf "@?@[<2>While %s %S in a position of %S:" x name position in let () = match ctx with - [ Finding -> do { + [ Finding -> begin pp "finding quotation"; - fprintf ppf "@ @[Available quotations are:@\n"; - List.iter begin fun ((s,t),_) -> - fprintf ppf "@[<2>%s@ (in@ a@ position@ of %a)@]@ " - s Exp_key.print_tag t - end expanders_table.val; - fprintf ppf "@]" - } + if expanders_table.val = [] then + fprintf ppf "@ There is no quotation expander available." + else + begin + fprintf ppf "@ @[Available quotation expanders are:@\n"; + List.iter begin fun ((s,t),_) -> + fprintf ppf "@[<2>%s@ (in@ a@ position@ of %a)@]@ " + s Exp_key.print_tag t + end expanders_table.val; + fprintf ppf "@]" + end + end | Expanding -> pp "expanding quotation" | Locating -> pp "parsing" | ParsingResult loc str -> @@ -92,13 +97,13 @@ module Make (Ast : Sig.Ast) let () = fprintf ppf " dumping result...\n" in try let oc = open_out_bin dump_file in - do { + begin output_string oc str; output_string oc "\n"; flush oc; close_out oc; fprintf ppf "%a:" Loc.print (Loc.set_file_name dump_file loc); - } + end with _ -> fprintf ppf "Error while dumping result in file %S; dump aborted" diff --git a/camlp4/Camlp4/Struct/Token.ml b/camlp4/Camlp4/Struct/Token.ml index 4dbdacac..384bba91 100644 --- a/camlp4/Camlp4/Struct/Token.ml +++ b/camlp4/Camlp4/Struct/Token.ml @@ -199,6 +199,9 @@ module Eval = struct [ [: `'\010' :] -> () | [: :] -> () ]; + value chr c = + if c < 0 || c > 255 then failwith "invalid char token" else Char.chr c; + value rec backslash = parser [ [: `'\010' :] -> '\010' | [: `'\013' :] -> '\013' @@ -211,10 +214,10 @@ module Eval = struct | [: `''' :] -> ''' | [: `' ' :] -> ' ' | [: `('0'..'9' as c1); `('0'..'9' as c2); `('0'..'9' as c3) :] -> - Char.chr (100 * (valch c1) + 10 * (valch c2) + (valch c3)) + chr (100 * (valch c1) + 10 * (valch c2) + (valch c3)) | [: `'x'; `('0'..'9' | 'a'..'f' | 'A'..'F' as c1) ; `('0'..'9' | 'a'..'f' | 'A'..'F' as c2) :] -> - Char.chr (16 * (valch_hex c1) + (valch_hex c2)) ]; + chr (16 * (valch_hex c1) + (valch_hex c2)) ]; value rec backslash_in_string strict store = parser [ [: `'\010'; s :] -> skip_indent s diff --git a/camlp4/Camlp4Bin.ml b/camlp4/Camlp4Bin.ml index a31c62ad..4ce8720d 100644 --- a/camlp4/Camlp4Bin.ml +++ b/camlp4/Camlp4Bin.ml @@ -18,7 +18,7 @@ * - Nicolas Pouillard: refactoring *) -(* $Id: Camlp4Bin.ml,v 1.14.2.3 2007/03/30 15:50:12 pouillar Exp $ *) +(* $Id: Camlp4Bin.ml,v 1.14.2.6 2007/06/23 16:00:09 ertai Exp $ *) open Camlp4; open PreCast.Syntax; @@ -80,7 +80,8 @@ value rewrite_and_load n x = | ("Filters"|"", "lift" | "camlp4astlifter.cmo") -> load ["Camlp4AstLifter"] | ("Filters"|"", "exn" | "camlp4exceptiontracer.cmo") -> load ["Camlp4ExceptionTracer"] | ("Filters"|"", "prof" | "camlp4profiler.cmo") -> load ["Camlp4Profiler"] - | ("Filters"|"", "map" | "camlp4mapgenerator.cmo") -> load ["Camlp4MapGenerator"] + (* map is now an alias of fold since fold handles map too *) + | ("Filters"|"", "map" | "camlp4mapgenerator.cmo") -> load ["Camlp4FoldGenerator"] | ("Filters"|"", "fold" | "camlp4foldgenerator.cmo") -> load ["Camlp4FoldGenerator"] | ("Filters"|"", "meta" | "camlp4metagenerator.cmo") -> load ["Camlp4MetaGenerator"] | ("Filters"|"", "trash" | "camlp4trashremover.cmo") -> load ["Camlp4TrashRemover"] @@ -118,13 +119,12 @@ value rec parse_file dyn_loader name pa getdir = let loc = Loc.mk name in do { current_warning.val := print_warning; - let ic = if name = "-" then stdin else open_in_bin name in - let cs = Stream.of_channel ic in - let clear () = if name = "-" then () else close_in ic in + let ic = if name = "-" then stdin else open_in_bin name; + let cs = Stream.of_channel ic; + let clear () = if name = "-" then () else close_in ic; let phr = try pa ?directive_handler loc cs - with x -> do { clear (); raise x } - in + with x -> do { clear (); raise x }; clear (); phr }; @@ -217,12 +217,14 @@ value input_file x = match x with [ Intf file_name -> task (process_intf dyn_loader) file_name | Impl file_name -> task (process_impl dyn_loader) file_name - | Str s -> do { - let (f, o) = Filename.open_temp_file "from_string" ".ml"; - output_string o s; - close_out o; - task (process_impl dyn_loader) f; - } + | Str s -> + begin + let (f, o) = Filename.open_temp_file "from_string" ".ml"; + output_string o s; + close_out o; + task (process_impl dyn_loader) f; + at_exit (fun () -> Sys.remove f); + end | ModuleImpl file_name -> rewrite_and_load "" file_name | IncludeDir dir -> DynLoader.include_dir dyn_loader dir ]; rcall_callback.val (); diff --git a/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml b/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml index 6819b9d1..af2dc83e 100644 --- a/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml +++ b/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml @@ -5,7 +5,7 @@ (* *) (* INRIA Rocquencourt *) (* *) -(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* Copyright 2006,2007 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 LICENSE at the top of the Objective *) @@ -22,7 +22,7 @@ open Camlp4; module Id = struct value name = "Camlp4FoldGenerator"; - value version = "$Id: Camlp4FoldGenerator.ml,v 1.1.4.4 2007/05/01 07:24:06 pouillar Exp $"; + value version = "$Id: Camlp4FoldGenerator.ml,v 1.1.4.10 2007/07/25 13:06:27 ertai Exp $"; end; module Make (AstFilters : Camlp4.Sig.AstFilters) = struct @@ -32,9 +32,28 @@ module Make (AstFilters : Camlp4.Sig.AstFilters) = struct value _loc = Loc.ghost; - value xi i = "_x" ^ string_of_int i; + value sf = Printf.sprintf; + + value xik i k = + let i = + if i < 0 then assert False + else if i = 0 then "" + else sf "_i%d" i + in + let k = + if k < 1 then assert False + else if k = 1 then "" + else sf "_k%d" k + in + sf "_x%s%s" i k; + value exik i k = <:expr< $lid:xik i k$ >>; + value pxik i k = <:patt< $lid:xik i k$ >>; + value elidk y k = <:expr< $lid:sf "%s_%d" y k$ >>; + value plidk y k = <:patt< $lid:sf "%s_%d" y k$ >>; value xs s = "_x_" ^ s; + value xsk = sf "_x_%s_%d"; + value exsk s k = <:expr< $lid:xsk s k$>>; value rec apply_expr accu = fun @@ -57,12 +76,7 @@ module Make (AstFilters : Camlp4.Sig.AstFilters) = struct let _loc = Ast.loc_of_ctyp x in apply_ctyp <:ctyp< $accu$ $x$ >> xs ]; - value list_mapi f = - let rec self i = - fun - [ [] -> [] - | [ x :: xs ] -> [ f i x :: self (succ i) xs ] ] - in self 0; + value opt_map f = fun [ Some x -> Some (f x) | None -> None ]; value list_init f n = let rec self m = @@ -70,273 +84,525 @@ module Make (AstFilters : Camlp4.Sig.AstFilters) = struct else [f m :: self (succ m)] in self 0; - (* Yes this is a poor fresh function *) - value fresh = - let count = ref 0 in - fun basename -> - let res = basename ^ (string_of_int count.val) - in do { incr count; res }; - - value mk_tuple self t = - let tl = Ast.list_of_ctyp t [] in - let n = List.length tl in - let exi i = <:expr< $lid:xi i$ >> in - let pxi i = <:patt< $lid:xi i$ >> in - let (e, _) = - List.fold_left - (fun (acc, i) t -> (self ?obj:(Some acc) (Some (exi i)) t, succ i)) - (<:expr>, 0) tl in - <:expr< fun ($tup:Ast.paCom_of_list (list_init pxi n)$) -> $e$ >>; - - value builtins = - <:class_str_item< - method string (_ : string) : 'self_type = o; - method int (_ : int) : 'self_type = o; - method float (_ : float) : 'self_type = o; - method bool (_ : bool) : 'self_type = o; - method list : ! 'a . ('self_type -> 'a -> 'self_type) -> list 'a -> 'self_type = - fun f -> List.fold_left f o; - method option : ! 'a . ('self_type -> 'a -> 'self_type) -> option 'a -> 'self_type = - fun f -> fun [ None -> o | Some x -> f o x ]; - method array : ! 'a . ('self_type -> 'a -> 'self_type) -> array 'a -> 'self_type = - fun f -> Array.fold_left f o; - method ref : ! 'a . ('self_type -> 'a -> 'self_type) -> ref 'a -> 'self_type = - fun f { val = x } -> f o x; - >>; - value rec lid_of_ident sep = fun [ <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> s | <:ident< $i1$.$i2$ >> -> lid_of_ident sep i1 ^ sep ^ lid_of_ident sep i2 | _ -> assert False ]; - type type_decl = (string * Ast.ident * list Ast.ctyp * Ast.ctyp); - - value (unknown_type, fold_unknown_types) = - let set = ref StringMap.empty in - let add id1 id2 ty = set.val := StringMap.add id1 (id1, id2, [], ty) set.val - and fold f = StringMap.fold f set.val in (add, fold); - - value rec expr_of_ty ?obj x ty = - let rec self ?(obj = <:expr>) ox = - fun - [ <:ctyp< $lid:id$ >> -> + type type_decl = (string * Ast.ident * list Ast.ctyp * Ast.ctyp * bool); + + value builtin_types = + let tyMap = StringMap.empty in + let tyMap = + let abstr = ["string"; "int"; "float"; "int32"; "int64"; "nativeint"; "char"] in + List.fold_right + (fun name -> StringMap.add name (name, <:ident< $lid:name$ >>, [], <:ctyp<>>, False)) + abstr tyMap + in + let tyMap = + let concr = + [("bool", <:ident>, [], <:ctyp< [ False | True ] >>, False); + ("list", <:ident>, [ <:ctyp< 'a >> ], <:ctyp< [ $uid:"[]"$ | $uid:"::"$ of 'a and list 'a ] >>, False); + ("option", <:ident