diff -Nru ocaml-4.01.0/asmcomp/amd64/arch.ml ocaml-4.02.3/asmcomp/amd64/arch.ml --- ocaml-4.01.0/asmcomp/amd64/arch.ml 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/asmcomp/amd64/arch.ml 2014-05-21 17:08:11.000000000 +0200 @@ -33,8 +33,9 @@ type specific_operation = Ilea of addressing_mode (* "lea" gives scaled adds *) - | Istore_int of nativeint * addressing_mode (* Store an integer constant *) - | Istore_symbol of string * addressing_mode (* Store a symbol *) + | Istore_int of nativeint * addressing_mode * bool + (* Store an integer constant *) + | Istore_symbol of string * addressing_mode * bool (* Store a symbol *) | Ioffset_loc of int * addressing_mode (* Add a constant to a location *) | Ifloatarithmem of float_operation * addressing_mode (* Float arith operation with memory *) @@ -101,10 +102,14 @@ let print_specific_operation printreg op ppf arg = match op with | Ilea addr -> print_addressing printreg addr ppf arg - | Istore_int(n, addr) -> - fprintf ppf "[%a] := %nd" (print_addressing printreg addr) arg n - | Istore_symbol(lbl, addr) -> - fprintf ppf "[%a] := \"%s\"" (print_addressing printreg addr) arg lbl + | Istore_int(n, addr, is_assign) -> + fprintf ppf "[%a] := %nd %s" + (print_addressing printreg addr) arg n + (if is_assign then "(assign)" else "(init)") + | Istore_symbol(lbl, addr, is_assign) -> + fprintf ppf "[%a] := \"%s\" %s" + (print_addressing printreg addr) arg lbl + (if is_assign then "(assign)" else "(init)") | Ioffset_loc(n, addr) -> fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n | Isqrtf -> diff -Nru ocaml-4.01.0/asmcomp/amd64/CSE.ml ocaml-4.02.3/asmcomp/amd64/CSE.ml --- ocaml-4.01.0/asmcomp/amd64/CSE.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/amd64/CSE.ml 2014-07-16 11:24:37.000000000 +0200 @@ -0,0 +1,38 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for the AMD64 *) + +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific spec -> + begin match spec with + | Ilea _ -> Op_pure + | Istore_int(_, _, is_asg) | Istore_symbol(_, _, is_asg) -> Op_store is_asg + | Ioffset_loc(_, _) -> Op_store true + | Ifloatarithmem _ | Ifloatsqrtf _ -> Op_load + | Ibswap _ | Isqrtf -> super#class_of_operation op + end + | _ -> super#class_of_operation op + +end + +let fundecl f = + (new cse)#fundecl f diff -Nru ocaml-4.01.0/asmcomp/amd64/emit.mlp ocaml-4.02.3/asmcomp/amd64/emit.mlp --- ocaml-4.01.0/asmcomp/amd64/emit.mlp 2013-06-03 20:03:59.000000000 +0200 +++ ocaml-4.02.3/asmcomp/amd64/emit.mlp 2015-06-10 11:27:36.000000000 +0200 @@ -20,8 +20,15 @@ open Linearize open Emitaux +(* [Branch_relaxation] is not used in this file, but is required by + emit.mlp files for certain other targets; the reference here ensures + that when releases are being prepared the .depend files are correct + for all targets. *) +open! Branch_relaxation + let macosx = (Config.system = "macosx") let mingw64 = (Config.system = "mingw64") +let cygwin = (Config.system = "cygwin") let fp = Config.with_frame_pointers @@ -61,17 +68,17 @@ Emitaux.emit_symbol '$' s let emit_call s = - if !Clflags.dlcode && not macosx && not mingw64 + if !Clflags.dlcode && not macosx && not mingw64 && not cygwin then `call {emit_symbol s}@PLT` else `call {emit_symbol s}` let emit_jump s = - if !Clflags.dlcode && not macosx && not mingw64 + if !Clflags.dlcode && not macosx && not mingw64 && not cygwin then `jmp {emit_symbol s}@PLT` else `jmp {emit_symbol s}` let load_symbol_addr s = - if !Clflags.dlcode && not mingw64 + if !Clflags.dlcode && not mingw64 && not cygwin then `movq {emit_symbol s}@GOTPCREL(%rip)` else if !pic_code then `leaq {emit_symbol s}(%rip)` @@ -334,15 +341,16 @@ (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = + let repr = Int64.bits_of_float cst in try - List.assoc cst !float_constants + List.assoc repr !float_constants with Not_found -> let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; + float_constants := (repr, lbl) :: !float_constants; lbl let emit_float_constant (cst, lbl) = @@ -372,7 +380,7 @@ | _ -> ` movq {emit_reg src}, {emit_reg dst}\n` end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if n = 0n then begin match i.res.(0).loc with Reg n -> ` xorq {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` @@ -381,12 +389,12 @@ ` movq ${emit_nativeint n}, {emit_reg i.res.(0)}\n` else ` movabsq ${emit_nativeint n}, {emit_reg i.res.(0)}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> - let lbl = add_float_constant s in + let lbl = add_float_constant f in ` movsd {emit_label lbl}(%rip), {emit_reg i.res.(0)}\n` end | Lop(Iconst_symbol s) -> @@ -447,7 +455,7 @@ | Double | Double_u -> ` movsd {emit_addressing addr i.arg 0}, {emit_reg dest}\n` end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> begin match chunk with | Word -> ` movq {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` @@ -514,6 +522,8 @@ | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %rcx *) ` {emit_string(instr_for_intop op)} %cl, {emit_reg i.res.(0)}\n` + | Lop(Iintop Imulh) -> + ` imulq {emit_reg i.arg.(1)}\n` | Lop(Iintop op) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` @@ -523,22 +533,6 @@ ` incq {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> ` decq {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Idiv, n)) -> - (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) - let l = Misc.log2 n in - ` movq {emit_reg i.arg.(0)}, %rax\n`; - ` addq ${emit_int(n-1)}, {emit_reg i.arg.(0)}\n`; - ` testq %rax, %rax\n`; - ` cmovns %rax, {emit_reg i.arg.(0)}\n`; - ` sarq ${emit_int l}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Imod, n)) -> - (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) - ` movq {emit_reg i.arg.(0)}, %rax\n`; - ` testq %rax, %rax\n`; - ` leaq {emit_int(n-1)}(%rax), %rax\n`; - ` cmovns {emit_reg i.arg.(0)}, %rax\n`; - ` andq ${emit_int (-n)}, %rax\n`; - ` subq %rax, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(op, n)) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} ${emit_int n}, {emit_reg i.res.(0)}\n` @@ -554,9 +548,9 @@ ` cvttsd2siq {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` | Lop(Ispecific(Ilea addr)) -> ` leaq {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> + | Lop(Ispecific(Istore_int(n, addr, _))) -> ` movq ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> assert (not !pic_code && not !Clflags.dlcode); ` movq ${emit_symbol s}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> @@ -650,7 +644,7 @@ ` jmp *{emit_reg tmp1}\n`; if macosx then ` .const\n` - else if mingw64 then + else if mingw64 || cygwin then ` .section .rdata,\"dr\"\n` else ` .section .rodata\n`; @@ -674,11 +668,16 @@ ` addq $8, %rsp\n`; cfi_adjust_cfa_offset (-8); stack_offset := !stack_offset - 16 - | Lraise -> - if !Clflags.debug then begin + | Lraise k -> + begin match !Clflags.debug, k with + | true, Lambda.Raise_regular -> ` {emit_call "caml_raise_exn"}\n`; record_frame Reg.Set.empty i.dbg - end else begin + | true, Lambda.Raise_reraise -> + ` {emit_call "caml_reraise_exn"}\n`; + record_frame Reg.Set.empty i.dbg + | false, _ + | true, Lambda.Raise_notrace -> ` movq %r14, %rsp\n`; ` popq %r14\n`; ` ret\n` @@ -772,9 +771,9 @@ | Cint n -> ` .quad {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".long" f + emit_float32_directive ".long" (Int32.bits_of_float f) | Cdouble f -> - emit_float64_directive ".quad" f + emit_float64_directive ".quad" (Int64.bits_of_float f) | Csymbol_address s -> ` .quad {emit_symbol s}\n` | Clabel_address lbl -> @@ -799,7 +798,7 @@ (* from amd64.S; could emit these constants on demand *) if macosx then ` .literal16\n` - else if mingw64 then + else if mingw64 || cygwin then ` .section .rdata,\"dr\"\n` else ` .section .rodata.cst8,\"a\",@progbits\n`; @@ -822,7 +821,7 @@ if !float_constants <> [] then begin if macosx then ` .literal8\n` - else if mingw64 then + else if mingw64 || cygwin then ` .section .rdata,\"dr\"\n` else ` .section .rodata.cst8,\"a\",@progbits\n`; diff -Nru ocaml-4.01.0/asmcomp/amd64/emit_nt.mlp ocaml-4.02.3/asmcomp/amd64/emit_nt.mlp --- ocaml-4.01.0/asmcomp/amd64/emit_nt.mlp 2013-06-03 20:03:59.000000000 +0200 +++ ocaml-4.02.3/asmcomp/amd64/emit_nt.mlp 2014-04-29 11:58:51.000000000 +0200 @@ -15,7 +15,6 @@ module StringSet = Set.Make(struct type t = string let compare (x:t) y = compare x y end) -open Misc open Cmm open Arch open Proc @@ -24,6 +23,8 @@ open Linearize open Emitaux +let rdx = phys_reg 4 + (* Tradeoff between code size and code speed *) let fastcode_flag = ref true @@ -52,9 +53,10 @@ else !stack_offset + (num_stack_slots.(0) + n) * 8 | Outgoing n -> n -(* Output a 32 bit integer in hex *) +(* Output a 32 or 64 bit integer in hex *) let emit_int32 n = emit_printf "0%lxh" n +let emit_int64 n = emit_printf "0%Lxh" n (* Symbols *) @@ -320,36 +322,24 @@ (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = + let repr = Int64.bits_of_float cst in try - List.assoc cst !float_constants + List.assoc repr !float_constants with Not_found -> let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; + float_constants := (repr, lbl) :: !float_constants; lbl -let emit_float s = - (* MASM doesn't like floating-point constants such as 2e9. - Turn them into 2.0e9. *) - let pos_e = ref (-1) and pos_dot = ref (-1) in - for i = 0 to String.length s - 1 do - match s.[i] with - 'e'|'E' -> pos_e := i - | '.' -> pos_dot := i - | _ -> () - done; - if !pos_dot < 0 && !pos_e >= 0 then begin - emit_string (String.sub s 0 !pos_e); - emit_string ".0"; - emit_string (String.sub s !pos_e (String.length s - !pos_e)) - end else - emit_string s - let emit_float_constant (cst, lbl) = - `{emit_label lbl} REAL8 {emit_float cst}\n` + `{emit_label lbl} QWORD {emit_int64 cst}\n` + +let emit_movabs reg n = + (* force ml64 to use mov reg, imm64 instruction *) + ` mov {emit_reg reg}, {emit_printf "0%nxH" n}\n` (* Output the assembly code for an instruction *) @@ -372,7 +362,7 @@ | _ -> ` mov {emit_reg dst}, {emit_reg src}\n` end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if n = 0n then begin match i.res.(0).loc with Reg n -> ` xor {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` @@ -383,14 +373,13 @@ (* work around bug in ml64 *) ` mov {emit_reg32 i.res.(0)}, {emit_nativeint n}\n` else - (* force ml64 to use mov reg, imm64 instruction *) - ` mov {emit_reg i.res.(0)}, {emit_printf "0%nxH" n}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with + emit_movabs i.res.(0) n + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> - let lbl = add_float_constant s in + let lbl = add_float_constant f in ` movsd {emit_reg i.res.(0)}, {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> @@ -454,7 +443,7 @@ | Double | Double_u -> ` movsd {emit_reg dest}, REAL8 PTR {emit_addressing addr i.arg 0}\n` end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> begin match chunk with | Word -> ` mov QWORD PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` @@ -517,6 +506,8 @@ | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %rcx *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, cl\n` + | Lop(Iintop Imulh) -> + ` imul {emit_reg i.arg.(1)}\n` | Lop(Iintop op) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n` @@ -526,22 +517,6 @@ ` inc {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> ` dec {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Idiv, n)) -> - (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) - let l = Misc.log2 n in - ` mov rax, {emit_reg i.arg.(0)}\n`; - ` add {emit_reg i.arg.(0)}, {emit_int(n-1)}\n`; - ` test rax, rax\n`; - ` cmovns {emit_reg i.arg.(0)}, rax\n`; - ` sar {emit_reg i.res.(0)}, {emit_int l}\n` - | Lop(Iintop_imm(Imod, n)) -> - (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) - ` mov rax, {emit_reg i.arg.(0)}\n`; - ` test rax, rax\n`; - ` lea rax, {emit_int(n-1)}[rax]\n`; - ` cmovns rax, {emit_reg i.arg.(0)}\n`; - ` and rax, {emit_int (-n)}\n`; - ` sub {emit_reg i.res.(0)}, rax\n` | Lop(Iintop_imm(op, n)) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_int n}\n` @@ -557,9 +532,9 @@ ` cvttsd2si {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` | Lop(Ispecific(Ilea addr)) -> ` lea {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> + | Lop(Ispecific(Istore_int(n, addr, _))) -> ` mov QWORD PTR {emit_addressing addr i.arg 0}, {emit_nativeint n}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> assert (not !pic_code); add_used_symbol s; ` mov QWORD PTR {emit_addressing addr i.arg 0}, OFFSET {emit_symbol s}\n` @@ -666,11 +641,16 @@ ` pop r14\n`; ` add rsp, 8\n`; stack_offset := !stack_offset - 16 - | Lraise -> - if !Clflags.debug then begin + | Lraise k -> + begin match !Clflags.debug, k with + | true, Lambda.Raise_regular -> ` call caml_raise_exn\n`; record_frame Reg.Set.empty i.dbg - end else begin + | true, Lambda.Raise_reraise -> + ` call caml_reraise_exn\n`; + record_frame Reg.Set.empty i.dbg + | false, _ + | true, Lambda.Raise_notrace -> ` mov rsp, r14\n`; ` pop r14\n`; ` ret\n` @@ -726,9 +706,9 @@ | Cint n -> ` QWORD {emit_nativeint n}\n` | Csingle f -> - ` REAL4 {emit_float f}\n` + ` DWORD {emit_int32 (Int32.bits_of_float f)}\n` | Cdouble f -> - ` REAL8 {emit_float f}\n` + ` QWORD {emit_int64 (Int64.bits_of_float f)}\n` | Csymbol_address s -> add_used_symbol s; ` QWORD {emit_symbol s}\n` @@ -762,6 +742,7 @@ ` EXTRN caml_alloc3: NEAR\n`; ` EXTRN caml_ml_array_bound_error: NEAR\n`; ` EXTRN caml_raise_exn: NEAR\n`; + ` EXTRN caml_reraise_exn: NEAR\n`; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in add_def_symbol lbl_begin; ` .DATA\n`; diff -Nru ocaml-4.01.0/asmcomp/amd64/proc.ml ocaml-4.02.3/asmcomp/amd64/proc.ml --- ocaml-4.01.0/asmcomp/amd64/proc.ml 2013-06-03 20:03:59.000000000 +0200 +++ ocaml-4.02.3/asmcomp/amd64/proc.ml 2014-08-18 20:26:49.000000000 +0200 @@ -24,7 +24,7 @@ let win64 = match Config.system with - | "win64" | "mingw64" -> true + | "win64" | "mingw64" | "cygwin" -> true | _ -> false (* Which asm conventions to use *) @@ -117,12 +117,12 @@ (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 13 Reg.dummy in + let v = Array.make 13 Reg.dummy in for i = 0 to 12 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 16 Reg.dummy in + let v = Array.make 16 Reg.dummy in for i = 0 to 15 do v.(i) <- Reg.at_location Float (Reg (100 + i)) done; v @@ -149,7 +149,7 @@ 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 loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in @@ -210,7 +210,7 @@ [| 100 (*xmm0*); 101 (*xmm1*); 102 (*xmm2*); 103 (*xmm3*) |] let win64_loc_external_arguments arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let reg = ref 0 and ofs = ref 32 in for i = 0 to Array.length arg - 1 do @@ -239,6 +239,10 @@ let loc_exn_bucket = rax +(* Volatile registers: none *) + +let regs_are_volatile rs = false + (* Registers destroyed by operations *) let destroyed_at_c_call = @@ -257,9 +261,10 @@ let destroyed_at_oper = function Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs | Iop(Iextcall(_, false)) -> destroyed_at_c_call - | Iop(Iintop(Idiv | Imod)) -> [| rax; rdx |] - | Iop(Istore(Single, _)) -> [| rxmm15 |] - | Iop(Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _)) + | Iop(Iintop(Idiv | Imod)) | Iop(Iintop_imm((Idiv | Imod), _)) + -> [| rax; rdx |] + | Iop(Istore(Single, _, _)) -> [| rxmm15 |] + | Iop(Ialloc _ | Iintop(Imulh | Icomp _) | Iintop_imm((Icomp _), _)) -> [| rax |] | Iswitch(_, _) -> [| rax; rdx |] | _ -> @@ -285,14 +290,25 @@ if fp then [| 7; 10 |] else [| 8; 10 |] else if fp then [| 3; 0 |] else [| 4; 0 |] - | Iintop(Idiv | Imod) -> + | Iintop(Idiv | Imod) | Iintop_imm((Idiv | Imod), _) -> if fp then [| 10; 16 |] else [| 11; 16 |] - | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _) -> + | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Icomp _), _) -> if fp then [| 11; 16 |] else [| 12; 16 |] - | Istore(Single, _) -> + | Istore(Single, _, _) -> if fp then [| 12; 15 |] else [| 13; 15 |] | _ -> if fp then [| 12; 16 |] else [| 13; 16 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Ispecific(Ilea _) -> true + | Ispecific _ -> false + | _ -> true + (* Layout of the stack frame *) let num_stack_slots = [| 0; 0 |] diff -Nru ocaml-4.01.0/asmcomp/amd64/reload.ml ocaml-4.02.3/asmcomp/amd64/reload.ml --- ocaml-4.01.0/asmcomp/amd64/reload.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/amd64/reload.ml 2014-03-17 15:34:00.000000000 +0100 @@ -22,7 +22,8 @@ Operation Res Arg1 Arg2 Imove R S or S R - Iconst_int S if 32-bit signed, R otherwise + Iconst_int ] S if 32-bit signed, R otherwise + Iconst_blockheader ] Iconst_float R Iconst_symbol (not PIC) S Iconst_symbol (PIC) R @@ -32,7 +33,8 @@ Istore R R Iintop(Icomp) R R S or S S R - Iintop(Imul|Idiv|mod) R R S + Iintop(Imul|Idiv|Imod) R R S + Iintop(Imulh) R R S Iintop(shift) S S R Iintop(others) R R S or S S R @@ -71,10 +73,10 @@ (* This add will be turned into a lea; args and results must be in registers *) super#reload_operation op arg res - | Iintop(Idiv | Imod | Ilsl | Ilsr | Iasr) + | Iintop(Imulh | Idiv | Imod | Ilsl | Ilsr | Iasr) | Iintop_imm(_, _) -> (* The argument(s) and results can be either in register or on stack *) - (* Note: Idiv, Imod: arg(0) and res(0) already forced in regs + (* Note: Imulh, Idiv, Imod: arg(0) and res(0) already forced in regs Ilsl, Ilsr, Iasr: arg(1) already forced in regs *) (arg, res) | Iintop(Imul) | Iaddf | Isubf | Imulf | Idivf -> @@ -86,7 +88,7 @@ | Ifloatofint | Iintoffloat -> (* Result must be in register, but argument can be on stack *) (arg, (if stackp res.(0) then [| self#makereg res.(0) |] else res)) - | Iconst_int n -> + | Iconst_int n | Iconst_blockheader n -> if n <= 0x7FFFFFFFn && n >= -0x80000000n then (arg, res) else super#reload_operation op arg res diff -Nru ocaml-4.01.0/asmcomp/amd64/selection.ml ocaml-4.02.3/asmcomp/amd64/selection.ml --- ocaml-4.01.0/asmcomp/amd64/selection.ml 2012-11-29 10:55:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/amd64/selection.ml 2014-04-26 12:40:22.000000000 +0200 @@ -91,6 +91,10 @@ (rax, rbx, rcx or rdx). Keep it simple, just force the argument in rax. *) | Ispecific(Ibswap 16) -> ([| rax |], [| rax |]) + (* For imulq, first arg must be in rax, rax is clobbered, and result is in + rdx. *) + | Iintop(Imulh) -> + ([| rax; arg.(1) |], [| rdx |]) | Ispecific(Ifloatarithmem(_,_)) -> let arg' = Array.copy arg in arg'.(0) <- res.(0); @@ -105,10 +109,6 @@ ([| rax; rcx |], [| rax |]) | Iintop(Imod) -> ([| rax; rcx |], [| rdx |]) - (* For div and mod with immediate operand, arg must not be in rax. - Keep it simple, force it in rdx. *) - | Iintop_imm((Idiv|Imod), _) -> - ([| rdx |], [| rdx |]) (* Other instructions are regular *) | _ -> raise Use_default @@ -152,20 +152,20 @@ | Ascaledadd(e1, e2, scale) -> (Iindexed2scaled(scale, d), Ctuple[e1; e2]) -method! select_store addr exp = +method! select_store is_assign addr exp = match exp with Cconst_int n when self#is_immediate n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) - | Cconst_natint n when self#is_immediate_natint n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) + | (Cconst_natint n | Cconst_blockheader n) when self#is_immediate_natint n -> + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_pointer n when self#is_immediate n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) | Cconst_natpointer n when self#is_immediate_natint n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_symbol s when not (!pic_code || !Clflags.dlcode) -> - (Ispecific(Istore_symbol(s, addr)), Ctuple []) + (Ispecific(Istore_symbol(s, addr, is_assign)), Ctuple []) | _ -> - super#select_store addr exp + super#select_store is_assign addr exp method! select_operation op args = match op with @@ -176,21 +176,6 @@ | (Iindexed2 0, _) -> super#select_operation op args | (addr, arg) -> (Ispecific(Ilea addr), [arg]) end - (* Recognize (x / cst) and (x % cst) only if cst is a power of 2. *) - | Cdivi -> - begin match args with - [arg1; Cconst_int n] when self#is_immediate n - && n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg1]) - | _ -> (Iintop Idiv, args) - end - | Cmodi -> - begin match args with - [arg1; Cconst_int n] when self#is_immediate n - && n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Imod, n), [arg1]) - | _ -> (Iintop Imod, args) - end (* Recognize float arithmetic with memory. *) | Caddf -> self#select_floatarith true Iaddf Ifloatadd args @@ -227,6 +212,9 @@ | Cextcall("caml_int64_direct_bswap", _, _, _) | Cextcall("caml_nativeint_direct_bswap", _, _, _) -> (Ispecific (Ibswap 64), args) + (* AMD64 does not support immediate operands for multiply high signed *) + | Cmulhi -> + (Iintop Imulh, args) | _ -> super#select_operation op args (* Recognize float arithmetic with mem *) @@ -246,6 +234,9 @@ | _ -> assert false +method! mark_c_tailcall = + Proc.contains_calls := true + (* Deal with register constraints *) method! insert_op_debug op dbg rs rd = diff -Nru ocaml-4.01.0/asmcomp/arm/arch.ml ocaml-4.02.3/asmcomp/arm/arch.ml --- ocaml-4.01.0/asmcomp/arm/arch.ml 2013-01-06 18:07:50.000000000 +0100 +++ ocaml-4.02.3/asmcomp/arm/arch.ml 2014-08-21 12:06:19.000000000 +0200 @@ -21,7 +21,7 @@ let abi = match Config.system with - "linux_eabi" -> EABI + "linux_eabi" | "freebsd" -> EABI | "linux_eabihf" -> EABI_HF | _ -> assert false @@ -107,9 +107,10 @@ (* Specific operations *) type specific_operation = - Ishiftarith of arith_operation * int - | Ishiftcheckbound of int + Ishiftarith of arith_operation * shift_operation * int + | Ishiftcheckbound of shift_operation * int | Irevsubimm of int + | Imulhadd (* multiply high and add *) | Imuladd (* multiply and add *) | Imulsub (* multiply and subtract *) | Inegmulf (* floating-point negate and multiply *) @@ -124,6 +125,14 @@ Ishiftadd | Ishiftsub | Ishiftsubrev + | Ishiftand + | Ishiftor + | Ishiftxor + +and shift_operation = + Ishiftlogicalleft + | Ishiftlogicalright + | Ishiftarithmeticright (* Sizes, endianness *) @@ -155,23 +164,41 @@ printreg ppf arg.(0); if n <> 0 then fprintf ppf " + %i" n +let shiftop_name = function + | Ishiftlogicalleft -> "<<" + | Ishiftlogicalright -> ">>u" + | Ishiftarithmeticright -> ">>s" + let print_specific_operation printreg op ppf arg = match op with - | Ishiftarith(op, shift) -> - let op_name = function - | Ishiftadd -> "+" - | Ishiftsub -> "-" - | Ishiftsubrev -> "-rev" in - let shift_mark = - if shift >= 0 - then sprintf "<< %i" shift - else sprintf ">> %i" (-shift) in - fprintf ppf "%a %s %a %s" - printreg arg.(0) (op_name op) printreg arg.(1) shift_mark - | Ishiftcheckbound n -> - fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) + Ishiftarith(op, shiftop, amount) -> + let (op1_name, op2_name) = match op with + Ishiftadd -> ("", "+") + | Ishiftsub -> ("", "-") + | Ishiftsubrev -> ("-", "+") + | Ishiftand -> ("", "&") + | Ishiftor -> ("", "|") + | Ishiftxor -> ("", "^") in + fprintf ppf "%s%a %s (%a %s %i)" + op1_name + printreg arg.(0) + op2_name + printreg arg.(1) + (shiftop_name shiftop) + amount + | Ishiftcheckbound(shiftop, amount) -> + fprintf ppf "check (%a %s %i) > %a" + printreg arg.(0) + (shiftop_name shiftop) + amount + printreg arg.(1) | Irevsubimm n -> fprintf ppf "%i %s %a" n "-" printreg arg.(0) + | Imulhadd -> + fprintf ppf "%a *h %a) + %a" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) | Imuladd -> fprintf ppf "(%a * %a) + %a" printreg arg.(0) diff -Nru ocaml-4.01.0/asmcomp/arm/CSE.ml ocaml-4.02.3/asmcomp/arm/CSE.ml --- ocaml-4.01.0/asmcomp/arm/CSE.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/arm/CSE.ml 2014-05-21 17:08:11.000000000 +0200 @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for ARM *) + +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Ishiftcheckbound _) -> Op_checkbound + | Ispecific _ -> Op_pure + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int n | Iconst_blockheader n -> n <= 255n && n >= 0n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff -Nru ocaml-4.01.0/asmcomp/arm/emit.mlp ocaml-4.02.3/asmcomp/arm/emit.mlp --- ocaml-4.01.0/asmcomp/arm/emit.mlp 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/asmcomp/arm/emit.mlp 2015-05-06 19:37:43.000000000 +0200 @@ -173,19 +173,23 @@ | Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi" let name_for_int_operation = function - Iadd -> "add" - | Isub -> "sub" - | Imul -> "mul" - | Iand -> "and" - | Ior -> "orr" - | Ixor -> "eor" + (* Use adds,subs,... to enable 16-bit T1 encoding *) + Iadd -> "adds" + | Isub -> "subs" + | Imul -> "mul" + | Imulh -> "smmul" + | Iand -> "ands" + | Ior -> "orrs" + | Ixor -> "eors" + | Ilsl -> "lsls" + | Ilsr -> "lsrs" + | Iasr -> "asrs" | _ -> assert false let name_for_shift_operation = function - Ilsl -> "lsl" - | Ilsr -> "lsr" - | Iasr -> "asr" - | _ -> assert false + Ishiftlogicalleft -> "lsl" + | Ishiftlogicalright -> "lsr" + | Ishiftarithmeticright -> "asr" (* General functional to decompose a non-immediate integer constant into 8-bit chunks shifted left 0 ... 30 bits. *) @@ -233,8 +237,9 @@ decompose_intconst n (fun bits -> if !first - then ` mov {emit_reg dst}, #{emit_int32 bits} @ {emit_int32 n}\n` - else ` add {emit_reg dst}, {emit_reg dst}, #{emit_int32 bits}\n`; + (* Use movs,adds here to enable 16-bit T1 encoding *) + then ` movs {emit_reg dst}, #{emit_int32 bits} @ {emit_int32 n}\n` + else ` adds {emit_reg dst}, {emit_reg dst}, #{emit_int32 bits}\n`; first := false) end @@ -268,7 +273,7 @@ (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 (* Pending floating-point literals *) -let float_literals = ref ([] : (string * label) list) +let float_literals = ref ([] : (int64 * label) list) (* Pending relative references to the global offset table *) let gotrel_literals = ref ([] : (label * label) list) (* Pending symbol literals *) @@ -278,12 +283,13 @@ (* Label a floating-point literal *) let float_literal f = + let repr = Int64.bits_of_float f in try - List.assoc f !float_literals + List.assoc repr !float_literals with Not_found -> let lbl = new_label() in num_literals := !num_literals + 2; - float_literals := (f, lbl) :: !float_literals; + float_literals := (repr, lbl) :: !float_literals; lbl (* Label a GOTREL literal *) @@ -309,7 +315,7 @@ ` .align 3\n`; List.iter (fun (f, lbl) -> - `{emit_label lbl}: .double {emit_string f}\n`) + `{emit_label lbl}:`; emit_float64_split_directive ".long" f) !float_literals; float_literals := [] end; @@ -382,11 +388,10 @@ ` ldr {emit_reg dst}, {emit_stack src}\n` end; 1 end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> emit_intconst i.res.(0) (Nativeint.to_int32 n) | Lop(Iconst_float f) when !fpu = Soft -> - ` @ {emit_string f}\n`; - let bits = Int64.bits_of_float (float_of_string f) in + let bits = Int64.bits_of_float f in let high_bits = Int64.to_int32 (Int64.shift_right_logical bits 32) and low_bits = Int64.to_int32 bits in if is_immediate low_bits || is_immediate high_bits then begin @@ -401,7 +406,7 @@ end | Lop(Iconst_float f) when !fpu = VFPv2 -> let lbl = float_literal f in - ` fldd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string f}\n`; + ` fldd {emit_reg i.res.(0)}, {emit_label lbl}\n`; 1 | Lop(Iconst_float f) -> let encode imm = @@ -420,12 +425,12 @@ let ex = ((ex + 3) land 0x07) lxor 0x04 in Some((sg lsl 7) lor (ex lsl 4) lor mn) end in - begin match encode (Int64.bits_of_float (float_of_string f)) with + begin match encode (Int64.bits_of_float f) with None -> let lbl = float_literal f in - ` fldd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string f}\n` + ` fldd {emit_reg i.res.(0)}, {emit_label lbl}\n` | Some imm8 -> - ` fconstd {emit_reg i.res.(0)}, #{emit_int imm8} @ {emit_string f}\n` + ` fconstd {emit_reg i.res.(0)}, #{emit_int imm8}\n` end; 1 | Lop(Iconst_symbol s) -> emit_load_symbol_addr i.res.(0) s @@ -503,10 +508,10 @@ | Double_u -> "fldd" | _ (* 32-bit quantities *) -> "ldr" in ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 0}\n`; 1 - | Lop(Istore(Single, addr)) when !fpu >= VFPv2 -> + | Lop(Istore(Single, addr, _)) when !fpu >= VFPv2 -> ` fcvtsd s14, {emit_reg i.arg.(0)}\n`; ` fsts s14, {emit_addressing addr i.arg 1}\n`; 2 - | Lop(Istore((Double | Double_u), addr)) when !fpu = Soft -> + | Lop(Istore((Double | Double_u), addr, _)) when !fpu = Soft -> (* Use STM or STRD if possible *) begin match i.arg.(0), i.arg.(1), addr with {loc = Reg rt}, {loc = Reg rt2}, Iindexed 0 @@ -520,7 +525,7 @@ ` str {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 2}\n`; ` str {emit_reg i.arg.(1)}, {emit_addressing addr' i.arg 2}\n`; 2 end - | Lop(Istore(size, addr)) -> + | Lop(Istore(size, addr, _)) -> let r = i.arg.(0) in let instr = match size with @@ -562,9 +567,6 @@ `{emit_label lbl_frame}: add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; 1 + ninstr end - | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> - let shift = name_for_shift_operation op in - ` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} {emit_reg i.arg.(1)}\n`; 1 | Lop(Iintop(Icomp cmp)) -> let compthen = name_for_comparison cmp in let compelse = name_for_comparison (negate_integer_comparison cmp) in @@ -587,45 +589,21 @@ let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; ` bls {emit_label lbl}\n`; 2 - | Lop(Ispecific(Ishiftcheckbound shift)) -> + | Lop(Ispecific(Ishiftcheckbound(shiftop, n))) -> let lbl = bound_error_label i.dbg in - ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; + let op = name_for_shift_operation shiftop in + ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, {emit_string op} #{emit_int n}\n`; ` bcs {emit_label lbl}\n`; 2 + | Lop(Iintop Imulh) when !arch < ARMv6 -> + ` smull r12, {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1 + | Lop(Ispecific Imulhadd) -> + ` smmla {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`; 1 | Lop(Iintop op) -> let instr = name_for_int_operation op in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1 - | Lop(Iintop_imm(Idiv, n)) -> (* n is a power of 2 *) - let l = Misc.log2 n in - let r = i.res.(0) in - ` movs {emit_reg r}, {emit_reg i.arg.(0)}\n`; - if n <= 256 then begin - ` it lt\n`; - ` addlt {emit_reg r}, {emit_reg r}, #{emit_int (n-1)}\n` - end else begin - ` itt lt\n`; - ` addlt {emit_reg r}, {emit_reg r}, #{emit_int n}\n`; - ` sublt {emit_reg r}, {emit_reg r}, #1\n` - end; - ` mov {emit_reg r}, {emit_reg r}, asr #{emit_int l}\n`; 5 - | Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *) - let l = Misc.log2 n in - let a = i.arg.(0) in - let r = i.res.(0) in - let lbl = new_label() in - ` cmp {emit_reg a}, #0\n`; - ` mov {emit_reg r}, {emit_reg a}, lsl #{emit_int (32-l)}\n`; - ` mov {emit_reg r}, {emit_reg r}, lsr #{emit_int (32-l)}\n`; - ` bpl {emit_label lbl}\n`; - ` cmp {emit_reg r}, #0\n`; - ` it ne\n`; - ` subne {emit_reg r}, {emit_reg r}, #{emit_int n}\n`; - `{emit_label lbl}:\n`; 7 - | Lop(Iintop_imm((Ilsl | Ilsr | Iasr as op), n)) -> - let shift = name_for_shift_operation op in - ` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} #{emit_int n}\n`; 1 + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1 | Lop(Iintop_imm(op, n)) -> let instr = name_for_int_operation op in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 | Lop(Iabsf | Inegf as op) when !fpu = Soft -> let instr = (match op with Iabsf -> "bic" @@ -664,16 +642,16 @@ | _ -> assert false) in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`; 1 - | Lop(Ispecific(Ishiftarith(op, shift))) -> + | Lop(Ispecific(Ishiftarith(op, shiftop, n))) -> let instr = (match op with Ishiftadd -> "add" | Ishiftsub -> "sub" - | Ishiftsubrev -> "rsb") in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`; - if shift >= 0 - then `, lsl #{emit_int shift}\n` - else `, asr #{emit_int (-shift)}\n`; - 1 + | Ishiftsubrev -> "rsb" + | Ishiftand -> "and" + | Ishiftor -> "orr" + | Ishiftxor -> "eor") in + let op = name_for_shift_operation shiftop in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_string op} #{emit_int n}\n`; 1 | Lop(Ispecific(Irevsubimm n)) -> ` rsb {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 | Lop(Ispecific(Imuladd | Imulsub as op)) -> @@ -803,11 +781,13 @@ ` pop \{trap_ptr, lr}\n`; cfi_adjust_cfa_offset (-8); stack_offset := !stack_offset - 8; 1 - | Lraise -> - if !Clflags.debug then begin + | Lraise k -> + begin match !Clflags.debug, k with + | true, (Lambda.Raise_regular | Lambda.Raise_reraise) -> ` {emit_call "caml_raise_exn"}\n`; `{record_frame Reg.Set.empty i.dbg}\n`; 1 - end else begin + | false, _ + | true, Lambda.Raise_notrace -> ` mov sp, trap_ptr\n`; ` pop \{trap_ptr, pc}\n`; 2 end @@ -872,8 +852,10 @@ let n = frame_size() in if n > 0 then begin ignore(emit_stack_adjustment (-n)); - if !contains_calls then + if !contains_calls then begin + cfi_offset ~reg:14 (* lr *) ~offset:(-4); ` str lr, [sp, #{emit_int(n - 4)}]\n` + end end; `{emit_label !tailrec_entry_point}:\n`; emit_all 0 fundecl.fun_body; @@ -894,8 +876,8 @@ | Cint16 n -> ` .short {emit_int n}\n` | Cint32 n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n` | Cint n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n` - | Csingle f -> ` .single {emit_string f}\n` - | Cdouble f -> ` .double {emit_string f}\n` + | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f) + | Cdouble f -> emit_float64_split_directive ".long" (Int64.bits_of_float f) | Csymbol_address s -> ` .word {emit_symbol s}\n` | Clabel_address lbl -> ` .word {emit_data_label lbl}\n` | Cstring s -> emit_string_directive " .ascii " s diff -Nru ocaml-4.01.0/asmcomp/arm/proc.ml ocaml-4.02.3/asmcomp/arm/proc.ml --- ocaml-4.01.0/asmcomp/arm/proc.ml 2013-06-03 20:03:59.000000000 +0200 +++ ocaml-4.02.3/asmcomp/arm/proc.ml 2014-10-09 11:33:36.000000000 +0200 @@ -82,14 +82,14 @@ (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 9 Reg.dummy in + let v = Array.make 9 Reg.dummy in for i = 0 to 8 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 32 Reg.dummy in + let v = Array.make 32 Reg.dummy in for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; @@ -108,7 +108,7 @@ 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 loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in @@ -166,13 +166,17 @@ let loc_exn_bucket = phys_reg 0 +(* Volatile registers: none *) + +let regs_are_volatile rs = false + (* Registers destroyed by operations *) let destroyed_at_alloc = (* r0-r6, d0-d15 preserved *) Array.of_list (List.map phys_reg [7;8; - 116;116;118;119;120;121;122;123; + 116;117;118;119;120;121;122;123; 124;125;126;127;128;129;130;131]) let destroyed_at_c_call = @@ -183,12 +187,12 @@ [0;1;2;3;8; 100;101;102;103;104;105;106;107; 108;109;110;111;112;113;114;115; - 116;116;118;119;120;121;122;123; + 116;117;118;119;120;121;122;123; 124;125;126;127;128;129;130;131] | EABI_HF -> (* r4-r7, d8-d15 preserved *) [0;1;2;3;8; 100;101;102;103;104;105;106;107; - 116;116;118;119;120;121;122;123; + 116;117;118;119;120;121;122;123; 124;125;126;127;128;129;130;131])) let destroyed_at_oper = function @@ -201,7 +205,9 @@ destroyed_at_alloc | Iop(Iconst_symbol _) when !pic_code -> [| phys_reg 3; phys_reg 8 |] (* r3 and r12 destroyed *) - | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _)) -> + | Iop(Iintop Imulh) when !arch < ARMv6 -> + [| phys_reg 8 |] (* r12 destroyed *) + | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _)) -> [| phys_reg 107 |] (* d7 (s14-s15) destroyed *) | _ -> [||] @@ -213,6 +219,7 @@ Iextcall(_, _) -> if abi = EABI then 0 else 4 | Ialloc _ -> if abi = EABI then 0 else 7 | Iconst_symbol _ when !pic_code -> 7 + | Iintop Imulh when !arch < ARMv6 -> 8 | _ -> 9 let max_register_pressure = function @@ -220,9 +227,20 @@ | Ialloc _ -> if abi = EABI then [| 7; 0; 0 |] else [| 7; 8; 8 |] | Iconst_symbol _ when !pic_code -> [| 7; 16; 32 |] | Iintoffloat | Ifloatofint - | Iload(Single, _) | Istore(Single, _) -> [| 9; 15; 31 |] + | Iload(Single, _) | Istore(Single, _, _) -> [| 9; 15; 31 |] + | Iintop Imulh when !arch < ARMv6 -> [| 8; 16; 32 |] | _ -> [| 9; 16; 32 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) + | Ispecific(Ishiftcheckbound _) -> false + | _ -> true + (* Layout of the stack *) let num_stack_slots = [| 0; 0; 0 |] diff -Nru ocaml-4.01.0/asmcomp/arm/scheduling.ml ocaml-4.02.3/asmcomp/arm/scheduling.ml --- ocaml-4.01.0/asmcomp/arm/scheduling.ml 2012-10-24 08:20:45.000000000 +0200 +++ ocaml-4.02.3/asmcomp/arm/scheduling.ml 2013-11-19 08:01:54.000000000 +0100 @@ -31,8 +31,8 @@ | Ifloatofint (* mcr/mrc count as memory access *) | Iintoffloat -> 2 (* Multiplys have a latency of two cycles *) - | Iintop Imul - | Ispecific(Imuladd | Imulsub) -> 2 + | Iintop (Imul | Imulh) + | Ispecific(Imuladd | Imulsub | Imulhadd) -> 2 (* VFP instructions *) | Iaddf | Isubf @@ -58,10 +58,8 @@ | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> 2 | Ispecific(Ishiftcheckbound _) -> 3 - | Iintop_imm(Idiv, _) -> 4 - | Iintop_imm(Imod, _) -> 6 - | Iintop Imul - | Ispecific(Imuladd | Imulsub) -> 2 + | Iintop(Imul | Imulh) + | Ispecific(Imuladd | Imulsub | Imulhadd) -> 2 (* VFP instructions *) | Iaddf | Isubf -> 7 diff -Nru ocaml-4.01.0/asmcomp/arm/selection.ml ocaml-4.02.3/asmcomp/arm/selection.ml --- ocaml-4.01.0/asmcomp/arm/selection.ml 2013-05-08 15:21:32.000000000 +0200 +++ ocaml-4.02.3/asmcomp/arm/selection.ml 2014-10-09 11:33:36.000000000 +0200 @@ -37,15 +37,20 @@ | _ -> n >= -255 && n <= 255 -let is_intconst = function - Cconst_int _ -> true - | _ -> false +let select_shiftop = function + Clsl -> Ishiftlogicalleft + | Clsr -> Ishiftlogicalright + | Casr -> Ishiftarithmeticright + | __-> assert false (* Special constraints on operand and result registers *) exception Use_default let r1 = phys_reg 1 +let r6 = phys_reg 6 +let r7 = phys_reg 7 +let r12 = phys_reg 8 let pseudoregs_for_operation op arg res = match op with @@ -54,6 +59,13 @@ is also a result of the mul / mla operation. *) Iintop Imul | Ispecific Imuladd when !arch < ARMv6 -> (arg, [| res.(0); arg.(0) |]) + (* For smull rdlo,rdhi,rn,rm (pre-ARMv6) the registers rdlo, rdhi and rn + must be different. Also, rdlo (whose contents we discard) is always + forced to be r12 in proc.ml, which means that neither rdhi and rn can + be r12. To keep things simple, we force both of those two to specific + hard regs: rdhi in r6 and rn in r7. *) + | Iintop Imulh when !arch < ARMv6 -> + ([| r7; arg.(1) |], [| r6 |]) (* Soft-float Iabsf and Inegf: arg.(0) and res.(0) must be the same *) | Iabsf | Inegf when !fpu = Soft -> ([|res.(0); arg.(1)|], res) @@ -110,24 +122,27 @@ | arg -> (Iindexed 0, arg) -method select_shift_arith op shiftop shiftrevop args = +method select_shift_arith op arithop arithrevop args = match args with - [arg1; Cop(Clsl, [arg2; Cconst_int n])] - when n > 0 && n < 32 && not(is_intconst arg2) -> - (Ispecific(Ishiftarith(shiftop, n)), [arg1; arg2]) - | [arg1; Cop(Casr, [arg2; Cconst_int n])] - when n > 0 && n < 32 && not(is_intconst arg2) -> - (Ispecific(Ishiftarith(shiftop, -n)), [arg1; arg2]) - | [Cop(Clsl, [arg1; Cconst_int n]); arg2] - when n > 0 && n < 32 && not(is_intconst arg1) -> - (Ispecific(Ishiftarith(shiftrevop, n)), [arg2; arg1]) - | [Cop(Casr, [arg1; Cconst_int n]); arg2] - when n > 0 && n < 32 && not(is_intconst arg1) -> - (Ispecific(Ishiftarith(shiftrevop, -n)), [arg2; arg1]) + [arg1; Cop(Clsl | Clsr | Casr as op, [arg2; Cconst_int n])] + when n > 0 && n < 32 -> + (Ispecific(Ishiftarith(arithop, select_shiftop op, n)), [arg1; arg2]) + | [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int n]); arg2] + when n > 0 && n < 32 -> + (Ispecific(Ishiftarith(arithrevop, select_shiftop op, n)), [arg2; arg1]) | args -> begin match super#select_operation op args with + (* Recognize multiply high and add *) + (Iintop Iadd, [Cop(Cmulhi, args); arg3]) + | (Iintop Iadd, [arg3; Cop(Cmulhi, args)]) as op_args + when !arch >= ARMv6 -> + begin match self#select_operation Cmulhi args with + (Iintop Imulh, [arg1; arg2]) -> + (Ispecific Imulhadd, [arg1; arg2; arg3]) + | _ -> op_args + end (* Recognize multiply and add *) - (Iintop Iadd, [Cop(Cmuli, args); arg3]) + | (Iintop Iadd, [Cop(Cmuli, args); arg3]) | (Iintop Iadd, [arg3; Cop(Cmuli, args)]) as op_args -> begin match self#select_operation Cmuli args with (Iintop Imul, [arg1; arg2]) -> @@ -161,21 +176,23 @@ (Ispecific(Irevsubimm n), [arg]) | ((Csuba | Csubi as op), args) -> self#select_shift_arith op Ishiftsub Ishiftsubrev args - | (Ccheckbound _, [Cop(Clsr, [arg1; Cconst_int n]); arg2]) - when n > 0 && n < 32 && not(is_intconst arg2) -> - (Ispecific(Ishiftcheckbound n), [arg1; arg2]) + | (Cand as op, args) -> + self#select_shift_arith op Ishiftand Ishiftand args + | (Cor as op, args) -> + self#select_shift_arith op Ishiftor Ishiftor args + | (Cxor as op, args) -> + self#select_shift_arith op Ishiftxor Ishiftxor args + | (Ccheckbound _, [Cop(Clsl | Clsr | Casr as op, [arg1; Cconst_int n]); arg2]) + when n > 0 && n < 32 -> + (Ispecific(Ishiftcheckbound(select_shiftop op, n)), [arg1; arg2]) (* ARM does not support immediate operands for multiplication *) | (Cmuli, args) -> (Iintop Imul, args) + | (Cmulhi, args) -> + (Iintop Imulh, args) (* Turn integer division/modulus into runtime ABI calls *) - | (Cdivi, [arg; Cconst_int n]) - when n = 1 lsl Misc.log2 n -> - (Iintop_imm(Idiv, n), [arg]) | (Cdivi, args) -> (Iextcall("__aeabi_idiv", false), args) - | (Cmodi, [arg; Cconst_int n]) - when n > 1 && n = 1 lsl Misc.log2 n -> - (Iintop_imm(Imod, n), [arg]) | (Cmodi, args) -> (* See above for fix up of return register *) (Iextcall("__aeabi_idivmod", false), args) diff -Nru ocaml-4.01.0/asmcomp/arm64/arch.ml ocaml-4.02.3/asmcomp/arm64/arch.ml --- ocaml-4.01.0/asmcomp/arm64/arch.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/arm64/arch.ml 2015-06-10 11:27:36.000000000 +0200 @@ -0,0 +1,158 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) +(* *) +(***********************************************************************) + +let command_line_options = [] + +(* Specific operations for the ARM processor, 64-bit mode *) + +open Format + +let command_line_options = [] + +(* Addressing modes *) + +type addressing_mode = + | Iindexed of int (* reg + displ *) + | Ibased of string * int (* global var + displ *) + +(* We do not support the reg + shifted reg addressing mode, because + what we really need is reg + shifted reg + displ, + and this is decomposed in two instructions (reg + shifted reg -> tmp, + then addressing tmp + displ). *) + +(* Specific operations *) + +type specific_operation = + | Ifar_alloc of int + | Ifar_intop_checkbound + | Ifar_intop_imm_checkbound of int + | Ishiftarith of arith_operation * int + | Ishiftcheckbound of int + | Ifar_shiftcheckbound of int + | Imuladd (* multiply and add *) + | Imulsub (* multiply and subtract *) + | Inegmulf (* floating-point negate and multiply *) + | Imuladdf (* floating-point multiply and add *) + | Inegmuladdf (* floating-point negate, multiply and add *) + | Imulsubf (* floating-point multiply and subtract *) + | Inegmulsubf (* floating-point negate, multiply and subtract *) + | Isqrtf (* floating-point square root *) + | Ibswap of int (* endianess conversion *) + +and arith_operation = + Ishiftadd + | Ishiftsub + +(* Sizes, endianness *) + +let big_endian = false + +let size_addr = 8 +let size_int = 8 +let size_float = 8 + +let allow_unaligned_access = false + +(* Behavior of division *) + +let division_crashes_on_overflow = false + +(* Operations on addressing modes *) + +let identity_addressing = Iindexed 0 + +let offset_addressing addr delta = + match addr with + | Iindexed n -> Iindexed(n + delta) + | Ibased(s, n) -> Ibased(s, n + delta) + +let num_args_addressing = function + | Iindexed n -> 1 + | Ibased(s, n) -> 0 + +(* Printing operations and addressing modes *) + +let print_addressing printreg addr ppf arg = + match addr with + | Iindexed n -> + printreg ppf arg.(0); + if n <> 0 then fprintf ppf " + %i" n + | Ibased(s, 0) -> + fprintf ppf "\"%s\"" s + | Ibased(s, n) -> + fprintf ppf "\"%s\" + %i" s n + +let print_specific_operation printreg op ppf arg = + match op with + | Ifar_alloc n -> + fprintf ppf "(far) alloc %i" n + | Ifar_intop_checkbound -> + fprintf ppf "%a (far) check > %a" printreg arg.(0) printreg arg.(1) + | Ifar_intop_imm_checkbound n -> + fprintf ppf "%a (far) check > %i" printreg arg.(0) n + | Ishiftarith(op, shift) -> + let op_name = function + | Ishiftadd -> "+" + | Ishiftsub -> "-" in + let shift_mark = + if shift >= 0 + then sprintf "<< %i" shift + else sprintf ">> %i" (-shift) in + fprintf ppf "%a %s %a %s" + printreg arg.(0) (op_name op) printreg arg.(1) shift_mark + | Ishiftcheckbound n -> + fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) + | Ifar_shiftcheckbound n -> + fprintf ppf + "(far) check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) + | Imuladd -> + fprintf ppf "(%a * %a) + %a" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Imulsub -> + fprintf ppf "-(%a * %a) + %a" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Inegmulf -> + fprintf ppf "-f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + | Imuladdf -> + fprintf ppf "%a +f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Inegmuladdf -> + fprintf ppf "(-f %a) -f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Imulsubf -> + fprintf ppf "%a -f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Inegmulsubf -> + fprintf ppf "(-f %a) +f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Isqrtf -> + fprintf ppf "sqrtf %a" + printreg arg.(0) + | Ibswap n -> + fprintf ppf "bswap%i %a" n + printreg arg.(0) diff -Nru ocaml-4.01.0/asmcomp/arm64/CSE.ml ocaml-4.02.3/asmcomp/arm64/CSE.ml --- ocaml-4.01.0/asmcomp/arm64/CSE.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/arm64/CSE.ml 2014-05-21 17:08:11.000000000 +0200 @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for ARM64 *) + +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Ishiftcheckbound _) -> Op_checkbound + | Ispecific _ -> Op_pure + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int n | Iconst_blockheader n -> n <= 65535n && n >= 0n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff -Nru ocaml-4.01.0/asmcomp/arm64/emit.mlp ocaml-4.02.3/asmcomp/arm64/emit.mlp --- ocaml-4.01.0/asmcomp/arm64/emit.mlp 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/arm64/emit.mlp 2015-06-10 11:27:36.000000000 +0200 @@ -0,0 +1,986 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Emission of ARM assembly code, 64-bit mode *) + +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(* Tradeoff between code size and code speed *) + +let fastcode_flag = ref true + +(* Names for special regs *) + +let reg_trap_ptr = phys_reg 23 +let reg_alloc_ptr = phys_reg 24 +let reg_alloc_limit = phys_reg 25 +let reg_tmp1 = phys_reg 26 +let reg_tmp2 = phys_reg 27 +let reg_x15 = phys_reg 15 + +(* Output a label *) + +let emit_label lbl = + emit_string ".L"; emit_int lbl + +let emit_data_label lbl = + emit_string ".Ld"; emit_int lbl + +(* Symbols *) + +let emit_symbol s = + Emitaux.emit_symbol '$' s + +(* Output a pseudo-register *) + +let emit_reg = function + {loc = Reg r} -> emit_string (register_name r) + | _ -> fatal_error "Emit.emit_reg" + +(* Likewise, but with the 32-bit name of the register *) + +let int_reg_name_w = + [| "w0"; "w1"; "w2"; "w3"; "w4"; "w5"; "w6"; "w7"; + "w8"; "w9"; "w10"; "w11"; "w12"; "w13"; "w14"; "w15"; + "w19"; "w20"; "w21"; "w22"; "w23"; "w24"; "w25"; + "w26"; "w27"; "w28"; "w16"; "w17" |] + +let emit_wreg = function + {loc = Reg r} -> emit_string int_reg_name_w.(r) + | _ -> fatal_error "Emit.emit_wreg" + +(* Layout of the stack frame *) + +let stack_offset = ref 0 + +let frame_size () = + let sz = + !stack_offset + + 8 * num_stack_slots.(0) + + 8 * num_stack_slots.(1) + + (if !contains_calls then 8 else 0) + in Misc.align sz 16 + +let slot_offset loc cl = + match loc with + Incoming n -> + assert (n >= 0); + frame_size() + n + | Local n -> + !stack_offset + + (if cl = 0 + then n * 8 + else num_stack_slots.(0) * 8 + n * 8) + | Outgoing n -> + assert (n >= 0); + n + +(* Output a stack reference *) + +let emit_stack r = + match r.loc with + | Stack s -> + let ofs = slot_offset s (register_class r) in `[sp, #{emit_int ofs}]` + | _ -> fatal_error "Emit.emit_stack" + +(* Output an addressing mode *) + +let emit_symbol_offset s ofs = + emit_symbol s; + if ofs > 0 then `+{emit_int ofs}` + else if ofs < 0 then `-{emit_int (-ofs)}` + else () + +let emit_addressing addr r = + match addr with + | Iindexed ofs -> + `[{emit_reg r}, #{emit_int ofs}]` + | Ibased(s, ofs) -> + `[{emit_reg r}, #:lo12:{emit_symbol_offset s ofs}]` + +(* Record live pointers at call points *) + +let record_frame_label live dbg = + let lbl = new_label() in + let live_offset = ref [] in + Reg.Set.iter + (function + {typ = Addr; loc = Reg r} -> + live_offset := ((r lsl 1) + 1) :: !live_offset + | {typ = Addr; loc = Stack s} as reg -> + live_offset := slot_offset s (register_class reg) :: !live_offset + | _ -> ()) + live; + frame_descriptors := + { fd_lbl = lbl; + fd_frame_size = frame_size(); + fd_live_offset = !live_offset; + fd_debuginfo = dbg } :: !frame_descriptors; + lbl + +let record_frame live dbg = + let lbl = record_frame_label live dbg in `{emit_label lbl}:` + +(* Record calls to the GC -- we've moved them out of the way *) + +type gc_call = + { gc_lbl: label; (* Entry label *) + gc_return_lbl: label; (* Where to branch after GC *) + gc_frame_lbl: label } (* Label of frame descriptor *) + +let call_gc_sites = ref ([] : gc_call list) + +let emit_call_gc gc = + `{emit_label gc.gc_lbl}: bl {emit_symbol "caml_call_gc"}\n`; + `{emit_label gc.gc_frame_lbl}: b {emit_label gc.gc_return_lbl}\n` + +(* Record calls to caml_ml_array_bound_error. + In debug mode, we maintain one call to caml_ml_array_bound_error + per bound check site. Otherwise, we can share a single call. *) + +type bound_error_call = + { bd_lbl: label; (* Entry label *) + bd_frame_lbl: label } (* Label of frame descriptor *) + +let bound_error_sites = ref ([] : bound_error_call list) + +let bound_error_label dbg = + if !Clflags.debug || !bound_error_sites = [] then begin + let lbl_bound_error = new_label() in + let lbl_frame = record_frame_label Reg.Set.empty dbg in + bound_error_sites := + { bd_lbl = lbl_bound_error; + bd_frame_lbl = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + let bd = List.hd !bound_error_sites in bd.bd_lbl + end + +let emit_call_bound_error bd = + `{emit_label bd.bd_lbl}: bl {emit_symbol "caml_ml_array_bound_error"}\n`; + `{emit_label bd.bd_frame_lbl}:\n` + +(* Names of various instructions *) + +let name_for_comparison = function + | Isigned Ceq -> "eq" | Isigned Cne -> "ne" | Isigned Cle -> "le" + | Isigned Cge -> "ge" | Isigned Clt -> "lt" | Isigned Cgt -> "gt" + | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "ls" + | Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi" + +let name_for_int_operation = function + | Iadd -> "add" + | Isub -> "sub" + | Imul -> "mul" + | Idiv -> "sdiv" + | Iand -> "and" + | Ior -> "orr" + | Ixor -> "eor" + | Ilsl -> "lsl" + | Ilsr -> "lsr" + | Iasr -> "asr" + | _ -> assert false + +(* Load an integer constant into a register *) + +let emit_intconst dst n = + let rec emit_pos first shift = + if shift < 0 then begin + if first then ` mov {emit_reg dst}, xzr\n` + end else begin + let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in + if s = 0n then emit_pos first (shift - 16) else begin + if first then + ` movz {emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n` + else + ` movk {emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n`; + emit_pos false (shift - 16) + end + end + and emit_neg first shift = + if shift < 0 then begin + if first then ` movn {emit_reg dst}, #0\n` + end else begin + let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in + if s = 0xFFFFn then emit_neg first (shift - 16) else begin + if first then + ` movn {emit_reg dst}, #{emit_nativeint (Nativeint.logxor s 0xFFFFn)}, lsl #{emit_int shift}\n` + else + ` movk {emit_reg dst}, #{emit_nativeint s}, lsl #{emit_int shift}\n`; + emit_neg false (shift - 16) + end + end + in + if n < 0n then emit_neg true 48 else emit_pos true 48 + +let num_instructions_for_intconst n = + let num_instructions = ref 0 in + let rec count_pos first shift = + if shift < 0 then begin + if first then incr num_instructions + end else begin + let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in + if s = 0n then count_pos first (shift - 16) else begin + incr num_instructions; + count_pos false (shift - 16) + end + end + and count_neg first shift = + if shift < 0 then begin + if first then incr num_instructions + end else begin + let s = Nativeint.(logand (shift_right_logical n shift) 0xFFFFn) in + if s = 0xFFFFn then count_neg first (shift - 16) else begin + incr num_instructions; + count_neg false (shift - 16) + end + end + in + if n < 0n then count_neg true 48 else count_pos true 48; + !num_instructions + +(* Recognize float constants appropriate for FMOV dst, #fpimm instruction: + "a normalized binary floating point encoding with 1 sign bit, 4 + bits of fraction and a 3-bit exponent" *) + +let is_immediate_float bits = + let exp = (Int64.(to_int (shift_right_logical bits 52)) land 0x7FF) - 1023 in + let mant = Int64.logand bits 0xF_FFFF_FFFF_FFFFL in + exp >= -3 && exp <= 4 && Int64.logand mant 0xF_0000_0000_0000L = mant + +(* Adjust sp (up or down) by the given byte amount *) + +let emit_stack_adjustment n = + let instr = if n < 0 then "sub" else "add" in + let m = abs n in + assert (m < 0x1_000_000); + let ml = m land 0xFFF and mh = m land 0xFFF_000 in + if mh <> 0 then ` {emit_string instr} sp, sp, #{emit_int mh}\n`; + if ml <> 0 then ` {emit_string instr} sp, sp, #{emit_int ml}\n`; + if n <> 0 then cfi_adjust_cfa_offset (-n) + +(* Deallocate the stack frame and reload the return address + before a return or tail call *) + +let output_epilogue f = + let n = frame_size() in + if !contains_calls then + ` ldr x30, [sp, #{emit_int (n-8)}]\n`; + if n > 0 then + emit_stack_adjustment n; + f(); + (* reset CFA back because function body may continue *) + if n > 0 then cfi_adjust_cfa_offset n + +(* Name of current function *) +let function_name = ref "" +(* Entry point for tail recursive calls *) +let tailrec_entry_point = ref 0 +(* Pending floating-point literals *) +let float_literals = ref ([] : (int64 * label) list) + +(* Label a floating-point literal *) +let float_literal f = + try + List.assoc f !float_literals + with Not_found -> + let lbl = new_label() in + float_literals := (f, lbl) :: !float_literals; + lbl + +(* Emit all pending literals *) +let emit_literals() = + if !float_literals <> [] then begin + ` .align 3\n`; + List.iter + (fun (f, lbl) -> + `{emit_label lbl}:`; emit_float64_directive ".quad" f) + !float_literals; + float_literals := [] + end + +(* Emit code to load the address of a symbol *) + +let emit_load_symbol_addr dst s = + if (not !Clflags.dlcode) || Compilenv.symbol_in_current_unit s then begin + ` adrp {emit_reg dst}, {emit_symbol s}\n`; + ` add {emit_reg dst}, {emit_reg dst}, #:lo12:{emit_symbol s}\n` + end else begin + ` adrp {emit_reg dst}, :got:{emit_symbol s}\n`; + ` ldr {emit_reg dst}, [{emit_reg dst}, #:got_lo12:{emit_symbol s}]\n` + end + +(* The following functions are used for calculating the sizes of the + call GC and bounds check points emitted out-of-line from the function + body. See branch_relaxation.mli. *) + +let num_call_gc_and_check_bound_points instr = + let rec loop instr ((call_gc, check_bound) as totals) = + match instr.desc with + | Lend -> totals + | Lop (Ialloc _) when !fastcode_flag -> + loop instr.next (call_gc + 1, check_bound) + | Lop (Iintop Icheckbound) + | Lop (Iintop_imm (Icheckbound, _)) + | Lop (Ispecific (Ishiftcheckbound _)) -> + let check_bound = + (* When not in debug mode, there is at most one check-bound point. *) + if not !Clflags.debug then 1 + else check_bound + 1 + in + loop instr.next (call_gc, check_bound) + (* The following four should never be seen, since this function is run + before branch relaxation. *) + | Lop (Ispecific (Ifar_alloc _)) + | Lop (Ispecific Ifar_intop_checkbound) + | Lop (Ispecific (Ifar_intop_imm_checkbound _)) + | Lop (Ispecific (Ifar_shiftcheckbound _)) -> assert false + | _ -> loop instr.next totals + in + loop instr (0, 0) + +let max_out_of_line_code_offset instr ~num_call_gc ~num_check_bound = + if num_call_gc < 1 && num_check_bound < 1 then 0 + else begin + let size_of_call_gc = 2 in + let size_of_check_bound = 1 in + let size_of_last_thing = + (* Call-GC points come before check-bound points. *) + if num_check_bound >= 1 then size_of_check_bound else size_of_call_gc + in + let total_size = + size_of_call_gc*num_call_gc + size_of_check_bound*num_check_bound + in + let max_offset = total_size - size_of_last_thing in + assert (max_offset >= 0); + max_offset + end + +module BR = Branch_relaxation.Make (struct + (* CR-someday mshinwell: B and BL have +/- 128Mb ranges; for the moment we + assume we will never exceed this. It would seem to be most likely to + occur for branches between functions; in this case, the linker should be + able to insert veneers anyway. (See section 4.6.7 of the document + "ELF for the ARM 64-bit architecture (AArch64)".) *) + + type distance = int + + module Cond_branch = struct + type t = TB | CB | Bcc + + let all = [TB; CB; Bcc] + + (* AArch64 instructions are 32 bits wide, so [distance] in this module + means units of 32-bit words. *) + let max_displacement = function + | TB -> 32 * 1024 / 4 (* +/- 32Kb *) + | CB | Bcc -> 1 * 1024 * 1024 / 4 (* +/- 1Mb *) + + let classify_instr = function + | Lop (Ialloc _) + | Lop (Iintop Icheckbound) + | Lop (Iintop_imm (Icheckbound, _)) + | Lop (Ispecific (Ishiftcheckbound _)) -> Some Bcc + (* The various "far" variants in [specific_operation] don't need to + return [Some] here, since their code sequences never contain any + conditional branches that might need relaxing. *) + | Lcondbranch (Itruetest, _) + | Lcondbranch (Ifalsetest, _) -> Some CB + | Lcondbranch (Iinttest _, _) + | Lcondbranch (Iinttest_imm _, _) + | Lcondbranch (Ifloattest _, _) -> Some Bcc + | Lcondbranch (Ioddtest, _) + | Lcondbranch (Ieventest, _) -> Some TB + | Lcondbranch3 _ -> Some Bcc + | _ -> None + end + + let offset_pc_at_branch = 0 + + let epilogue_size () = + if !contains_calls then 3 else 2 + + let instr_size = function + | Lend -> 0 + | Lop (Imove | Ispill | Ireload) -> 1 + | Lop (Iconst_int n | Iconst_blockheader n) -> + num_instructions_for_intconst n + | Lop (Iconst_float _) -> 2 + | Lop (Iconst_symbol _) -> 2 + | Lop (Icall_ind) -> 1 + | Lop (Icall_imm _) -> 1 + | Lop (Itailcall_ind) -> epilogue_size () + | Lop (Itailcall_imm s) -> + if s = !function_name then 1 else epilogue_size () + | Lop (Iextcall (_, false)) -> 1 + | Lop (Iextcall (_, true)) -> 3 + | Lop (Istackoffset _) -> 2 + | Lop (Iload (size, addr)) | Lop (Istore (size, addr, _)) -> + let based = match addr with Iindexed _ -> 0 | Ibased _ -> 1 in + based + begin match size with Single -> 2 | _ -> 1 end + | Lop (Ialloc _) when !fastcode_flag -> 4 + | Lop (Ispecific (Ifar_alloc _)) when !fastcode_flag -> 5 + | Lop (Ialloc num_words) | Lop (Ispecific (Ifar_alloc num_words)) -> + begin match num_words with + | 16 | 24 | 32 -> 1 + | _ -> 1 + num_instructions_for_intconst (Nativeint.of_int num_words) + end + | Lop (Iintop (Icomp _)) -> 2 + | Lop (Iintop_imm (Icomp _, _)) -> 2 + | Lop (Iintop Icheckbound) -> 2 + | Lop (Ispecific Ifar_intop_checkbound) -> 3 + | Lop (Iintop_imm (Icheckbound, _)) -> 2 + | Lop (Ispecific (Ifar_intop_imm_checkbound _)) -> 3 + | Lop (Ispecific (Ishiftcheckbound _)) -> 2 + | Lop (Ispecific (Ifar_shiftcheckbound _)) -> 3 + | Lop (Iintop Imod) -> 2 + | Lop (Iintop Imulh) -> 1 + | Lop (Iintop _) -> 1 + | Lop (Iintop_imm _) -> 1 + | Lop (Ifloatofint | Iintoffloat | Iabsf | Inegf | Ispecific Isqrtf) -> 1 + | Lop (Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf) -> 1 + | Lop (Ispecific (Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf)) -> 1 + | Lop (Ispecific (Ishiftarith _)) -> 1 + | Lop (Ispecific (Imuladd | Imulsub)) -> 1 + | Lop (Ispecific (Ibswap 16)) -> 2 + | Lop (Ispecific (Ibswap _)) -> 1 + | Lreloadretaddr -> 0 + | Lreturn -> epilogue_size () + | Llabel _ -> 0 + | Lbranch _ -> 1 + | Lcondbranch (tst, _) -> + begin match tst with + | Itruetest -> 1 + | Ifalsetest -> 1 + | Iinttest _ -> 2 + | Iinttest_imm _ -> 2 + | Ifloattest _ -> 2 + | Ioddtest -> 1 + | Ieventest -> 1 + end + | Lcondbranch3 (lbl0, lbl1, lbl2) -> + 1 + begin match lbl0 with None -> 0 | Some _ -> 1 end + + begin match lbl1 with None -> 0 | Some _ -> 1 end + + begin match lbl2 with None -> 0 | Some _ -> 1 end + | Lswitch jumptbl -> 3 + Array.length jumptbl + | Lsetuptrap _ -> 2 + | Lpushtrap -> 3 + | Lpoptrap -> 1 + | Lraise k -> + begin match !Clflags.debug, k with + | true, (Lambda.Raise_regular | Lambda.Raise_reraise) -> 1 + | false, _ + | true, Lambda.Raise_notrace -> 4 + end + + let relax_allocation ~num_words = + Lop (Ispecific (Ifar_alloc num_words)) + + let relax_intop_checkbound () = + Lop (Ispecific Ifar_intop_checkbound) + + let relax_intop_imm_checkbound ~bound = + Lop (Ispecific (Ifar_intop_imm_checkbound bound)) + + let relax_specific_op = function + | Ishiftcheckbound shift -> Lop (Ispecific (Ifar_shiftcheckbound shift)) + | _ -> assert false +end) + +(* Output the assembly code for allocation. *) + +let assembly_code_for_allocation i ~n ~far = + let lbl_frame = record_frame_label i.live i.dbg in + if !fastcode_flag then begin + let lbl_redo = new_label() in + let lbl_call_gc = new_label() in + `{emit_label lbl_redo}:`; + ` sub {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_ptr}, #{emit_int n}\n`; + ` cmp {emit_reg reg_alloc_ptr}, {emit_reg reg_alloc_limit}\n`; + ` add {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n`; + if not far then begin + ` b.lo {emit_label lbl_call_gc}\n` + end else begin + let lbl = new_label () in + ` b.cs {emit_label lbl}\n`; + ` b {emit_label lbl_call_gc}\n`; + `{emit_label lbl}:\n` + end; + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame_lbl = lbl_frame } :: !call_gc_sites + end else begin + begin match n with + | 16 -> ` bl {emit_symbol "caml_alloc1"}\n` + | 24 -> ` bl {emit_symbol "caml_alloc2"}\n` + | 32 -> ` bl {emit_symbol "caml_alloc3"}\n` + | _ -> emit_intconst reg_x15 (Nativeint.of_int n); + ` bl {emit_symbol "caml_allocN"}\n` + end; + `{emit_label lbl_frame}: add {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n` + end + +(* Output the assembly code for an instruction *) + +let emit_instr i = + emit_debug_info i.dbg; + match i.desc with + | Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then begin + match (src, dst) with + | {loc = Reg _; typ = Float}, {loc = Reg _} -> + ` fmov {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg _}, {loc = Reg _} -> + ` mov {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg _}, {loc = Stack _} -> + ` str {emit_reg src}, {emit_stack dst}\n` + | {loc = Stack _}, {loc = Reg _} -> + ` ldr {emit_reg dst}, {emit_stack src}\n` + | _ -> + assert false + end + | Lop(Iconst_int n | Iconst_blockheader n) -> + emit_intconst i.res.(0) n + | Lop(Iconst_float f) -> + let b = Int64.bits_of_float f in + if b = 0L then + ` fmov {emit_reg i.res.(0)}, xzr\n` + else if is_immediate_float b then + ` fmov {emit_reg i.res.(0)}, #{emit_printf "0x%Lx" b}\n` + else begin + let lbl = float_literal b in + ` adrp {emit_reg reg_tmp1}, {emit_label lbl}\n`; + ` ldr {emit_reg i.res.(0)}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}]\n` + end + | Lop(Iconst_symbol s) -> + emit_load_symbol_addr i.res.(0) s + | Lop(Icall_ind) -> + ` blr {emit_reg i.arg.(0)}\n`; + `{record_frame i.live i.dbg}\n` + | Lop(Icall_imm s) -> + ` bl {emit_symbol s}\n`; + `{record_frame i.live i.dbg}\n` + | Lop(Itailcall_ind) -> + output_epilogue (fun () -> ` br {emit_reg i.arg.(0)}\n`) + | Lop(Itailcall_imm s) -> + if s = !function_name then + ` b {emit_label !tailrec_entry_point}\n` + else + output_epilogue (fun () -> ` b {emit_symbol s}\n`) + | Lop(Iextcall(s, false)) -> + ` bl {emit_symbol s}\n` + | Lop(Iextcall(s, true)) -> + emit_load_symbol_addr reg_x15 s; + ` bl {emit_symbol "caml_c_call"}\n`; + `{record_frame i.live i.dbg}\n` + | Lop(Istackoffset n) -> + assert (n mod 16 = 0); + emit_stack_adjustment (-n); + stack_offset := !stack_offset + n + | Lop(Iload(size, addr)) -> + let dst = i.res.(0) in + let base = + match addr with + | Iindexed ofs -> i.arg.(0) + | Ibased(s, ofs) -> + ` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`; + reg_tmp1 in + begin match size with + | Byte_unsigned -> + ` ldrb {emit_wreg dst}, {emit_addressing addr base}\n` + | Byte_signed -> + ` ldrsb {emit_reg dst}, {emit_addressing addr base}\n` + | Sixteen_unsigned -> + ` ldrh {emit_wreg dst}, {emit_addressing addr base}\n` + | Sixteen_signed -> + ` ldrsh {emit_reg dst}, {emit_addressing addr base}\n` + | Thirtytwo_unsigned -> + ` ldr {emit_wreg dst}, {emit_addressing addr base}\n` + | Thirtytwo_signed -> + ` ldrsw {emit_reg dst}, {emit_addressing addr base}\n` + | Single -> + ` ldr s7, {emit_addressing addr base}\n`; + ` fcvt {emit_reg dst}, s7\n` + | Word | Double | Double_u -> + ` ldr {emit_reg dst}, {emit_addressing addr base}\n` + end + | Lop(Istore(size, addr, _)) -> + let src = i.arg.(0) in + let base = + match addr with + | Iindexed ofs -> i.arg.(1) + | Ibased(s, ofs) -> + ` adrp {emit_reg reg_tmp1}, {emit_symbol_offset s ofs}\n`; + reg_tmp1 in + begin match size with + | Byte_unsigned | Byte_signed -> + ` strb {emit_wreg src}, {emit_addressing addr base}\n` + | Sixteen_unsigned | Sixteen_signed -> + ` strh {emit_wreg src}, {emit_addressing addr base}\n` + | Thirtytwo_unsigned | Thirtytwo_signed -> + ` str {emit_wreg src}, {emit_addressing addr base}\n` + | Single -> + ` fcvt s7, {emit_reg src}\n`; + ` str s7, {emit_addressing addr base}\n`; + | Word | Double | Double_u -> + ` str {emit_reg src}, {emit_addressing addr base}\n` + end + | Lop(Ialloc n) -> + assembly_code_for_allocation i ~n ~far:false + | Lop(Ispecific (Ifar_alloc n)) -> + assembly_code_for_allocation i ~n ~far:true + | Lop(Iintop(Icomp cmp)) -> + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` cset {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n` + | Lop(Iintop_imm(Icomp cmp, n)) -> + ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; + ` cset {emit_reg i.res.(0)}, {emit_string (name_for_comparison cmp)}\n` + | Lop(Iintop Icheckbound) -> + let lbl = bound_error_label i.dbg in + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` b.ls {emit_label lbl}\n` + | Lop(Ispecific Ifar_intop_checkbound) -> + let lbl = bound_error_label i.dbg in + let lbl2 = new_label () in + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` b.hi {emit_label lbl2}\n`; + ` b {emit_label lbl}\n`; + `{emit_label lbl2}:\n`; + | Lop(Iintop_imm(Icheckbound, n)) -> + let lbl = bound_error_label i.dbg in + ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; + ` b.ls {emit_label lbl}\n` + | Lop(Ispecific(Ifar_intop_imm_checkbound bound)) -> + let lbl = bound_error_label i.dbg in + let lbl2 = new_label () in + ` cmp {emit_reg i.arg.(0)}, #{emit_int bound}\n`; + ` b.hi {emit_label lbl2}\n`; + ` b {emit_label lbl}\n`; + `{emit_label lbl2}:\n`; + | Lop(Ispecific(Ishiftcheckbound shift)) -> + let lbl = bound_error_label i.dbg in + ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; + ` b.cs {emit_label lbl}\n` + | Lop(Ispecific(Ifar_shiftcheckbound shift)) -> + let lbl = bound_error_label i.dbg in + let lbl2 = new_label () in + ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; + ` b.lo {emit_label lbl2}\n`; + ` b {emit_label lbl}\n`; + `{emit_label lbl2}:\n`; + | Lop(Iintop Imod) -> + ` sdiv {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` msub {emit_reg i.res.(0)}, {emit_reg reg_tmp1}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n` + | Lop(Iintop Imulh) -> + ` smulh {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Iintop op) -> + let instr = name_for_int_operation op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Iintop_imm(op, n)) -> + let instr = name_for_int_operation op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n` + | Lop(Ifloatofint | Iintoffloat | Iabsf | Inegf | Ispecific Isqrtf as op) -> + let instr = (match op with + | Ifloatofint -> "scvtf" + | Iintoffloat -> "fcvtzs" + | Iabsf -> "fabs" + | Inegf -> "fneg" + | Ispecific Isqrtf -> "fsqrt" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` + | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf as op) -> + let instr = (match op with + | Iaddf -> "fadd" + | Isubf -> "fsub" + | Imulf -> "fmul" + | Idivf -> "fdiv" + | Ispecific Inegmulf -> "fnmul" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf as op)) -> + let instr = (match op with + | Imuladdf -> "fmadd" + | Inegmuladdf -> "fnmadd" + | Imulsubf -> "fmsub" + | Inegmulsubf -> "fnmsub" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}, {emit_reg i.arg.(0)}\n` + | Lop(Ispecific(Ishiftarith(op, shift))) -> + let instr = (match op with + Ishiftadd -> "add" + | Ishiftsub -> "sub") in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`; + if shift >= 0 + then `, lsl #{emit_int shift}\n` + else `, asr #{emit_int (-shift)}\n` + | Lop(Ispecific(Imuladd | Imulsub as op)) -> + let instr = (match op with + Imuladd -> "madd" + | Imulsub -> "msub" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n` + | Lop(Ispecific(Ibswap size)) -> + begin match size with + | 16 -> + ` rev16 {emit_wreg i.res.(0)}, {emit_wreg i.arg.(0)}\n`; + ` ubfm {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, #0, #15\n` + | 32 -> + ` rev {emit_wreg i.res.(0)}, {emit_wreg i.arg.(0)}\n` + | 64 -> + ` rev {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` + | _ -> + assert false + end + | Lreloadretaddr -> + () + | Lreturn -> + output_epilogue (fun () -> ` ret\n`) + | Llabel lbl -> + `{emit_label lbl}:\n` + | Lbranch lbl -> + ` b {emit_label lbl}\n` + | Lcondbranch(tst, lbl) -> + begin match tst with + | Itruetest -> + ` cbnz {emit_reg i.arg.(0)}, {emit_label lbl}\n` + | Ifalsetest -> + ` cbz {emit_reg i.arg.(0)}, {emit_label lbl}\n` + | Iinttest cmp -> + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + let comp = name_for_comparison cmp in + ` b.{emit_string comp} {emit_label lbl}\n` + | Iinttest_imm(cmp, n) -> + ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; + let comp = name_for_comparison cmp in + ` b.{emit_string comp} {emit_label lbl}\n` + | Ifloattest(cmp, neg) -> + let comp = (match (cmp, neg) with + | (Ceq, false) | (Cne, true) -> "eq" + | (Cne, false) | (Ceq, true) -> "ne" + | (Clt, false) -> "cc" + | (Clt, true) -> "cs" + | (Cle, false) -> "ls" + | (Cle, true) -> "hi" + | (Cgt, false) -> "gt" + | (Cgt, true) -> "le" + | (Cge, false) -> "ge" + | (Cge, true) -> "lt") in + ` fcmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` b.{emit_string comp} {emit_label lbl}\n` + | Ioddtest -> + ` tbnz {emit_reg i.arg.(0)}, #0, {emit_label lbl}\n` + | Ieventest -> + ` tbz {emit_reg i.arg.(0)}, #0, {emit_label lbl}\n` + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + ` cmp {emit_reg i.arg.(0)}, #1\n`; + begin match lbl0 with + None -> () + | Some lbl -> ` b.lt {emit_label lbl}\n` + end; + begin match lbl1 with + None -> () + | Some lbl -> ` b.eq {emit_label lbl}\n` + end; + begin match lbl2 with + None -> () + | Some lbl -> ` b.gt {emit_label lbl}\n` + end + | Lswitch jumptbl -> + let lbltbl = new_label() in + ` adr {emit_reg reg_tmp1}, {emit_label lbltbl}\n`; + ` add {emit_reg reg_tmp1}, {emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, lsl #2\n`; + ` br {emit_reg reg_tmp1}\n`; + `{emit_label lbltbl}:`; + for j = 0 to Array.length jumptbl - 1 do + ` b {emit_label jumptbl.(j)}\n` + done +(* Alternative: + let lbltbl = new_label() in + ` adr {emit_reg reg_tmp1}, {emit_label lbltbl}\n`; + ` ldr {emit_wreg reg_tmp2}, [{emit_reg reg_tmp1}, {emit_reg i.arg.(0)}, lsl #2]\n`; + ` add {emit_reg reg_tmp1}, {emit_wreg reg_tmp2}, sxtb\n`; + ` br {emit_reg reg_tmp1}\n`; + `{emit_label lbltbl}:\n`; + for j = 0 to Array.length jumptbl - 1 do + ` .word {emit_label jumptbl.(j)} - {emit_label lbltbl}\n` + done +*) + | Lsetuptrap lbl -> + let lblnext = new_label() in + ` adr {emit_reg reg_tmp1}, {emit_label lblnext}\n`; + ` b {emit_label lbl}\n`; + `{emit_label lblnext}:\n` + | Lpushtrap -> + stack_offset := !stack_offset + 16; + ` str {emit_reg reg_trap_ptr}, [sp, -16]!\n`; + ` str {emit_reg reg_tmp1}, [sp, #8]\n`; + cfi_adjust_cfa_offset 16; + ` mov {emit_reg reg_trap_ptr}, sp\n` + | Lpoptrap -> + ` ldr {emit_reg reg_trap_ptr}, [sp], 16\n`; + cfi_adjust_cfa_offset (-16); + stack_offset := !stack_offset - 16 + | Lraise k -> + begin match !Clflags.debug, k with + | true, (Lambda.Raise_regular | Lambda.Raise_reraise) -> + ` bl {emit_symbol "caml_raise_exn"}\n`; + `{record_frame Reg.Set.empty i.dbg}\n` + | false, _ + | true, Lambda.Raise_notrace -> + ` mov sp, {emit_reg reg_trap_ptr}\n`; + ` ldr {emit_reg reg_tmp1}, [sp, #8]\n`; + ` ldr {emit_reg reg_trap_ptr}, [sp], 16\n`; + ` br {emit_reg reg_tmp1}\n` + end + +(* Emission of an instruction sequence *) + +let rec emit_all i = + if i.desc = Lend then () else (emit_instr i; emit_all i.next) + +(* Emission of the profiling prelude *) + +let emit_profile() = () (* TODO *) +(* + match Config.system with + "linux_eabi" | "linux_eabihf" -> + ` push \{lr}\n`; + ` {emit_call "__gnu_mcount_nc"}\n` + | _ -> () +*) + +(* Emission of a function declaration *) + +let fundecl fundecl = + function_name := fundecl.fun_name; + fastcode_flag := fundecl.fun_fast; + tailrec_entry_point := new_label(); + float_literals := []; + stack_offset := 0; + call_gc_sites := []; + bound_error_sites := []; + ` .text\n`; + ` .align 3\n`; + ` .globl {emit_symbol fundecl.fun_name}\n`; + ` .type {emit_symbol fundecl.fun_name}, %function\n`; + `{emit_symbol fundecl.fun_name}:\n`; + emit_debug_info fundecl.fun_dbg; + cfi_startproc(); + if !Clflags.gprofile then emit_profile(); + let n = frame_size() in + if n > 0 then + emit_stack_adjustment (-n); + if !contains_calls then begin + cfi_offset ~reg:30 (* return address *) ~offset:(-8); + ` str x30, [sp, #{emit_int (n-8)}]\n` + end; + `{emit_label !tailrec_entry_point}:\n`; + let num_call_gc, num_check_bound = + num_call_gc_and_check_bound_points fundecl.fun_body + in + let max_out_of_line_code_offset = + max_out_of_line_code_offset fundecl.fun_body ~num_call_gc + ~num_check_bound + in + BR.relax fundecl.fun_body ~max_out_of_line_code_offset; + emit_all fundecl.fun_body; + List.iter emit_call_gc !call_gc_sites; + List.iter emit_call_bound_error !bound_error_sites; + assert (List.length !call_gc_sites = num_call_gc); + assert (List.length !bound_error_sites = num_check_bound); + cfi_endproc(); + ` .type {emit_symbol fundecl.fun_name}, %function\n`; + ` .size {emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n`; + emit_literals() + +(* Emission of data *) + +let emit_item = function + | Cglobal_symbol s -> ` .globl {emit_symbol s}\n`; + | Cdefine_symbol s -> `{emit_symbol s}:\n` + | Cdefine_label lbl -> `{emit_data_label lbl}:\n` + | Cint8 n -> ` .byte {emit_int n}\n` + | Cint16 n -> ` .short {emit_int n}\n` + | Cint32 n -> ` .long {emit_nativeint n}\n` + | Cint n -> ` .quad {emit_nativeint n}\n` + | Csingle f -> emit_float32_directive ".long" (Int32.bits_of_float f) + | Cdouble f -> emit_float64_directive ".quad" (Int64.bits_of_float f) + | Csymbol_address s -> ` .quad {emit_symbol s}\n` + | Clabel_address lbl -> ` .quad {emit_data_label lbl}\n` + | Cstring s -> emit_string_directive " .ascii " s + | Cskip n -> if n > 0 then ` .space {emit_int n}\n` + | Calign n -> ` .align {emit_int(Misc.log2 n)}\n` + +let data l = + ` .data\n`; + ` .align 3\n`; + List.iter emit_item l + +(* Beginning / end of an assembly file *) + +let begin_assembly() = + reset_debug_info(); + let lbl_begin = Compilenv.make_symbol (Some "data_begin") in + ` .data\n`; + ` .globl {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n`; + let lbl_begin = Compilenv.make_symbol (Some "code_begin") in + ` .text\n`; + ` .globl {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin}:\n` + +let end_assembly () = + let lbl_end = Compilenv.make_symbol (Some "code_end") in + ` .text\n`; + ` .globl {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + let lbl_end = Compilenv.make_symbol (Some "data_end") in + ` .data\n`; + ` .globl {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end}:\n`; + ` .long 0\n`; + let lbl = Compilenv.make_symbol (Some "frametable") in + ` .globl {emit_symbol lbl}\n`; + `{emit_symbol lbl}:\n`; + emit_frames + { efa_label = (fun lbl -> + ` .type {emit_label lbl}, %function\n`; + ` .quad {emit_label lbl}\n`); + efa_16 = (fun n -> ` .short {emit_int n}\n`); + efa_32 = (fun n -> ` .long {emit_int32 n}\n`); + efa_word = (fun n -> ` .quad {emit_int n}\n`); + efa_align = (fun n -> ` .align {emit_int(Misc.log2 n)}\n`); + efa_label_rel = (fun lbl ofs -> + ` .long {emit_label lbl} - . + {emit_int32 ofs}\n`); + efa_def_label = (fun lbl -> `{emit_label lbl}:\n`); + efa_string = (fun s -> emit_string_directive " .asciz " s) }; + ` .type {emit_symbol lbl}, %object\n`; + ` .size {emit_symbol lbl}, .-{emit_symbol lbl}\n`; + begin match Config.system with + | "linux" -> + (* Mark stack as non-executable *) + ` .section .note.GNU-stack,\"\",%progbits\n` + | _ -> () + end diff -Nru ocaml-4.01.0/asmcomp/arm64/proc.ml ocaml-4.02.3/asmcomp/arm64/proc.ml --- ocaml-4.01.0/asmcomp/arm64/proc.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/arm64/proc.ml 2014-08-18 20:26:49.000000000 +0200 @@ -0,0 +1,226 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Description of the ARM processor in 64-bit mode *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +(* Instruction selection *) + +let word_addressed = false + +(* Registers available for register allocation *) + +(* Integer register map: + x0 - x15 general purpose (caller-save) + x16, x17 temporaries (used by call veeners) + x18 platform register (reserved) + x19 - x25 general purpose (callee-save) + x26 trap pointer + x27 alloc pointer + x28 alloc limit + x29 frame pointer + x30 return address + sp / xzr stack pointer / zero register + Floating-point register map: + d0 - d7 general purpose (caller-save) + d8 - d15 general purpose (callee-save) + d16 - d31 generat purpose (caller-save) +*) + +let int_reg_name = + [| "x0"; "x1"; "x2"; "x3"; "x4"; "x5"; "x6"; "x7"; + "x8"; "x9"; "x10"; "x11"; "x12"; "x13"; "x14"; "x15"; + "x19"; "x20"; "x21"; "x22"; "x23"; "x24"; "x25"; + "x26"; "x27"; "x28"; "x16"; "x17" |] + +let float_reg_name = + [| "d0"; "d1"; "d2"; "d3"; "d4"; "d5"; "d6"; "d7"; + "d8"; "d9"; "d10"; "d11"; "d12"; "d13"; "d14"; "d15"; + "d16"; "d17"; "d18"; "d19"; "d20"; "d21"; "d22"; "d23"; + "d24"; "d25"; "d26"; "d27"; "d28"; "d29"; "d30"; "d31" |] + +let num_register_classes = 2 + +let register_class r = + match r.typ with + | (Int | Addr) -> 0 + | Float -> 1 + +let num_available_registers = + [| 23; 32 |] (* first 23 int regs allocatable; all float regs allocatable *) + +let first_available_register = + [| 0; 100 |] + +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) + +let rotate_registers = true + +(* Representation of hard registers by pseudo-registers *) + +let hard_int_reg = + let v = Array.make 28 Reg.dummy in + for i = 0 to 27 do + v.(i) <- Reg.at_location Int (Reg i) + done; + v + +let hard_float_reg = + let v = Array.make 32 Reg.dummy in + for i = 0 to 31 do + v.(i) <- Reg.at_location Float (Reg(100 + i)) + done; + v + +let all_phys_regs = + Array.append hard_int_reg hard_float_reg + +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) + +let reg_x15 = phys_reg 15 +let reg_d7 = phys_reg 107 + +let stack_slot slot ty = + Reg.at_location ty (Stack slot) + +(* Calling conventions *) + +let calling_conventions + first_int last_int first_float last_float make_stack arg = + let loc = Array.make (Array.length arg) Reg.dummy in + let int = ref first_int in + let float = ref first_float in + let ofs = ref 0 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- phys_reg !int; + incr int + end else begin + loc.(i) <- stack_slot (make_stack !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, Misc.align !ofs 16) (* keep stack 16-aligned *) + +let incoming ofs = Incoming ofs +let outgoing ofs = Outgoing ofs +let not_supported ofs = fatal_error "Proc.loc_results: cannot call" + +(* OCaml calling convention: + first integer args in r0...r15 + first float args in d0...d15 + remaining args on stack. + Return values in r0...r15 or d0...d15. *) + +let loc_arguments arg = + calling_conventions 0 15 100 115 outgoing arg +let loc_parameters arg = + let (loc, _) = calling_conventions 0 15 100 115 incoming arg in loc +let loc_results res = + let (loc, _) = calling_conventions 0 15 100 115 not_supported res in loc + +(* C calling convention: + first integer args in r0...r7 + first float args in d0...d7 + remaining args on stack. + Return values in r0...r1 or d0. *) + +let loc_external_arguments arg = + calling_conventions 0 7 100 107 outgoing arg +let loc_external_results res = + let (loc, _) = calling_conventions 0 1 100 100 not_supported res in loc + +let loc_exn_bucket = phys_reg 0 + +(* Volatile registers: none *) + +let regs_are_volatile rs = false + +(* Registers destroyed by operations *) + +let destroyed_at_c_call = + (* x19-x28, d8-d15 preserved *) + Array.of_list (List.map phys_reg + [0;1;2;3;4;5;6;7;8;9;10;11;12;13;14;15; + 100;101;102;103;104;105;106;107; + 116;117;118;119;120;121;122;123; + 124;125;126;127;128;129;130;131]) + +let destroyed_at_oper = function + | Iop(Icall_ind | Icall_imm _) | Iop(Iextcall(_, true)) -> + all_phys_regs + | Iop(Iextcall(_, false)) -> + destroyed_at_c_call + | Iop(Ialloc _) -> + [| reg_x15 |] + | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _)) -> + [| reg_d7 |] (* d7 / s7 destroyed *) + | _ -> [||] + +let destroyed_at_raise = all_phys_regs + +(* Maximal register pressure *) + +let safe_register_pressure = function + | Iextcall(_, _) -> 8 + | Ialloc _ -> 25 + | _ -> 26 + +let max_register_pressure = function + | Iextcall(_, _) -> [| 10; 8 |] + | Ialloc _ -> [| 25; 32 |] + | Iintoffloat | Ifloatofint + | Iload(Single, _) | Istore(Single, _, _) -> [| 26; 31 |] + | _ -> [| 26; 32 |] + +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) + | Ispecific(Ishiftcheckbound _) -> false + | _ -> true + +(* Layout of the stack *) + +let num_stack_slots = [| 0; 0 |] +let contains_calls = ref false + +(* Calling the assembler *) + +let assemble_file infile outfile = + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) + + +let init () = () diff -Nru ocaml-4.01.0/asmcomp/arm64/reload.ml ocaml-4.02.3/asmcomp/arm64/reload.ml --- ocaml-4.01.0/asmcomp/arm64/reload.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/arm64/reload.ml 2013-07-15 17:07:55.000000000 +0200 @@ -0,0 +1,16 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Reloading for the ARM 64 bits *) + +let fundecl f = + (new Reloadgen.reload_generic)#fundecl f diff -Nru ocaml-4.01.0/asmcomp/arm64/scheduling.ml ocaml-4.02.3/asmcomp/arm64/scheduling.ml --- ocaml-4.01.0/asmcomp/arm64/scheduling.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/arm64/scheduling.ml 2013-07-15 17:07:55.000000000 +0200 @@ -0,0 +1,18 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +let _ = let module M = Schedgen in () (* to create a dependency *) + +(* Scheduling is turned off because the processor schedules dynamically + much better than what we could do. *) + +let fundecl f = f diff -Nru ocaml-4.01.0/asmcomp/arm64/selection.ml ocaml-4.02.3/asmcomp/arm64/selection.ml --- ocaml-4.01.0/asmcomp/arm64/selection.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/arm64/selection.ml 2014-04-12 12:17:02.000000000 +0200 @@ -0,0 +1,243 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Instruction selection for the ARM processor *) + +open Arch +open Cmm +open Mach + +let is_offset chunk n = + (n >= -256 && n <= 255) (* 9 bits signed unscaled *) +|| (n >= 0 && + match chunk with (* 12 bits unsigned, scaled by chunk size *) + | Byte_unsigned | Byte_signed -> + n < 0x1000 + | Sixteen_unsigned | Sixteen_signed -> + n land 1 = 0 && n lsr 1 < 0x1000 + | Thirtytwo_unsigned | Thirtytwo_signed | Single -> + n land 3 = 0 && n lsr 2 < 0x1000 + | Word | Double | Double_u -> + n land 7 = 0 && n lsr 3 < 0x1000) + +(* An automaton to recognize ( 0+1+0* | 1+0+1* ) + + 0 1 0 + / \ / \ / \ + \ / \ / \ / + -0--> [1] --1--> [2] --0--> [3] + / + [0] + \ + -1--> [4] --0--> [5] --1--> [6] + / \ / \ / \ + \ / \ / \ / + 1 0 1 + +The accepting states are 2, 3, 5 and 6. *) + +let auto_table = [| (* accepting?, next on 0, next on 1 *) + (* state 0 *) (false, 1, 4); + (* state 1 *) (false, 1, 2); + (* state 2 *) (true, 3, 2); + (* state 3 *) (true, 3, 7); + (* state 4 *) (false, 5, 4); + (* state 5 *) (true, 5, 6); + (* state 6 *) (true, 7, 6); + (* state 7 *) (false, 7, 7) (* error state *) +|] + +let rec run_automata nbits state input = + let (acc, next0, next1) = auto_table.(state) in + if nbits <= 0 + then acc + else run_automata (nbits - 1) + (if input land 1 = 0 then next0 else next1) + (input asr 1) + +(* We are very conservative wrt what ARM64 supports: we don't support + repetitions of a 000111000 or 1110000111 pattern, just a single + pattern of this kind. *) + +let is_logical_immediate n = + n <> 0 && n <> -1 && run_automata 64 0 n + +let is_intconst = function + Cconst_int _ -> true + | _ -> false + +let inline_ops = + [ "sqrt"; "caml_bswap16_direct"; "caml_int32_direct_bswap"; + "caml_int64_direct_bswap"; "caml_nativeint_direct_bswap" ] + +let use_direct_addressing symb = + (not !Clflags.dlcode) || Compilenv.symbol_in_current_unit symb + +(* Instruction selection *) + +class selector = object(self) + +inherit Selectgen.selector_generic as super + +method is_immediate n = + let mn = -n in + n land 0xFFF = n || n land 0xFFF_000 = n + || mn land 0xFFF = mn || mn land 0xFFF_000 = mn + +method! is_simple_expr = function + (* inlined floating-point ops are simple if their arguments are *) + | Cop(Cextcall(fn, _, _, _), args) when List.mem fn inline_ops -> + List.for_all self#is_simple_expr args + | e -> super#is_simple_expr e + +method select_addressing chunk = function + | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) + when use_direct_addressing s -> + (Ibased(s, n), Ctuple []) + | Cop(Cadda, [arg; Cconst_int n]) + when is_offset chunk n -> + (Iindexed n, arg) + | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) + when is_offset chunk n -> + (Iindexed n, Cop(Cadda, [arg1; arg2])) + | Cconst_symbol s + when use_direct_addressing s -> + (Ibased(s, 0), Ctuple []) + | arg -> + (Iindexed 0, arg) + +method! select_operation op args = + match op with + (* Integer addition *) + | Caddi | Cadda -> + begin match args with + (* Add immediate *) + | [arg; Cconst_int n] | [Cconst_int n; arg] when self#is_immediate n -> + ((if n >= 0 then Iintop_imm(Iadd, n) else Iintop_imm(Isub, -n)), + [arg]) + (* Shift-add *) + | [arg1; Cop(Clsl, [arg2; Cconst_int n])] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftadd, n)), [arg1; arg2]) + | [arg1; Cop(Casr, [arg2; Cconst_int n])] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftadd, -n)), [arg1; arg2]) + | [Cop(Clsl, [arg1; Cconst_int n]); arg2] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftadd, n)), [arg2; arg1]) + | [Cop(Casr, [arg1; Cconst_int n]); arg2] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftadd, -n)), [arg2; arg1]) + (* Multiply-add *) + | [arg1; Cop(Cmuli, args2)] | [Cop(Cmuli, args2); arg1] -> + begin match self#select_operation Cmuli args2 with + | (Iintop_imm(Ilsl, l), [arg3]) -> + (Ispecific(Ishiftarith(Ishiftadd, l)), [arg1; arg3]) + | (Iintop Imul, [arg3; arg4]) -> + (Ispecific Imuladd, [arg3; arg4; arg1]) + | _ -> + super#select_operation op args + end + | _ -> + super#select_operation op args + end + (* Integer subtraction *) + | Csubi | Csuba -> + begin match args with + (* Sub immediate *) + | [arg; Cconst_int n] when self#is_immediate n -> + ((if n >= 0 then Iintop_imm(Isub, n) else Iintop_imm(Iadd, -n)), + [arg]) + (* Shift-sub *) + | [arg1; Cop(Clsl, [arg2; Cconst_int n])] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftsub, n)), [arg1; arg2]) + | [arg1; Cop(Casr, [arg2; Cconst_int n])] when n > 0 && n < 64 -> + (Ispecific(Ishiftarith(Ishiftsub, -n)), [arg1; arg2]) + (* Multiply-sub *) + | [arg1; Cop(Cmuli, args2)] -> + begin match self#select_operation Cmuli args2 with + | (Iintop_imm(Ilsl, l), [arg3]) -> + (Ispecific(Ishiftarith(Ishiftsub, l)), [arg1; arg3]) + | (Iintop Imul, [arg3; arg4]) -> + (Ispecific Imulsub, [arg3; arg4; arg1]) + | _ -> + super#select_operation op args + end + | _ -> + super#select_operation op args + end + (* Checkbounds *) + | Ccheckbound _ -> + begin match args with + | [Cop(Clsr, [arg1; Cconst_int n]); arg2] when n > 0 && n < 64 -> + (Ispecific(Ishiftcheckbound n), [arg1; arg2]) + | _ -> + super#select_operation op args + end + (* Integer multiplication *) + (* ARM does not support immediate operands for multiplication *) + | Cmuli -> + (Iintop Imul, args) + | Cmulhi -> + (Iintop Imulh, args) + (* Bitwise logical operations have a different range of immediate + operands than the other instructions *) + | Cand -> self#select_logical Iand args + | Cor -> self#select_logical Ior args + | Cxor -> self#select_logical Ixor args + (* Recognize floating-point negate and multiply *) + | Cnegf -> + begin match args with + | [Cop(Cmulf, args)] -> (Ispecific Inegmulf, args) + | _ -> super#select_operation op args + end + (* Recognize floating-point multiply and add/sub *) + | Caddf -> + begin match args with + | [arg; Cop(Cmulf, args)] | [Cop(Cmulf, args); arg] -> + (Ispecific Imuladdf, arg :: args) + | _ -> + super#select_operation op args + end + | Csubf -> + begin match args with + | [arg; Cop(Cmulf, args)] -> + (Ispecific Imulsubf, arg :: args) + | [Cop(Cmulf, args); arg] -> + (Ispecific Inegmulsubf, arg :: args) + | _ -> + super#select_operation op args + end + (* Recognize floating-point square root *) + | Cextcall("sqrt", _, _, _) -> + (Ispecific Isqrtf, args) + (* Recognize bswap instructions *) + | Cextcall("caml_bswap16_direct", _, _, _) -> + (Ispecific(Ibswap 16), args) + | Cextcall("caml_int32_direct_bswap", _, _, _) -> + (Ispecific(Ibswap 32), args) + | Cextcall(("caml_int64_direct_bswap"|"caml_nativeint_direct_bswap"), + _, _, _) -> + (Ispecific (Ibswap 64), args) + (* Other operations are regular *) + | _ -> + super#select_operation op args + +method select_logical op = function + | [arg; Cconst_int n] when is_logical_immediate n -> + (Iintop_imm(op, n), [arg]) + | [Cconst_int n; arg] when is_logical_immediate n -> + (Iintop_imm(op, n), [arg]) + | args -> + (Iintop op, args) + +end + +let fundecl f = (new selector)#emit_fundecl f diff -Nru ocaml-4.01.0/asmcomp/asmgen.ml ocaml-4.02.3/asmcomp/asmgen.ml --- ocaml-4.01.0/asmcomp/asmgen.ml 2013-06-03 20:03:59.000000000 +0200 +++ ocaml-4.02.3/asmcomp/asmgen.ml 2014-04-26 12:40:22.000000000 +0200 @@ -64,7 +64,10 @@ ++ pass_dump_if ppf dump_selection "After instruction selection" ++ Comballoc.fundecl ++ pass_dump_if ppf dump_combine "After allocation combining" + ++ CSE.fundecl + ++ pass_dump_if ppf dump_cse "After CSE" ++ liveness ppf + ++ Deadcode.fundecl ++ pass_dump_if ppf dump_live "Liveness analysis" ++ Spill.fundecl ++ liveness ppf @@ -140,3 +143,10 @@ | Assembler_error file -> fprintf ppf "Assembler error, input left in file %a" Location.print_filename file + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff -Nru ocaml-4.01.0/asmcomp/asmlibrarian.ml ocaml-4.02.3/asmcomp/asmlibrarian.ml --- ocaml-4.01.0/asmcomp/asmlibrarian.ml 2013-06-05 18:34:40.000000000 +0200 +++ ocaml-4.02.3/asmcomp/asmlibrarian.ml 2013-09-17 11:30:41.000000000 +0200 @@ -69,3 +69,10 @@ fprintf ppf "Cannot find file %s" name | Archiver_error name -> fprintf ppf "Error while creating the library %s" name + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff -Nru ocaml-4.01.0/asmcomp/asmlink.ml ocaml-4.02.3/asmcomp/asmlink.ml --- ocaml-4.01.0/asmcomp/asmlink.ml 2013-07-23 16:48:47.000000000 +0200 +++ ocaml-4.02.3/asmcomp/asmlink.ml 2015-04-27 18:04:21.000000000 +0200 @@ -33,31 +33,37 @@ (* Consistency check between interfaces and implementations *) let crc_interfaces = Consistbl.create () +let interfaces = ref ([] : string list) let crc_implementations = Consistbl.create () -let extra_implementations = ref ([] : string list) +let implementations = ref ([] : string list) let implementations_defined = ref ([] : (string * string) list) let cmx_required = ref ([] : string list) let check_consistency file_name unit crc = begin try List.iter - (fun (name, crc) -> - if name = unit.ui_name - then Consistbl.set crc_interfaces name crc file_name - else Consistbl.check crc_interfaces name crc file_name) + (fun (name, crco) -> + interfaces := name :: !interfaces; + match crco with + None -> () + | Some crc -> + if name = unit.ui_name + then Consistbl.set crc_interfaces name crc file_name + else Consistbl.check crc_interfaces name crc file_name) unit.ui_imports_cmi with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_interface(name, user, auth))) end; begin try List.iter - (fun (name, crc) -> - if crc <> cmx_not_found_crc then - Consistbl.check crc_implementations name crc file_name - else if List.mem name !cmx_required then - raise(Error(Missing_cmx(file_name, name))) - else - extra_implementations := name :: !extra_implementations) + (fun (name, crco) -> + implementations := name :: !implementations; + match crco with + None -> + if List.mem name !cmx_required then + raise(Error(Missing_cmx(file_name, name))) + | Some crc -> + Consistbl.check crc_implementations name crc file_name) unit.ui_imports_cmx with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_implementation(name, user, auth))) @@ -67,6 +73,7 @@ raise (Error(Multiple_definition(unit.ui_name, file_name, source))) with Not_found -> () end; + implementations := unit.ui_name :: !implementations; Consistbl.set crc_implementations unit.ui_name crc file_name; implementations_defined := (unit.ui_name, file_name) :: !implementations_defined; @@ -74,13 +81,9 @@ cmx_required := unit.ui_name :: !cmx_required let extract_crc_interfaces () = - Consistbl.extract crc_interfaces + Consistbl.extract !interfaces crc_interfaces let extract_crc_implementations () = - List.fold_left - (fun ncl n -> - if List.mem_assoc n ncl then ncl else (n, cmx_not_found_crc) :: ncl) - (Consistbl.extract crc_implementations) - !extra_implementations + Consistbl.extract !implementations crc_implementations (* Add C objects and options and "custom" info from a library descriptor. See bytecomp/bytelink.ml for comments on the order of C objects. *) @@ -88,10 +91,11 @@ let lib_ccobjs = ref [] let lib_ccopts = ref [] -let add_ccobjs l = +let add_ccobjs origin l = if not !Clflags.no_auto_link then begin lib_ccobjs := l.lib_ccobjs @ !lib_ccobjs; - lib_ccopts := l.lib_ccopts @ !lib_ccopts + let replace_origin = Misc.replace_substring ~before:"$CAMLORIGIN" ~after:origin in + lib_ccopts := List.map replace_origin l.lib_ccopts @ !lib_ccopts end let runtime_lib () = @@ -176,7 +180,7 @@ | Library (file_name,infos) -> (* This is an archive file. Each unit contained in it will be linked in only if needed. *) - add_ccobjs infos; + add_ccobjs (Filename.dirname file_name) infos; List.fold_right (fun (info, crc) reqd -> if info.ui_force_link @@ -206,18 +210,22 @@ compile_phrase (Cmmgen.entry_point name_list); let units = List.map (fun (info,_,_) -> info) units_list in List.iter compile_phrase (Cmmgen.generic_functions false units); - Array.iter - (fun name -> compile_phrase (Cmmgen.predef_exception name)) + Array.iteri + (fun i name -> compile_phrase (Cmmgen.predef_exception i name)) Runtimedef.builtin_exceptions; compile_phrase (Cmmgen.global_table name_list); compile_phrase (Cmmgen.globals_map (List.map (fun (unit,_,crc) -> - try (unit.ui_name, List.assoc unit.ui_name unit.ui_imports_cmi, - crc, - unit.ui_defines) - with Not_found -> assert false) + let intf_crc = + try + match List.assoc unit.ui_name unit.ui_imports_cmi with + None -> assert false + | Some crc -> crc + with Not_found -> assert false + in + (unit.ui_name, intf_crc, crc, unit.ui_defines)) units_list)); compile_phrase(Cmmgen.data_segment_table ("_startup" :: name_list)); compile_phrase(Cmmgen.code_segment_table ("_startup" :: name_list)); @@ -277,12 +285,13 @@ let call_linker file_list startup_file output_name = let main_dll = !Clflags.output_c_object && Filename.check_suffix output_name Config.ext_dll + and main_obj_runtime = !Clflags.output_complete_object in let files = startup_file :: (List.rev file_list) in let files, c_lib = - if (not !Clflags.output_c_object) || main_dll then + if (not !Clflags.output_c_object) || main_dll || main_obj_runtime then files @ (List.rev !Clflags.ccobjs) @ runtime_lib (), - (if !Clflags.nopervasives then "" else Config.native_c_libraries) + (if !Clflags.nopervasives || main_obj_runtime then "" else Config.native_c_libraries) else files, "" in @@ -390,3 +399,18 @@ Location.print_filename filename name Location.print_filename filename name + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + +let reset () = + Consistbl.clear crc_interfaces; + Consistbl.clear crc_implementations; + implementations_defined := []; + cmx_required := []; + interfaces := []; + implementations := [] diff -Nru ocaml-4.01.0/asmcomp/asmlink.mli ocaml-4.02.3/asmcomp/asmlink.mli --- ocaml-4.01.0/asmcomp/asmlink.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/asmlink.mli 2014-05-09 14:01:21.000000000 +0200 @@ -20,9 +20,10 @@ val call_linker_shared: string list -> string -> unit +val reset : unit -> unit val check_consistency: string -> Cmx_format.unit_infos -> Digest.t -> unit -val extract_crc_interfaces: unit -> (string * Digest.t) list -val extract_crc_implementations: unit -> (string * Digest.t) list +val extract_crc_interfaces: unit -> (string * Digest.t option) list +val extract_crc_implementations: unit -> (string * Digest.t option) list type error = File_not_found of string diff -Nru ocaml-4.01.0/asmcomp/asmpackager.ml ocaml-4.02.3/asmcomp/asmpackager.ml --- ocaml-4.01.0/asmcomp/asmpackager.ml 2013-07-23 16:48:47.000000000 +0200 +++ ocaml-4.02.3/asmcomp/asmpackager.ml 2014-05-07 02:34:20.000000000 +0200 @@ -130,7 +130,7 @@ List.flatten (List.map (fun info -> info.ui_defines) units) @ [ui.ui_symbol]; ui_imports_cmi = - (ui.ui_name, Env.crc_of_unit ui.ui_name) :: + (ui.ui_name, Some (Env.crc_of_unit ui.ui_name)) :: filter(Asmlink.extract_crc_interfaces()); ui_imports_cmx = filter(Asmlink.extract_crc_implementations()); @@ -161,7 +161,7 @@ (* The entry point *) -let package_files ppf files targetcmx = +let package_files ppf initial_env files targetcmx = let files = List.map (fun f -> @@ -177,7 +177,8 @@ (* Set the name of the current compunit *) Compilenv.reset ?packname:!Clflags.for_package targetname; try - let coercion = Typemod.package_units files targetcmi targetname in + let coercion = + Typemod.package_units initial_env files targetcmi targetname in package_object_files ppf files targetcmx targetobj targetname coercion with x -> remove_file targetcmx; remove_file targetobj; @@ -204,3 +205,10 @@ fprintf ppf "Error while assembling %s" file | Linking_error -> fprintf ppf "Error during partial linking" + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff -Nru ocaml-4.01.0/asmcomp/asmpackager.mli ocaml-4.02.3/asmcomp/asmpackager.mli --- ocaml-4.01.0/asmcomp/asmpackager.mli 2013-04-29 16:57:38.000000000 +0200 +++ ocaml-4.02.3/asmcomp/asmpackager.mli 2014-04-29 13:56:17.000000000 +0200 @@ -13,7 +13,7 @@ (* "Package" a set of .cmx/.o files into one .cmx/.o file having the original compilation units as sub-modules. *) -val package_files: Format.formatter -> string list -> string -> unit +val package_files: Format.formatter -> Env.t -> string list -> string -> unit type error = Illegal_renaming of string * string * string diff -Nru ocaml-4.01.0/asmcomp/branch_relaxation_intf.ml ocaml-4.02.3/asmcomp/branch_relaxation_intf.ml --- ocaml-4.01.0/asmcomp/branch_relaxation_intf.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/branch_relaxation_intf.ml 2015-06-10 17:58:19.000000000 +0200 @@ -0,0 +1,64 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +module type S = sig + (* The distance between two instructions, in arbitrary units (typically + the natural word size of instructions). *) + type distance = int + + module Cond_branch : sig + (* The various types of conditional branches for a given target that + may require relaxation. *) + type t + + (* All values of type [t] that the emitter may produce. *) + val all : t list + + (* If [max_displacement branch] is [n] then [branch] is assumed to + reach any address in the range [pc - n, pc + n] (inclusive), after + the [pc] of the branch has been adjusted by [offset_pc_at_branch] + (see below). *) + val max_displacement : t -> distance + + (* Which variety of conditional branch may be produced by the emitter for a + given instruction description. For the moment we assume that only one + such variety per instruction description is needed. + + N.B. The only instructions supported are the following: + - Lop (Ialloc _) + - Lop (Iintop Icheckbound) + - Lop (Iintop_imm (Icheckbound, _)) + - Lop (Ispecific _) + - Lcondbranch (_, _) + - Lcondbranch3 (_, _, _) + [classify_instr] is expected to return [None] when called on any + instruction not in this list. *) + val classify_instr : Linearize.instruction_desc -> t option + end + + (* The value to be added to the program counter (in [distance] units) + when it is at a branch instruction, prior to calculating the distance + to a branch target. *) + val offset_pc_at_branch : distance + + (* The maximum size of a given instruction. *) + val instr_size : Linearize.instruction_desc -> distance + + (* Insertion of target-specific code to relax operations that cannot be + relaxed generically. It is assumed that these rewrites do not change + the size of out-of-line code (cf. branch_relaxation.mli). *) + val relax_allocation : num_words:int -> Linearize.instruction_desc + val relax_intop_checkbound : unit -> Linearize.instruction_desc + val relax_intop_imm_checkbound : bound:int -> Linearize.instruction_desc + val relax_specific_op : Arch.specific_operation -> Linearize.instruction_desc +end diff -Nru ocaml-4.01.0/asmcomp/branch_relaxation.ml ocaml-4.02.3/asmcomp/branch_relaxation.ml --- ocaml-4.01.0/asmcomp/branch_relaxation.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/branch_relaxation.ml 2015-06-10 17:58:19.000000000 +0200 @@ -0,0 +1,138 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +open Mach +open Linearize + +module Make (T : Branch_relaxation_intf.S) = struct + let label_map code = + let map = Hashtbl.create 37 in + let rec fill_map pc instr = + match instr.desc with + | Lend -> (pc, map) + | Llabel lbl -> Hashtbl.add map lbl pc; fill_map pc instr.next + | op -> fill_map (pc + T.instr_size op) instr.next + in + fill_map 0 code + + let branch_overflows map pc_branch lbl_dest max_branch_offset = + let pc_dest = Hashtbl.find map lbl_dest in + let delta = pc_dest - (pc_branch + T.offset_pc_at_branch) in + delta <= -max_branch_offset || delta >= max_branch_offset + + let opt_branch_overflows map pc_branch opt_lbl_dest max_branch_offset = + match opt_lbl_dest with + | None -> false + | Some lbl_dest -> + branch_overflows map pc_branch lbl_dest max_branch_offset + + let instr_overflows ~code_size ~max_out_of_line_code_offset instr map pc = + match T.Cond_branch.classify_instr instr.desc with + | None -> false + | Some branch -> + let max_branch_offset = + (* Remember to cut some slack for multi-word instructions (in the + [Linearize] sense of the word) where the branch can be anywhere in + the middle. 12 words of slack is plenty. *) + T.Cond_branch.max_displacement branch - 12 + in + match instr.desc with + | Lop (Ialloc _) + | Lop (Iintop Icheckbound) + | Lop (Iintop_imm (Icheckbound, _)) + | Lop (Ispecific _) -> + (* We assume that any branches eligible for relaxation generated + by these instructions only branch forward. We further assume + that any of these may branch to an out-of-line code block. *) + code_size + max_out_of_line_code_offset - pc >= max_branch_offset + | Lcondbranch (_, lbl) -> + branch_overflows map pc lbl max_branch_offset + | Lcondbranch3 (lbl0, lbl1, lbl2) -> + opt_branch_overflows map pc lbl0 max_branch_offset + || opt_branch_overflows map pc lbl1 max_branch_offset + || opt_branch_overflows map pc lbl2 max_branch_offset + | _ -> + Misc.fatal_error "Unsupported instruction for branch relaxation" + + let fixup_branches ~code_size ~max_out_of_line_code_offset map code = + let expand_optbranch lbl n arg next = + match lbl with + | None -> next + | Some l -> + instr_cons (Lcondbranch (Iinttest_imm (Isigned Cmm.Ceq, n), l)) + arg [||] next + in + let rec fixup did_fix pc instr = + match instr.desc with + | Lend -> did_fix + | _ -> + let overflows = + instr_overflows ~code_size ~max_out_of_line_code_offset instr map pc + in + if not overflows then + fixup did_fix (pc + T.instr_size instr.desc) instr.next + else + match instr.desc with + | Lop (Ialloc num_words) -> + instr.desc <- T.relax_allocation ~num_words; + fixup true (pc + T.instr_size instr.desc) instr.next + | Lop (Iintop Icheckbound) -> + instr.desc <- T.relax_intop_checkbound (); + fixup true (pc + T.instr_size instr.desc) instr.next + | Lop (Iintop_imm (Icheckbound, bound)) -> + instr.desc <- T.relax_intop_imm_checkbound ~bound; + fixup true (pc + T.instr_size instr.desc) instr.next + | Lop (Ispecific specific) -> + instr.desc <- T.relax_specific_op specific; + fixup true (pc + T.instr_size instr.desc) instr.next + | Lcondbranch (test, lbl) -> + let lbl2 = new_label() in + let cont = + instr_cons (Lbranch lbl) [||] [||] + (instr_cons (Llabel lbl2) [||] [||] instr.next) + in + instr.desc <- Lcondbranch (invert_test test, lbl2); + instr.next <- cont; + fixup true (pc + T.instr_size instr.desc) instr.next + | Lcondbranch3 (lbl0, lbl1, lbl2) -> + let cont = + expand_optbranch lbl0 0 instr.arg + (expand_optbranch lbl1 1 instr.arg + (expand_optbranch lbl2 2 instr.arg instr.next)) + in + instr.desc <- cont.desc; + instr.next <- cont.next; + fixup true pc instr + | _ -> + (* Any other instruction has already been rejected in + [instr_overflows] above. + We can *never* get here. *) + assert false + in + fixup false 0 code + + (* Iterate branch expansion till all conditional branches are OK *) + + let rec relax code ~max_out_of_line_code_offset = + let min_of_max_branch_offsets = + List.fold_left (fun min_of_max_branch_offsets branch -> + min min_of_max_branch_offsets + (T.Cond_branch.max_displacement branch)) + max_int T.Cond_branch.all + in + let (code_size, map) = label_map code in + if code_size >= min_of_max_branch_offsets + && fixup_branches ~code_size ~max_out_of_line_code_offset map code + then relax code ~max_out_of_line_code_offset + else () +end diff -Nru ocaml-4.01.0/asmcomp/branch_relaxation.mli ocaml-4.02.3/asmcomp/branch_relaxation.mli --- ocaml-4.01.0/asmcomp/branch_relaxation.mli 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/branch_relaxation.mli 2015-06-10 17:58:19.000000000 +0200 @@ -0,0 +1,26 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Fix up conditional branches that exceed hardware-allowed ranges. *) + +module Make (T : Branch_relaxation_intf.S) : sig + val relax + : Linearize.instruction + (* [max_offset_of_out_of_line_code] specifies the furthest distance, + measured from the first address immediately after the last instruction + of the function, that may be branched to from within the function in + order to execute "out of line" code blocks such as call GC and + bounds check points. *) + -> max_out_of_line_code_offset:T.distance + -> unit +end diff -Nru ocaml-4.01.0/asmcomp/clambda.ml ocaml-4.02.3/asmcomp/clambda.ml --- ocaml-4.01.0/asmcomp/clambda.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/clambda.ml 2014-05-25 18:45:09.000000000 +0200 @@ -18,9 +18,23 @@ type function_label = string +type ustructured_constant = + | Uconst_float of float + | Uconst_int32 of int32 + | Uconst_int64 of int64 + | Uconst_nativeint of nativeint + | Uconst_block of int * uconstant list + | Uconst_float_array of float list + | Uconst_string of string + +and uconstant = + | Uconst_ref of string * ustructured_constant + | Uconst_int of int + | Uconst_ptr of int + type ulambda = Uvar of Ident.t - | Uconst of structured_constant * string option + | Uconst of uconstant | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of ufunction list * ulambda list @@ -29,6 +43,7 @@ | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch + | Ustringswitch of ulambda * (string * ulambda) list * ulambda option | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda | Utrywith of ulambda * Ident.t * ulambda @@ -59,7 +74,9 @@ { fun_label: function_label; (* Label of direct entry point *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Ident.t list * ulambda) option } + mutable fun_inline: (Ident.t list * ulambda) option; + mutable fun_float_const_prop: bool (* Can propagate FP consts *) + } (* Approximation of values *) @@ -67,5 +84,67 @@ Value_closure of function_description * value_approximation | Value_tuple of value_approximation array | Value_unknown - | Value_integer of int - | Value_constptr of int + | Value_const of uconstant + | Value_global_field of string * int + +(* Comparison functions for constants. We must not use Pervasives.compare + because it compares "0.0" and "-0.0" equal. (PR#6442) *) + +let compare_floats x1 x2 = + Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2) + +let rec compare_float_lists l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | h1::t1, h2::t2 -> + let c = compare_floats h1 h2 in + if c <> 0 then c else compare_float_lists t1 t2 + +let compare_constants c1 c2 = + match c1, c2 with + | Uconst_ref(lbl1, c1), Uconst_ref(lbl2, c2) -> String.compare lbl1 lbl2 + (* Same labels -> same constants. + Different labels -> different constants, even if the contents + match, because of string constants that must not be + reshared. *) + | Uconst_int n1, Uconst_int n2 -> Pervasives.compare n1 n2 + | Uconst_ptr n1, Uconst_ptr n2 -> Pervasives.compare n1 n2 + | Uconst_ref _, _ -> -1 + | Uconst_int _, Uconst_ref _ -> 1 + | Uconst_int _, Uconst_ptr _ -> -1 + | Uconst_ptr _, _ -> 1 + +let rec compare_constant_lists l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _::_ -> -1 + | _::_, [] -> 1 + | h1::t1, h2::t2 -> + let c = compare_constants h1 h2 in + if c <> 0 then c else compare_constant_lists t1 t2 + +let rank_structured_constant = function + | Uconst_float _ -> 0 + | Uconst_int32 _ -> 1 + | Uconst_int64 _ -> 2 + | Uconst_nativeint _ -> 3 + | Uconst_block _ -> 4 + | Uconst_float_array _ -> 5 + | Uconst_string _ -> 6 + +let compare_structured_constants c1 c2 = + match c1, c2 with + | Uconst_float x1, Uconst_float x2 -> compare_floats x1 x2 + | Uconst_int32 x1, Uconst_int32 x2 -> Int32.compare x1 x2 + | Uconst_int64 x1, Uconst_int64 x2 -> Int64.compare x1 x2 + | Uconst_nativeint x1, Uconst_nativeint x2 -> Nativeint.compare x1 x2 + | Uconst_block(t1, l1), Uconst_block(t2, l2) -> + let c = t1 - t2 (* no overflow possible here *) in + if c <> 0 then c else compare_constant_lists l1 l2 + | Uconst_float_array l1, Uconst_float_array l2 -> + compare_float_lists l1 l2 + | Uconst_string s1, Uconst_string s2 -> String.compare s1 s2 + | _, _ -> rank_structured_constant c1 - rank_structured_constant c2 + (* no overflow possible here *) diff -Nru ocaml-4.01.0/asmcomp/clambda.mli ocaml-4.02.3/asmcomp/clambda.mli --- ocaml-4.01.0/asmcomp/clambda.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/clambda.mli 2014-05-25 18:45:09.000000000 +0200 @@ -18,9 +18,23 @@ type function_label = string +type ustructured_constant = + | Uconst_float of float + | Uconst_int32 of int32 + | Uconst_int64 of int64 + | Uconst_nativeint of nativeint + | Uconst_block of int * uconstant list + | Uconst_float_array of float list + | Uconst_string of string + +and uconstant = + | Uconst_ref of string * ustructured_constant + | Uconst_int of int + | Uconst_ptr of int + type ulambda = Uvar of Ident.t - | Uconst of structured_constant * string option + | Uconst of uconstant | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of ufunction list * ulambda list @@ -29,6 +43,7 @@ | Uletrec of (Ident.t * ulambda) list * ulambda | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch + | Ustringswitch of ulambda * (string * ulambda) list * ulambda option | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda | Utrywith of ulambda * Ident.t * ulambda @@ -59,7 +74,9 @@ { fun_label: function_label; (* Label of direct entry point *) fun_arity: int; (* Number of arguments *) mutable fun_closed: bool; (* True if environment not used *) - mutable fun_inline: (Ident.t list * ulambda) option } + mutable fun_inline: (Ident.t list * ulambda) option; + mutable fun_float_const_prop: bool (* Can propagate FP consts *) + } (* Approximation of values *) @@ -67,5 +84,12 @@ Value_closure of function_description * value_approximation | Value_tuple of value_approximation array | Value_unknown - | Value_integer of int - | Value_constptr of int + | Value_const of uconstant + | Value_global_field of string * int + +(* Comparison functions for constants *) + +val compare_structured_constants: + ustructured_constant -> ustructured_constant -> int +val compare_constants: + uconstant -> uconstant -> int diff -Nru ocaml-4.01.0/asmcomp/closure.ml ocaml-4.02.3/asmcomp/closure.ml --- ocaml-4.01.0/asmcomp/closure.ml 2013-06-07 13:32:13.000000000 +0200 +++ ocaml-4.02.3/asmcomp/closure.ml 2014-08-18 20:26:49.000000000 +0200 @@ -19,6 +19,14 @@ open Switch open Clambda +module Storer = + Switch.Store + (struct + type t = lambda + type key = lambda + let make_key = Lambda.make_key + end) + (* Auxiliaries for compiling functions *) let rec split_list n l = @@ -48,7 +56,7 @@ let occurs_var var u = let rec occurs = function Uvar v -> v = var - | Uconst (cst,_) -> false + | Uconst _ -> false | Udirect_apply(lbl, args, _) -> List.exists occurs args | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args | Uclosure(fundecls, clos) -> List.exists occurs clos @@ -60,6 +68,10 @@ | Uswitch(arg, s) -> occurs arg || occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks + | Ustringswitch(arg,sw,d) -> + occurs arg || + List.exists (fun (_,e) -> occurs e) sw || + (match d with None -> false | Some d -> occurs d) | Ustaticfail (_, args) -> List.exists occurs args | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr | Utrywith(body, exn, hdlr) -> occurs body || occurs hdlr @@ -81,6 +93,52 @@ true in occurs u +(* Split a function with default parameters into a wrapper and an + inner function. The wrapper fills in missing optional parameters + with their default value and tail-calls the inner function. The + wrapper can then hopefully be inlined on most call sites to avoid + the overhead associated with boxing an optional argument with a + 'Some' constructor, only to deconstruct it immediately in the + function's body. *) + +let split_default_wrapper fun_id kind params body = + let rec aux map = function + | Llet(Strict, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when + Ident.name optparam = "*opt*" && List.mem optparam params + && not (List.mem_assoc optparam map) + -> + let wrapper_body, inner = aux ((optparam, id) :: map) rest in + Llet(Strict, id, def, wrapper_body), inner + | _ when map = [] -> raise Exit + | body -> + (* Check that those *opt* identifiers don't appear in the remaining + body. This should not appear, but let's be on the safe side. *) + let fv = Lambda.free_variables body in + List.iter (fun (id, _) -> if IdentSet.mem id fv then raise Exit) map; + + let inner_id = Ident.create (Ident.name fun_id ^ "_inner") in + let map_param p = try List.assoc p map with Not_found -> p in + let args = List.map (fun p -> Lvar (map_param p)) params in + let wrapper_body = Lapply (Lvar inner_id, args, Location.none) in + + let inner_params = List.map map_param params in + let new_ids = List.map Ident.rename inner_params in + let subst = List.fold_left2 + (fun s id new_id -> + Ident.add id (Lvar new_id) s) + Ident.empty inner_params new_ids + in + let body = Lambda.subst_lambda subst body in + let inner_fun = Lfunction(Curried, new_ids, body) in + (wrapper_body, (inner_id, inner_fun)) + in + try + let wrapper_body, inner = aux [] body in + [(fun_id, Lfunction(kind, params, wrapper_body)); inner] + with Exit -> + [(fun_id, Lfunction(kind, params, body))] + + (* Determine whether the estimated size of a clambda term is below some threshold *) @@ -96,7 +154,7 @@ | Psetfloatfield f -> 1 | Pduprecord _ -> 10 + List.length args | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args - | Praise -> 4 + | Praise _ -> 4 | Pstringlength -> 5 | Pstringrefs | Pstringsets -> 6 | Pmakearray kind -> 5 + List.length args @@ -118,14 +176,7 @@ if !size > threshold then raise Exit; match lam with Uvar v -> () - | Uconst( - (Const_base(Const_int _ | Const_char _ | Const_float _ | - Const_int32 _ | Const_int64 _ | Const_nativeint _) | - Const_pointer _), _) -> incr size -(* Structured Constants are now emitted during closure conversion. *) - | Uconst (_, Some _) -> incr size - | Uconst _ -> - raise Exit (* avoid duplication of structured constants *) + | Uconst _ -> incr size | Udirect_apply(fn, args, _) -> size := !size + 4; lambda_list_size args | Ugeneric_apply(fn, args, _) -> @@ -147,6 +198,15 @@ lambda_size lam; lambda_array_size cases.us_actions_consts ; lambda_array_size cases.us_actions_blocks + | Ustringswitch (lam,sw,d) -> + lambda_size lam ; + (* as ifthenelse *) + List.iter + (fun (_,lam) -> + size := !size+2 ; + lambda_size lam) + sw ; + Misc.may lambda_size d | Ustaticfail (_,args) -> lambda_list_size args | Ucatch(_, _, body, handler) -> incr size; lambda_size body; lambda_size handler @@ -180,17 +240,20 @@ Uvar v -> true | Uconst _ -> true | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ | - Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets | + Pccall _ | Praise _ | Poffsetref _ | Pstringsetu | Pstringsets | Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false | Uprim(p, args, _) -> List.for_all is_pure_clambda args | _ -> false -(* Simplify primitive operations on integers *) +(* Simplify primitive operations on known arguments *) -let make_const_int n = (Uconst(Const_base(Const_int n), None), Value_integer n) -let make_const_ptr n = (Uconst(Const_pointer n, None), Value_constptr n) +let make_const c = (Uconst c, Value_const c) +let make_const_ref c = + make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c, c)) +let make_const_int n = make_const (Uconst_int n) +let make_const_ptr n = make_const (Uconst_ptr n) let make_const_bool b = make_const_ptr(if b then 1 else 0) -let make_comparison cmp (x: int) (y: int) = +let make_comparison cmp x y = make_const_bool (match cmp with Ceq -> x = y @@ -199,75 +262,258 @@ | Cgt -> x > y | Cle -> x <= y | Cge -> x >= y) +let make_const_float n = make_const_ref (Uconst_float n) +let make_const_natint n = make_const_ref (Uconst_nativeint n) +let make_const_int32 n = make_const_ref (Uconst_int32 n) +let make_const_int64 n = make_const_ref (Uconst_int64 n) -let simplif_prim_pure p (args, approxs) dbg = +(* The [fpc] parameter is true if constant propagation of + floating-point computations is allowed *) + +let simplif_arith_prim_pure fpc p (args, approxs) dbg = + let default = (Uprim(p, args, dbg), Value_unknown) in match approxs with - [Value_integer x] -> + (* int (or enumerated type) *) + | [ Value_const(Uconst_int n1 | Uconst_ptr n1) ] -> begin match p with - Pidentity -> make_const_int x - | Pnegint -> make_const_int (-x) - | Pbswap16 -> - make_const_int (((x land 0xff) lsl 8) lor - ((x land 0xff00) lsr 8)) - | Poffsetint y -> make_const_int (x + y) - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Pnot -> make_const_bool (n1 = 0) + | Pnegint -> make_const_int (- n1) + | Poffsetint n -> make_const_int (n + n1) + | Pfloatofint when fpc -> make_const_float (float_of_int n1) + | Pbintofint Pnativeint -> make_const_natint (Nativeint.of_int n1) + | Pbintofint Pint32 -> make_const_int32 (Int32.of_int n1) + | Pbintofint Pint64 -> make_const_int64 (Int64.of_int n1) + | Pbswap16 -> make_const_int (((n1 land 0xff) lsl 8) + lor ((n1 land 0xff00) lsr 8)) + | _ -> default end - | [Value_integer x; Value_integer y] -> + (* int (or enumerated type), int (or enumerated type) *) + | [ Value_const(Uconst_int n1 | Uconst_ptr n1); + Value_const(Uconst_int n2 | Uconst_ptr n2) ] -> begin match p with - Paddint -> make_const_int(x + y) - | Psubint -> make_const_int(x - y) - | Pmulint -> make_const_int(x * y) - | Pdivint when y <> 0 -> make_const_int(x / y) - | Pmodint when y <> 0 -> make_const_int(x mod y) - | Pandint -> make_const_int(x land y) - | Porint -> make_const_int(x lor y) - | Pxorint -> make_const_int(x lxor y) - | Plslint -> make_const_int(x lsl y) - | Plsrint -> make_const_int(x lsr y) - | Pasrint -> make_const_int(x asr y) - | Pintcomp cmp -> make_comparison cmp x y - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Psequand -> make_const_bool (n1 <> 0 && n2 <> 0) + | Psequor -> make_const_bool (n1 <> 0 || n2 <> 0) + | Paddint -> make_const_int (n1 + n2) + | Psubint -> make_const_int (n1 - n2) + | Pmulint -> make_const_int (n1 * n2) + | Pdivint when n2 <> 0 -> make_const_int (n1 / n2) + | Pmodint when n2 <> 0 -> make_const_int (n1 mod n2) + | Pandint -> make_const_int (n1 land n2) + | Porint -> make_const_int (n1 lor n2) + | Pxorint -> make_const_int (n1 lxor n2) + | Plslint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_int (n1 lsl n2) + | Plsrint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_int (n1 lsr n2) + | Pasrint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_int (n1 asr n2) + | Pintcomp c -> make_comparison c n1 n2 + | _ -> default end - | [Value_constptr x] -> + (* float *) + | [Value_const(Uconst_ref(_, Uconst_float n1))] when fpc -> begin match p with - Pidentity -> make_const_ptr x - | Pnot -> make_const_bool(x = 0) - | Pisint -> make_const_bool true - | Pctconst c -> - begin - match c with - | Big_endian -> make_const_bool Arch.big_endian - | Word_size -> make_const_int (8*Arch.size_int) - | Ostype_unix -> make_const_bool (Sys.os_type = "Unix") - | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32") - | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin") - end - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Pintoffloat -> make_const_int (int_of_float n1) + | Pnegfloat -> make_const_float (-. n1) + | Pabsfloat -> make_const_float (abs_float n1) + | _ -> default end - | [Value_constptr x; Value_constptr y] -> + (* float, float *) + | [Value_const(Uconst_ref(_, Uconst_float n1)); + Value_const(Uconst_ref(_, Uconst_float n2))] when fpc -> begin match p with - Psequand -> make_const_bool(x <> 0 && y <> 0) - | Psequor -> make_const_bool(x <> 0 || y <> 0) - | Pintcomp cmp -> make_comparison cmp x y - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Paddfloat -> make_const_float (n1 +. n2) + | Psubfloat -> make_const_float (n1 -. n2) + | Pmulfloat -> make_const_float (n1 *. n2) + | Pdivfloat -> make_const_float (n1 /. n2) + | Pfloatcomp c -> make_comparison c n1 n2 + | _ -> default end - | [Value_constptr x; Value_integer y] -> + (* nativeint *) + | [Value_const(Uconst_ref(_, Uconst_nativeint n))] -> begin match p with - | Pintcomp cmp -> make_comparison cmp x y - | _ -> (Uprim(p, args, dbg), Value_unknown) + | Pintofbint Pnativeint -> make_const_int (Nativeint.to_int n) + | Pcvtbint(Pnativeint, Pint32) -> make_const_int32 (Nativeint.to_int32 n) + | Pcvtbint(Pnativeint, Pint64) -> make_const_int64 (Int64.of_nativeint n) + | Pnegbint Pnativeint -> make_const_natint (Nativeint.neg n) + | _ -> default end - | [Value_integer x; Value_constptr y] -> + (* nativeint, nativeint *) + | [Value_const(Uconst_ref(_, Uconst_nativeint n1)); + Value_const(Uconst_ref(_, Uconst_nativeint n2))] -> begin match p with - | Pintcomp cmp -> make_comparison cmp x y + | Paddbint Pnativeint -> make_const_natint (Nativeint.add n1 n2) + | Psubbint Pnativeint -> make_const_natint (Nativeint.sub n1 n2) + | Pmulbint Pnativeint -> make_const_natint (Nativeint.mul n1 n2) + | Pdivbint Pnativeint when n2 <> 0n -> + make_const_natint (Nativeint.div n1 n2) + | Pmodbint Pnativeint when n2 <> 0n -> + make_const_natint (Nativeint.rem n1 n2) + | Pandbint Pnativeint -> make_const_natint (Nativeint.logand n1 n2) + | Porbint Pnativeint -> make_const_natint (Nativeint.logor n1 n2) + | Pxorbint Pnativeint -> make_const_natint (Nativeint.logxor n1 n2) + | Pbintcomp(Pnativeint, c) -> make_comparison c n1 n2 + | _ -> default + end + (* nativeint, int *) + | [Value_const(Uconst_ref(_, Uconst_nativeint n1)); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_natint (Nativeint.shift_left n1 n2) + | Plsrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_natint (Nativeint.shift_right_logical n1 n2) + | Pasrbint Pnativeint when 0 <= n2 && n2 < 8 * Arch.size_int -> + make_const_natint (Nativeint.shift_right n1 n2) + | _ -> default + end + (* int32 *) + | [Value_const(Uconst_ref(_, Uconst_int32 n))] -> + begin match p with + | Pintofbint Pint32 -> make_const_int (Int32.to_int n) + | Pcvtbint(Pint32, Pnativeint) -> make_const_natint (Nativeint.of_int32 n) + | Pcvtbint(Pint32, Pint64) -> make_const_int64 (Int64.of_int32 n) + | Pnegbint Pint32 -> make_const_int32 (Int32.neg n) + | _ -> default + end + (* int32, int32 *) + | [Value_const(Uconst_ref(_, Uconst_int32 n1)); + Value_const(Uconst_ref(_, Uconst_int32 n2))] -> + begin match p with + | Paddbint Pint32 -> make_const_int32 (Int32.add n1 n2) + | Psubbint Pint32 -> make_const_int32 (Int32.sub n1 n2) + | Pmulbint Pint32 -> make_const_int32 (Int32.mul n1 n2) + | Pdivbint Pint32 when n2 <> 0l -> make_const_int32 (Int32.div n1 n2) + | Pmodbint Pint32 when n2 <> 0l -> make_const_int32 (Int32.rem n1 n2) + | Pandbint Pint32 -> make_const_int32 (Int32.logand n1 n2) + | Porbint Pint32 -> make_const_int32 (Int32.logor n1 n2) + | Pxorbint Pint32 -> make_const_int32 (Int32.logxor n1 n2) + | Pbintcomp(Pint32, c) -> make_comparison c n1 n2 + | _ -> default + end + (* int32, int *) + | [Value_const(Uconst_ref(_, Uconst_int32 n1)); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_left n1 n2) + | Plsrbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_right_logical n1 n2) + | Pasrbint Pint32 when 0 <= n2 && n2 < 32 -> + make_const_int32 (Int32.shift_right n1 n2) + | _ -> default + end + (* int64 *) + | [Value_const(Uconst_ref(_, Uconst_int64 n))] -> + begin match p with + | Pintofbint Pint64 -> make_const_int (Int64.to_int n) + | Pcvtbint(Pint64, Pint32) -> make_const_int32 (Int64.to_int32 n) + | Pcvtbint(Pint64, Pnativeint) -> make_const_natint (Int64.to_nativeint n) + | Pnegbint Pint64 -> make_const_int64 (Int64.neg n) + | _ -> default + end + (* int64, int64 *) + | [Value_const(Uconst_ref(_, Uconst_int64 n1)); + Value_const(Uconst_ref(_, Uconst_int64 n2))] -> + begin match p with + | Paddbint Pint64 -> make_const_int64 (Int64.add n1 n2) + | Psubbint Pint64 -> make_const_int64 (Int64.sub n1 n2) + | Pmulbint Pint64 -> make_const_int64 (Int64.mul n1 n2) + | Pdivbint Pint64 when n2 <> 0L -> make_const_int64 (Int64.div n1 n2) + | Pmodbint Pint64 when n2 <> 0L -> make_const_int64 (Int64.rem n1 n2) + | Pandbint Pint64 -> make_const_int64 (Int64.logand n1 n2) + | Porbint Pint64 -> make_const_int64 (Int64.logor n1 n2) + | Pxorbint Pint64 -> make_const_int64 (Int64.logxor n1 n2) + | Pbintcomp(Pint64, c) -> make_comparison c n1 n2 + | _ -> default + end + (* int64, int *) + | [Value_const(Uconst_ref(_, Uconst_int64 n1)); + Value_const(Uconst_int n2)] -> + begin match p with + | Plslbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_left n1 n2) + | Plsrbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_right_logical n1 n2) + | Pasrbint Pint64 when 0 <= n2 && n2 < 64 -> + make_const_int64 (Int64.shift_right n1 n2) + | _ -> default + end + (* TODO: Pbbswap *) + (* Catch-all *) + | _ -> + default + +let field_approx n = function + | Value_tuple a when n < Array.length a -> a.(n) + | Value_const (Uconst_ref(_, Uconst_block(_, l))) when n < List.length l -> + Value_const (List.nth l n) + | _ -> Value_unknown + +let simplif_prim_pure fpc p (args, approxs) dbg = + match p, args, approxs with + (* Block construction *) + | Pmakeblock(tag, Immutable), _, _ -> + let field = function + | Value_const c -> c + | _ -> raise Exit + in + begin try + let cst = Uconst_block (tag, List.map field approxs) in + let name = + Compilenv.new_structured_constant cst ~shared:true + in + make_const (Uconst_ref (name, cst)) + with Exit -> + (Uprim(p, args, dbg), Value_tuple (Array.of_list approxs)) + end + (* Field access *) + | Pfield n, _, [ Value_const(Uconst_ref(_, Uconst_block(_, l))) ] + when n < List.length l -> + make_const (List.nth l n) + | Pfield n, [ Uprim(Pmakeblock _, ul, _) ], [approx] + when n < List.length ul -> + (List.nth ul n, field_approx n approx) + (* Strings *) + | Pstringlength, _, [ Value_const(Uconst_ref(_, Uconst_string s)) ] -> + make_const_int (String.length s) + (* Identity *) + | Pidentity, [arg1], [app1] -> + (arg1, app1) + (* Kind test *) + | Pisint, _, [a1] -> + begin match a1 with + | Value_const(Uconst_int _ | Uconst_ptr _) -> make_const_bool true + | Value_const(Uconst_ref _) -> make_const_bool false + | Value_closure _ | Value_tuple _ -> make_const_bool false | _ -> (Uprim(p, args, dbg), Value_unknown) end + (* Compile-time constants *) + | Pctconst c, _, _ -> + begin match c with + | Big_endian -> make_const_bool Arch.big_endian + | Word_size -> make_const_int (8*Arch.size_int) + | Ostype_unix -> make_const_bool (Sys.os_type = "Unix") + | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32") + | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin") + end + (* Catch-all *) | _ -> - (Uprim(p, args, dbg), Value_unknown) + simplif_arith_prim_pure fpc p (args, approxs) dbg -let simplif_prim p (args, approxs as args_approxs) dbg = +let simplif_prim fpc p (args, approxs as args_approxs) dbg = if List.for_all is_pure_clambda args - then simplif_prim_pure p args_approxs dbg - else (Uprim(p, args, dbg), Value_unknown) + then simplif_prim_pure fpc p args_approxs dbg + else + (* XXX : always return the same approxs as simplif_prim_pure? *) + let approx = + match p with + | Pmakeblock(_, Immutable) -> + Value_tuple (Array.of_list approxs) + | _ -> + Value_unknown + in + (Uprim(p, args, dbg), approx) (* Substitute variables in a [ulambda] term (a body of an inlined function) and perform some more simplifications on integer primitives. @@ -279,20 +525,19 @@ over functions. *) let approx_ulam = function - Uconst(Const_base(Const_int n),_) -> Value_integer n - | Uconst(Const_base(Const_char c),_) -> Value_integer(Char.code c) - | Uconst(Const_pointer n,_) -> Value_constptr n + Uconst c -> Value_const c | _ -> Value_unknown -let rec substitute sb ulam = +let rec substitute fpc sb ulam = match ulam with Uvar v -> begin try Tbl.find v sb with Not_found -> ulam end | Uconst _ -> ulam | Udirect_apply(lbl, args, dbg) -> - Udirect_apply(lbl, List.map (substitute sb) args, dbg) + Udirect_apply(lbl, List.map (substitute fpc sb) args, dbg) | Ugeneric_apply(fn, args, dbg) -> - Ugeneric_apply(substitute sb fn, List.map (substitute sb) args, dbg) + Ugeneric_apply(substitute fpc sb fn, + List.map (substitute fpc sb) args, dbg) | Uclosure(defs, env) -> (* Question: should we rename function labels as well? Otherwise, there is a risk that function labels are not globally unique. @@ -302,11 +547,12 @@ - When we substitute offsets for idents bound by let rec in [close], case [Lletrec], we discard the original let rec body and use only the substituted term. *) - Uclosure(defs, List.map (substitute sb) env) - | Uoffset(u, ofs) -> Uoffset(substitute sb u, ofs) + Uclosure(defs, List.map (substitute fpc sb) env) + | Uoffset(u, ofs) -> Uoffset(substitute fpc sb u, ofs) | Ulet(id, u1, u2) -> let id' = Ident.rename id in - Ulet(id', substitute sb u1, substitute (Tbl.add id (Uvar id') sb) u2) + Ulet(id', substitute fpc sb u1, + substitute fpc (Tbl.add id (Uvar id') sb) u2) | Uletrec(bindings, body) -> let bindings1 = List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in @@ -315,86 +561,102 @@ (fun (id, id', _) s -> Tbl.add id (Uvar id') s) bindings1 sb in Uletrec( - List.map (fun (id, id', rhs) -> (id', substitute sb' rhs)) bindings1, - substitute sb' body) + List.map + (fun (id, id', rhs) -> (id', substitute fpc sb' rhs)) + bindings1, + substitute fpc sb' body) | Uprim(p, args, dbg) -> - let sargs = List.map (substitute sb) args in - let (res, _) = simplif_prim p (sargs, List.map approx_ulam sargs) dbg in + let sargs = + List.map (substitute fpc sb) args in + let (res, _) = + simplif_prim fpc p (sargs, List.map approx_ulam sargs) dbg in res | Uswitch(arg, sw) -> - Uswitch(substitute sb arg, + Uswitch(substitute fpc sb arg, { sw with us_actions_consts = - Array.map (substitute sb) sw.us_actions_consts; + Array.map (substitute fpc sb) sw.us_actions_consts; us_actions_blocks = - Array.map (substitute sb) sw.us_actions_blocks; + Array.map (substitute fpc sb) sw.us_actions_blocks; }) + | Ustringswitch(arg,sw,d) -> + Ustringswitch + (substitute fpc sb arg, + List.map (fun (s,act) -> s,substitute fpc sb act) sw, + Misc.may_map (substitute fpc sb) d) | Ustaticfail (nfail, args) -> - Ustaticfail (nfail, List.map (substitute sb) args) + Ustaticfail (nfail, List.map (substitute fpc sb) args) | Ucatch(nfail, ids, u1, u2) -> - Ucatch(nfail, ids, substitute sb u1, substitute sb u2) + Ucatch(nfail, ids, substitute fpc sb u1, substitute fpc sb u2) | Utrywith(u1, id, u2) -> let id' = Ident.rename id in - Utrywith(substitute sb u1, id', substitute (Tbl.add id (Uvar id') sb) u2) + Utrywith(substitute fpc sb u1, id', + substitute fpc (Tbl.add id (Uvar id') sb) u2) | Uifthenelse(u1, u2, u3) -> - begin match substitute sb u1 with - Uconst(Const_pointer n, _) -> - if n <> 0 then substitute sb u2 else substitute sb u3 + begin match substitute fpc sb u1 with + Uconst (Uconst_ptr n) -> + if n <> 0 then substitute fpc sb u2 else substitute fpc sb u3 + | Uprim(Pmakeblock _, _, _) -> + substitute fpc sb u2 | su1 -> - Uifthenelse(su1, substitute sb u2, substitute sb u3) + Uifthenelse(su1, substitute fpc sb u2, substitute fpc sb u3) end - | Usequence(u1, u2) -> Usequence(substitute sb u1, substitute sb u2) - | Uwhile(u1, u2) -> Uwhile(substitute sb u1, substitute sb u2) + | Usequence(u1, u2) -> + Usequence(substitute fpc sb u1, substitute fpc sb u2) + | Uwhile(u1, u2) -> + Uwhile(substitute fpc sb u1, substitute fpc sb u2) | Ufor(id, u1, u2, dir, u3) -> let id' = Ident.rename id in - Ufor(id', substitute sb u1, substitute sb u2, dir, - substitute (Tbl.add id (Uvar id') sb) u3) + Ufor(id', substitute fpc sb u1, substitute fpc sb u2, dir, + substitute fpc (Tbl.add id (Uvar id') sb) u3) | Uassign(id, u) -> let id' = try match Tbl.find id sb with Uvar i -> i | _ -> assert false with Not_found -> id in - Uassign(id', substitute sb u) + Uassign(id', substitute fpc sb u) | Usend(k, u1, u2, ul, dbg) -> - Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul, - dbg) + Usend(k, substitute fpc sb u1, substitute fpc sb u2, + List.map (substitute fpc sb) ul, dbg) (* Perform an inline expansion *) let is_simple_argument = function - Uvar _ -> true - | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ | - Const_int32 _ | Const_int64 _ | Const_nativeint _),_) -> - true - | Uconst(Const_pointer _, _) -> true + | Uvar _ | Uconst _ -> true | _ -> false let no_effects = function - Uclosure _ -> true - | Uconst(Const_base(Const_string _),_) -> true + | Uclosure _ -> true | u -> is_simple_argument u -let rec bind_params_rec subst params args body = +let rec bind_params_rec fpc subst params args body = match (params, args) with - ([], []) -> substitute subst body + ([], []) -> substitute fpc subst body | (p1 :: pl, a1 :: al) -> if is_simple_argument a1 then - bind_params_rec (Tbl.add p1 a1 subst) pl al body + bind_params_rec fpc (Tbl.add p1 a1 subst) pl al body else begin let p1' = Ident.rename p1 in + let u1, u2 = + match Ident.name p1, a1 with + | "*opt*", Uprim(Pmakeblock(0, Immutable), [a], dbg) -> + a, Uprim(Pmakeblock(0, Immutable), [Uvar p1'], dbg) + | _ -> + a1, Uvar p1' + in let body' = - bind_params_rec (Tbl.add p1 (Uvar p1') subst) pl al body in - if occurs_var p1 body then Ulet(p1', a1, body') + bind_params_rec fpc (Tbl.add p1 u2 subst) pl al body in + if occurs_var p1 body then Ulet(p1', u1, body') else if no_effects a1 then body' else Usequence(a1, body') end | (_, _) -> assert false -let bind_params params args body = +let bind_params fpc params args body = (* Reverse parameters and arguments to preserve right-to-left evaluation order (PR#2910). *) - bind_params_rec Tbl.empty (List.rev params) (List.rev args) body + bind_params_rec fpc Tbl.empty (List.rev params) (List.rev args) body (* Check if a lambda term is ``pure'', that is without side-effects *and* not containing function definitions *) @@ -403,7 +665,7 @@ Lvar v -> true | Lconst cst -> true | Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ | - Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets | + Pccall _ | Praise _ | Poffsetref _ | Pstringsetu | Pstringsets | Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false | Lprim(p, args) -> List.for_all is_pure args | Levent(lam, ev) -> is_pure lam @@ -416,8 +678,10 @@ if fundesc.fun_closed then uargs else uargs @ [ufunct] in let app = match fundesc.fun_inline with - None -> Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none) - | Some(params, body) -> bind_params params app_args body in + | None -> + Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none) + | Some(params, body) -> + bind_params fundesc.fun_float_const_prop params app_args body in (* If ufunct can contain side-effects or function definitions, we must make sure that it is evaluated exactly once. If the function is not closed, we evaluate ufunct as part of the @@ -432,7 +696,8 @@ let strengthen_approx appl approx = match approx_ulam appl with - (Value_integer _ | Value_constptr _) as intapprox -> intapprox + (Value_const _) as intapprox -> + intapprox | _ -> approx (* If a term has approximation Value_integer or Value_constptr and is pure, @@ -440,8 +705,16 @@ let check_constant_result lam ulam approx = match approx with - Value_integer n when is_pure lam -> make_const_int n - | Value_constptr n when is_pure lam -> make_const_ptr n + Value_const c when is_pure lam -> make_const c + | Value_global_field (id, i) when is_pure lam -> + begin match ulam with + | Uprim(Pfield _, [Uprim(Pgetglobal _, _, _)], _) -> (ulam, approx) + | _ -> + let glb = + Uprim(Pgetglobal (Ident.create_persistent id), [], Debuginfo.none) + in + Uprim(Pfield i, [glb], Debuginfo.none), approx + end | _ -> (ulam, approx) (* Evaluate an expression with known value for its side effects only, @@ -473,8 +746,8 @@ args2, Debuginfo.from_call ev) | Ugeneric_apply(fn, args, dinfo) -> Ugeneric_apply(fn, args, Debuginfo.from_call ev) - | Uprim(Praise, args, dinfo) -> - Uprim(Praise, args, Debuginfo.from_call ev) + | Uprim(Praise k, args, dinfo) -> + Uprim(Praise k, args, Debuginfo.from_call ev) | Uprim(p, args, dinfo) -> Uprim(p, args, Debuginfo.from_call ev) | Usend(kind, u1, u2, args, dinfo) -> @@ -492,13 +765,12 @@ The closure environment [cenv] maps idents to [ulambda] terms. It is used to substitute environment accesses for free identifiers. *) +exception NotClosed + let close_approx_var fenv cenv id = let approx = try Tbl.find id fenv with Not_found -> Value_unknown in match approx with - Value_integer n -> - make_const_int n - | Value_constptr n -> - make_const_ptr n + Value_const c -> make_const c | approx -> let subst = try Tbl.find id cenv with Not_found -> Uvar id in (subst, approx) @@ -510,14 +782,33 @@ Lvar id -> close_approx_var fenv cenv id | Lconst cst -> - begin match cst with - Const_base(Const_int n) -> (Uconst (cst,None), Value_integer n) - | Const_base(Const_char c) -> (Uconst (cst,None), - Value_integer(Char.code c)) - | Const_pointer n -> (Uconst (cst, None), Value_constptr n) - | _ -> (Uconst (cst, Some (Compilenv.new_structured_constant cst true)), - Value_unknown) - end + let str ?(shared = true) cst = + let name = + Compilenv.new_structured_constant cst ~shared + in + Uconst_ref (name, cst) + in + let rec transl = function + | Const_base(Const_int n) -> Uconst_int n + | Const_base(Const_char c) -> Uconst_int (Char.code c) + | Const_pointer n -> Uconst_ptr n + | Const_block (tag, fields) -> + str (Uconst_block (tag, List.map transl fields)) + | Const_float_array sl -> + (* constant float arrays are really immutable *) + str (Uconst_float_array (List.map float_of_string sl)) + | Const_immstring s -> + str (Uconst_string s) + | Const_base (Const_string (s, _)) -> + (* strings (even literal ones) are mutable! *) + (* of course, the empty string is really immutable *) + str ~shared:false(*(String.length s = 0)*) (Uconst_string s) + | Const_base(Const_float x) -> str (Uconst_float (float_of_string x)) + | Const_base(Const_int32 x) -> str (Uconst_int32 x) + | Const_base(Const_int64 x) -> str (Uconst_int64 x) + | Const_base(Const_nativeint x) -> str (Uconst_nativeint x) + in + make_const (transl cst) | Lfunction(kind, params, body) as funct -> close_one_function fenv cenv (Ident.create "fun") funct @@ -581,7 +872,7 @@ (Variable, _) -> let (ubody, abody) = close fenv cenv body in (Ulet(id, ulam, ubody), abody) - | (_, (Value_integer _ | Value_constptr _)) + | (_, Value_const _) when str = Alias || is_pure lam -> close (Tbl.add id alam fenv) cenv body | (_, _) -> @@ -606,7 +897,7 @@ (fun (id, pos, approx) sb -> Tbl.add id (Uoffset(Uvar clos_ident, pos)) sb) infos Tbl.empty in - (Ulet(clos_ident, clos, substitute sb ubody), + (Ulet(clos_ident, clos, substitute !Clflags.float_const_prop sb ubody), approx) end else begin (* General case: recursive definition of values *) @@ -614,7 +905,7 @@ [] -> ([], fenv) | (id, lam) :: rem -> let (udefs, fenv_body) = clos_defs rem in - let (ulam, approx) = close fenv cenv lam in + let (ulam, approx) = close_named fenv cenv id lam in ((id, ulam) :: udefs, Tbl.add id approx fenv_body) in let (udefs, fenv_body) = clos_defs defs in let (ubody, approx) = close fenv_body cenv body in @@ -627,45 +918,67 @@ check_constant_result lam (getglobal id) (Compilenv.global_approx id) - | Lprim(Pmakeblock(tag, mut) as prim, lams) -> - let (ulams, approxs) = List.split (List.map (close fenv cenv) lams) in - (Uprim(prim, ulams, Debuginfo.none), - begin match mut with - Immutable -> Value_tuple(Array.of_list approxs) - | Mutable -> Value_unknown - end) | Lprim(Pfield n, [lam]) -> let (ulam, approx) = close fenv cenv lam in - let fieldapprox = - match approx with - Value_tuple a when n < Array.length a -> a.(n) - | _ -> Value_unknown in check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none)) - fieldapprox + (field_approx n approx) | Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) -> let (ulam, approx) = close fenv cenv lam in - (!global_approx).(n) <- approx; + if approx <> Value_unknown then + (!global_approx).(n) <- approx; (Uprim(Psetfield(n, false), [getglobal id; ulam], Debuginfo.none), Value_unknown) - | Lprim(Praise, [Levent(arg, ev)]) -> + | Lprim(Praise k, [Levent(arg, ev)]) -> let (ulam, approx) = close fenv cenv arg in - (Uprim(Praise, [ulam], Debuginfo.from_raise ev), + (Uprim(Praise k, [ulam], Debuginfo.from_raise ev), Value_unknown) | Lprim(p, args) -> - simplif_prim p (close_list_approx fenv cenv args) Debuginfo.none + simplif_prim !Clflags.float_const_prop + p (close_list_approx fenv cenv args) Debuginfo.none | Lswitch(arg, sw) -> + let fn fail = + let (uarg, _) = close fenv cenv arg in + let const_index, const_actions, fconst = + close_switch arg fenv cenv sw.sw_consts sw.sw_numconsts fail + and block_index, block_actions, fblock = + close_switch arg fenv cenv sw.sw_blocks sw.sw_numblocks fail in + let ulam = + Uswitch + (uarg, + {us_index_consts = const_index; + us_actions_consts = const_actions; + us_index_blocks = block_index; + us_actions_blocks = block_actions}) in + (fconst (fblock ulam),Value_unknown) in (* NB: failaction might get copied, thus it should be some Lstaticraise *) - let (uarg, _) = close fenv cenv arg in - let const_index, const_actions = - close_switch fenv cenv sw.sw_consts sw.sw_numconsts sw.sw_failaction - and block_index, block_actions = - close_switch fenv cenv sw.sw_blocks sw.sw_numblocks sw.sw_failaction in - (Uswitch(uarg, - {us_index_consts = const_index; - us_actions_consts = const_actions; - us_index_blocks = block_index; - us_actions_blocks = block_actions}), - Value_unknown) + let fail = sw.sw_failaction in + begin match fail with + | None|Some (Lstaticraise (_,_)) -> fn fail + | Some lamfail -> + if + (sw.sw_numconsts - List.length sw.sw_consts) + + (sw.sw_numblocks - List.length sw.sw_blocks) > 1 + then + let i = next_raise_count () in + let ubody,_ = fn (Some (Lstaticraise (i,[]))) + and uhandler,_ = close fenv cenv lamfail in + Ucatch (i,[],ubody,uhandler),Value_unknown + else fn fail + end + | Lstringswitch(arg,sw,d) -> + let uarg,_ = close fenv cenv arg in + let usw = + List.map + (fun (s,act) -> + let uact,_ = close fenv cenv act in + s,uact) + sw in + let ud = + Misc.may_map + (fun d -> + let ud,_ = close fenv cenv d in + ud) d in + Ustringswitch (uarg,usw,ud),Value_unknown | Lstaticraise (i, args) -> (Ustaticfail (i, close_list fenv cenv args), Value_unknown) | Lstaticcatch(body, (i, vars), handler) -> @@ -678,7 +991,7 @@ (Utrywith(ubody, id, uhandler), Value_unknown) | Lifthenelse(arg, ifso, ifnot) -> begin match close fenv cenv arg with - (uarg, Value_constptr n) -> + (uarg, Value_const (Uconst_ptr n)) -> sequence_constant_expr arg uarg (close fenv cenv (if n = 0 then ifnot else ifso)) | (uarg, _ ) -> @@ -730,6 +1043,17 @@ (* Build a shared closure for a set of mutually recursive functions *) and close_functions fenv cenv fun_defs = + let fun_defs = + List.flatten + (List.map + (function + | (id, Lfunction(kind, params, body)) -> + split_default_wrapper id kind params body + | _ -> assert false + ) + fun_defs) + in + (* Update and check nesting depth *) incr function_nesting_depth; let initially_closed = @@ -750,7 +1074,8 @@ {fun_label = label; fun_arity = (if kind = Tupled then -arity else arity); fun_closed = initially_closed; - fun_inline = None } in + fun_inline = None; + fun_float_const_prop = !Clflags.float_const_prop } in (id, params, body, fundesc) | (_, _) -> fatal_error "Closure.close_functions") fun_defs in @@ -783,31 +1108,52 @@ build_closure_env env_param (fv_pos - env_pos) fv in let cenv_body = List.fold_right2 - (fun (id, params, arity, body) pos env -> + (fun (id, params, body, fundesc) pos env -> Tbl.add id (Uoffset(Uvar env_param, pos - env_pos)) env) uncurried_defs clos_offsets cenv_fv in let (ubody, approx) = close fenv_rec cenv_body body in - if !useless_env && occurs_var env_param ubody then useless_env := false; + if !useless_env && occurs_var env_param ubody then raise NotClosed; let fun_params = if !useless_env then params else params @ [env_param] in - ({ label = fundesc.fun_label; - arity = fundesc.fun_arity; - params = fun_params; - body = ubody; - dbg }, - (id, env_pos, Value_closure(fundesc, approx))) in + let f = + { + label = fundesc.fun_label; + arity = fundesc.fun_arity; + params = fun_params; + body = ubody; + dbg; + } + in + (* give more chance of function with default parameters (i.e. + their wrapper functions) to be inlined *) + let n = + List.fold_left + (fun n id -> n + if Ident.name id = "*opt*" then 8 else 1) + 0 + fun_params + in + if lambda_smaller ubody + (!Clflags.inline_threshold + n) + then fundesc.fun_inline <- Some(fun_params, ubody); + + (f, (id, env_pos, Value_closure(fundesc, approx))) in (* Translate all function definitions. *) let clos_info_list = if initially_closed then begin - let cl = List.map2 clos_fundef uncurried_defs clos_offsets in + let snap = Compilenv.snapshot () in + try List.map2 clos_fundef uncurried_defs clos_offsets + with NotClosed -> (* If the hypothesis that the environment parameters are useless has been invalidated, then set [fun_closed] to false in all descriptions and recompile *) - if !useless_env then cl else begin + Compilenv.backtrack snap; (* PR#6337 *) List.iter - (fun (id, params, body, fundesc) -> fundesc.fun_closed <- false) + (fun (id, params, body, fundesc) -> + fundesc.fun_closed <- false; + fundesc.fun_inline <- None; + ) uncurried_defs; + useless_env := false; List.map2 clos_fundef uncurried_defs clos_offsets - end end else (* Excessive closure nesting: assume environment parameter is used *) List.map2 clos_fundef uncurried_defs clos_offsets @@ -817,31 +1163,27 @@ (* Return the Uclosure node and the list of all identifiers defined, with offsets and approximations. *) let (clos, infos) = List.split clos_info_list in + let fv = if !useless_env then [] else fv in (Uclosure(clos, List.map (close_var fenv cenv) fv), infos) (* Same, for one non-recursive function *) and close_one_function fenv cenv id funct = match close_functions fenv cenv [id, funct] with - ((Uclosure([f], _) as clos), - [_, _, (Value_closure(fundesc, _) as approx)]) -> - (* See if the function can be inlined *) - if lambda_smaller f.body - (!Clflags.inline_threshold + List.length f.params) - then fundesc.fun_inline <- Some(f.params, f.body); - (clos, approx) - | _ -> fatal_error "Closure.close_one_function" + | (clos, (i, _, approx) :: _) when id = i -> (clos, approx) + | _ -> fatal_error "Closure.close_one_function" (* Close a switch *) -and close_switch fenv cenv cases num_keys default = - let index = Array.create num_keys 0 - and store = mk_store Lambda.same in +and close_switch arg fenv cenv cases num_keys default = + let ncases = List.length cases in + let index = Array.make num_keys 0 + and store = Storer.mk_store () in (* First default case *) begin match default with - | Some def when List.length cases < num_keys -> - ignore (store.act_store def) + | Some def when ncases < num_keys -> + assert (store.act_store def = 0) | _ -> () end ; (* Then all other cases *) @@ -849,24 +1191,108 @@ (fun (key,lam) -> index.(key) <- store.act_store lam) cases ; - (* Compile action *) + + (* Explicit sharing with catch/exit, as switcher compilation may + later unshare *) + let acts = store.act_get_shared () in + let hs = ref (fun e -> e) in + + (* Compile actions *) let actions = Array.map - (fun lam -> - let ulam,_ = close fenv cenv lam in - ulam) - (store.act_get ()) in + (function + | Single lam|Shared (Lstaticraise (_,[]) as lam) -> + let ulam,_ = close fenv cenv lam in + ulam + | Shared lam -> + let ulam,_ = close fenv cenv lam in + let i = next_raise_count () in +(* + let string_of_lambda e = + Printlambda.lambda Format.str_formatter e ; + Format.flush_str_formatter () in + Printf.eprintf "SHARE CLOSURE %i [%s]\n%s\n" i + (string_of_lambda arg) + (string_of_lambda lam) ; +*) + let ohs = !hs in + hs := (fun e -> Ucatch (i,[],ohs e,ulam)) ; + Ustaticfail (i,[])) + acts in match actions with - | [| |] -> [| |], [| |] (* May happen when default is None *) - | _ -> index, actions + | [| |] -> [| |], [| |], !hs (* May happen when default is None *) + | _ -> index, actions, !hs + +(* Collect exported symbols for structured constants *) + +let collect_exported_structured_constants a = + let rec approx = function + | Value_closure (fd, a) -> + approx a; + begin match fd.fun_inline with + | Some (_, u) -> ulam u + | None -> () + end + | Value_tuple a -> Array.iter approx a + | Value_const c -> const c + | Value_unknown | Value_global_field _ -> () + and const = function + | Uconst_ref (s, c) -> + Compilenv.add_exported_constant s; + structured_constant c + | Uconst_int _ | Uconst_ptr _ -> () + and structured_constant = function + | Uconst_block (_, ul) -> List.iter const ul + | Uconst_float _ | Uconst_int32 _ + | Uconst_int64 _ | Uconst_nativeint _ + | Uconst_float_array _ | Uconst_string _ -> () + and ulam = function + | Uvar _ -> () + | Uconst c -> const c + | Udirect_apply (_, ul, _) -> List.iter ulam ul + | Ugeneric_apply (u, ul, _) -> ulam u; List.iter ulam ul + | Uclosure (fl, ul) -> + List.iter (fun f -> ulam f.body) fl; + List.iter ulam ul + | Uoffset(u, _) -> ulam u + | Ulet (_, u1, u2) -> ulam u1; ulam u2 + | Uletrec (l, u) -> List.iter (fun (_, u) -> ulam u) l; ulam u + | Uprim (_, ul, _) -> List.iter ulam ul + | Uswitch (u, sl) -> + ulam u; + Array.iter ulam sl.us_actions_consts; + Array.iter ulam sl.us_actions_blocks + | Ustringswitch (u,sw,d) -> + ulam u ; + List.iter (fun (_,act) -> ulam act) sw ; + Misc.may ulam d + | Ustaticfail (_, ul) -> List.iter ulam ul + | Ucatch (_, _, u1, u2) + | Utrywith (u1, _, u2) + | Usequence (u1, u2) + | Uwhile (u1, u2) -> ulam u1; ulam u2 + | Uifthenelse (u1, u2, u3) + | Ufor (_, u1, u2, _, u3) -> ulam u1; ulam u2; ulam u3 + | Uassign (_, u) -> ulam u + | Usend (_, u1, u2, ul, _) -> ulam u1; ulam u2; List.iter ulam ul + in + approx a + +let reset () = + global_approx := [||]; + function_nesting_depth := 0 (* The entry point *) let intro size lam = - function_nesting_depth := 0; - global_approx := Array.create size Value_unknown; + reset (); + let id = Compilenv.make_symbol None in + global_approx := Array.init size (fun i -> Value_global_field (id, i)); Compilenv.set_global_approx(Value_tuple !global_approx); let (ulam, approx) = close Tbl.empty Tbl.empty lam in + if !Clflags.opaque + then Compilenv.set_global_approx(Value_unknown) + else collect_exported_structured_constants (Value_tuple !global_approx); global_approx := [||]; ulam diff -Nru ocaml-4.01.0/asmcomp/closure.mli ocaml-4.02.3/asmcomp/closure.mli --- ocaml-4.01.0/asmcomp/closure.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/closure.mli 2014-05-09 14:22:35.000000000 +0200 @@ -13,3 +13,4 @@ (* Introduction of closures, uncurrying, recognition of direct calls *) val intro: int -> Lambda.lambda -> Clambda.ulambda +val reset : unit -> unit diff -Nru ocaml-4.01.0/asmcomp/cmmgen.ml ocaml-4.02.3/asmcomp/cmmgen.ml --- ocaml-4.01.0/asmcomp/cmmgen.ml 2013-05-22 15:59:24.000000000 +0200 +++ ocaml-4.02.3/asmcomp/cmmgen.ml 2015-05-27 11:03:34.000000000 +0200 @@ -27,24 +27,33 @@ let bind name arg fn = match arg with Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _ - | Cconst_pointer _ | Cconst_natpointer _ -> fn arg + | Cconst_pointer _ | Cconst_natpointer _ + | Cconst_blockheader _ -> fn arg | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id)) let bind_nonvar name arg fn = match arg with Cconst_int _ | Cconst_natint _ | Cconst_symbol _ - | Cconst_pointer _ | Cconst_natpointer _ -> fn arg + | Cconst_pointer _ | Cconst_natpointer _ + | Cconst_blockheader _ -> fn arg | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id)) +let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8 + (* cf. byterun/gc.h *) + (* Block headers. Meaning of the tag field: see stdlib/obj.ml *) -let float_tag = Cconst_int Obj.double_tag let floatarray_tag = Cconst_int Obj.double_array_tag let block_header tag sz = Nativeint.add (Nativeint.shift_left (Nativeint.of_int sz) 10) (Nativeint.of_int tag) -let closure_header sz = block_header Obj.closure_tag sz +(* Static data corresponding to "value"s must be marked black in case we are + in no-naked-pointers mode. See [caml_darken] and the code below that emits + structured constants and static module definitions. *) +let black_block_header tag sz = Nativeint.logor (block_header tag sz) caml_black +let white_closure_header sz = block_header Obj.closure_tag sz +let black_closure_header sz = black_block_header Obj.closure_tag sz let infix_header ofs = block_header Obj.infix_tag ofs let float_header = block_header Obj.double_tag (size_float / size_addr) let floatarray_header len = @@ -55,14 +64,14 @@ let boxedint64_header = block_header Obj.custom_tag (1 + 8 / size_addr) let boxedintnat_header = block_header Obj.custom_tag 2 -let alloc_block_header tag sz = Cconst_natint(block_header tag sz) -let alloc_float_header = Cconst_natint(float_header) -let alloc_floatarray_header len = Cconst_natint(floatarray_header len) -let alloc_closure_header sz = Cconst_natint(closure_header sz) -let alloc_infix_header ofs = Cconst_natint(infix_header ofs) -let alloc_boxedint32_header = Cconst_natint(boxedint32_header) -let alloc_boxedint64_header = Cconst_natint(boxedint64_header) -let alloc_boxedintnat_header = Cconst_natint(boxedintnat_header) +let alloc_block_header tag sz = Cconst_blockheader(block_header tag sz) +let alloc_float_header = Cconst_blockheader(float_header) +let alloc_floatarray_header len = Cconst_blockheader(floatarray_header len) +let alloc_closure_header sz = Cconst_blockheader(white_closure_header sz) +let alloc_infix_header ofs = Cconst_blockheader(infix_header ofs) +let alloc_boxedint32_header = Cconst_blockheader(boxedint32_header) +let alloc_boxedint64_header = Cconst_blockheader(boxedint64_header) +let alloc_boxedintnat_header = Cconst_blockheader(boxedintnat_header) (* Integers *) @@ -75,10 +84,14 @@ else Cconst_natint (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) -let add_const c n = +let rec add_const c n = if n = 0 then c else match c with | Cconst_int x when no_overflow_add x n -> Cconst_int (x + n) + | Cop(Csubi, [Cconst_int x; c]) when no_overflow_add n x -> + Cop(Csubi, [Cconst_int (n + x); c]) + | Cop(Csubi, [c; Cconst_int x]) when no_overflow_sub n x -> + add_const c (n - x) | c -> Cop(Caddi, [c; Cconst_int n]) let incr_int = function @@ -121,31 +134,16 @@ let mul_int c1 c2 = match (c1, c2) with - (Cconst_int 0, _) -> c1 - | (Cconst_int 1, _) -> c2 - | (_, Cconst_int 0) -> c2 - | (_, Cconst_int 1) -> c1 - | (_, _) -> Cop(Cmuli, [c1; c2]) - -let tag_int = function - Cconst_int n -> int_const n - | c -> Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) - -let force_tag_int = function - Cconst_int n -> int_const n - | c -> Cop(Cor, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) - -let untag_int = function - Cconst_int n -> Cconst_int(n asr 1) - | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c - | Cop(Cor, [Cop(Casr, [c; Cconst_int n]); Cconst_int 1]) - when n > 0 && n < size_int * 8 -> - Cop(Casr, [c; Cconst_int (n+1)]) - | Cop(Cor, [Cop(Clsr, [c; Cconst_int n]); Cconst_int 1]) - when n > 0 && n < size_int * 8 -> - Cop(Clsr, [c; Cconst_int (n+1)]) - | Cop(Cor, [c; Cconst_int 1]) -> Cop(Casr, [c; Cconst_int 1]) - | c -> Cop(Casr, [c; Cconst_int 1]) + (c, Cconst_int 0) | (Cconst_int 0, c) -> + Cconst_int 0 + | (c, Cconst_int 1) | (Cconst_int 1, c) -> + c + | (c, Cconst_int(-1)) | (Cconst_int(-1), c) -> + sub_int (Cconst_int 0) c + | (c, Cconst_int n) | (Cconst_int n, c) when n = 1 lsl Misc.log2 n-> + Cop(Clsl, [c; Cconst_int(Misc.log2 n)]) + | (c1, c2) -> + Cop(Cmuli, [c1; c2]) let lsl_int c1 c2 = match (c1, c2) with @@ -163,64 +161,251 @@ let lsr_int c1 c2 = match c2 with - (Cconst_int n) when n > 0 -> - Cop(Clsr, [ignore_low_bit_int c1; c2]) + Cconst_int 0 -> + c1 + | Cconst_int n when n > 0 -> + Cop(Clsr, [ignore_low_bit_int c1; c2]) | _ -> - Cop(Clsr, [c1; c2]) + Cop(Clsr, [c1; c2]) let asr_int c1 c2 = match c2 with - (Cconst_int n) when n > 0 -> - Cop(Casr, [ignore_low_bit_int c1; c2]) + Cconst_int 0 -> + c1 + | Cconst_int n when n > 0 -> + Cop(Casr, [ignore_low_bit_int c1; c2]) | _ -> - Cop(Casr, [c1; c2]) + Cop(Casr, [c1; c2]) -(* Division or modulo on tagged integers. The overflow case min_int / -1 - cannot occur, but we must guard against division by zero. *) +let tag_int = function + Cconst_int n -> + int_const n + | Cop(Casr, [c; Cconst_int n]) when n > 0 -> + Cop(Cor, [asr_int c (Cconst_int (n - 1)); Cconst_int 1]) + | c -> + incr_int (lsl_int c (Cconst_int 1)) -let is_different_from x = function - Cconst_int n -> n <> x - | Cconst_natint n -> n <> Nativeint.of_int x - | _ -> false +let force_tag_int = function + Cconst_int n -> + int_const n + | Cop(Casr, [c; Cconst_int n]) when n > 0 -> + Cop(Cor, [asr_int c (Cconst_int (n - 1)); Cconst_int 1]) + | c -> + Cop(Cor, [lsl_int c (Cconst_int 1); Cconst_int 1]) -let safe_divmod op c1 c2 dbg = - if !Clflags.fast || is_different_from 0 c2 then - Cop(op, [c1; c2]) - else - bind "divisor" c2 (fun c2 -> - Cifthenelse(c2, - Cop(op, [c1; c2]), - Cop(Craise dbg, - [Cconst_symbol "caml_bucket_Division_by_zero"]))) +let untag_int = function + Cconst_int n -> Cconst_int(n asr 1) + | Cop(Caddi, [Cop(Clsl, [c; Cconst_int 1]); Cconst_int 1]) -> c + | Cop(Cor, [Cop(Casr, [c; Cconst_int n]); Cconst_int 1]) + when n > 0 && n < size_int * 8 -> + Cop(Casr, [c; Cconst_int (n+1)]) + | Cop(Cor, [Cop(Clsr, [c; Cconst_int n]); Cconst_int 1]) + when n > 0 && n < size_int * 8 -> + Cop(Clsr, [c; Cconst_int (n+1)]) + | Cop(Cor, [c; Cconst_int 1]) -> Cop(Casr, [c; Cconst_int 1]) + | c -> Cop(Casr, [c; Cconst_int 1]) + +(* Turning integer divisions into multiply-high then shift. + The [division_parameters] function is used in module Emit for + those target platforms that support this optimization. *) + +(* Unsigned comparison between native integers. *) + +let ucompare x y = Nativeint.(compare (add x min_int) (add y min_int)) + +(* Unsigned division and modulus at type nativeint. + Algorithm: Hacker's Delight section 9.3 *) + +let udivmod n d = Nativeint.( + if d < 0n then + if ucompare n d < 0 then (0n, n) else (1n, sub n d) + else begin + let q = shift_left (div (shift_right_logical n 1) d) 1 in + let r = sub n (mul q d) in + if ucompare r d >= 0 then (succ q, sub r d) else (q, r) + end) + +(* Compute division parameters. + Algorithm: Hacker's Delight chapter 10, fig 10-1. *) + +let divimm_parameters d = Nativeint.( + assert (d > 0n); + let twopsm1 = min_int in (* 2^31 for 32-bit archs, 2^63 for 64-bit archs *) + let nc = sub (pred twopsm1) (snd (udivmod twopsm1 d)) in + let rec loop p (q1, r1) (q2, r2) = + let p = p + 1 in + let q1 = shift_left q1 1 and r1 = shift_left r1 1 in + let (q1, r1) = + if ucompare r1 nc >= 0 then (succ q1, sub r1 nc) else (q1, r1) in + let q2 = shift_left q2 1 and r2 = shift_left r2 1 in + let (q2, r2) = + if ucompare r2 d >= 0 then (succ q2, sub r2 d) else (q2, r2) in + let delta = sub d r2 in + if ucompare q1 delta < 0 || (q1 = delta && r1 = 0n) + then loop p (q1, r1) (q2, r2) + else (succ q2, p - size) + in loop (size - 1) (udivmod twopsm1 nc) (udivmod twopsm1 d)) + +(* The result [(m, p)] of [divimm_parameters d] satisfies the following + inequality: + + 2^(wordsize + p) < m * d <= 2^(wordsize + p) + 2^(p + 1) (i) + + from which it follows that + + floor(n / d) = floor(n * m / 2^(wordsize+p)) + if 0 <= n < 2^(wordsize-1) + ceil(n / d) = floor(n * m / 2^(wordsize+p)) + 1 + if -2^(wordsize-1) <= n < 0 + + The correctness condition (i) above can be checked by the code below. + It was exhaustively tested for values of d from 2 to 10^9 in the + wordsize = 64 case. + +let add2 (xh, xl) (yh, yl) = + let zl = add xl yl and zh = add xh yh in + ((if ucompare zl xl < 0 then succ zh else zh), zl) + +let shl2 (xh, xl) n = + assert (0 < n && n < size + size); + if n < size + then (logor (shift_left xh n) (shift_right_logical xl (size - n)), + shift_left xl n) + else (shift_left xl (n - size), 0n) + +let mul2 x y = + let halfsize = size / 2 in + let halfmask = pred (shift_left 1n halfsize) in + let xl = logand x halfmask and xh = shift_right_logical x halfsize in + let yl = logand y halfmask and yh = shift_right_logical y halfsize in + add2 (mul xh yh, 0n) + (add2 (shl2 (0n, mul xl yh) halfsize) + (add2 (shl2 (0n, mul xh yl) halfsize) + (0n, mul xl yl))) + +let ucompare2 (xh, xl) (yh, yl) = + let c = ucompare xh yh in if c = 0 then ucompare xl yl else c + +let validate d m p = + let md = mul2 m d in + let one2 = (0n, 1n) in + let twoszp = shl2 one2 (size + p) in + let twop1 = shl2 one2 (p + 1) in + ucompare2 twoszp md < 0 && ucompare2 md (add2 twoszp twop1) <= 0 +*) + +let rec div_int c1 c2 dbg = + match (c1, c2) with + (c1, Cconst_int 0) -> + Csequence(c1, Cop(Craise (Raise_regular, dbg), + [Cconst_symbol "caml_exn_Division_by_zero"])) + | (c1, Cconst_int 1) -> + c1 + | (Cconst_int 0 as c1, c2) -> + Csequence(c2, c1) + | (Cconst_int n1, Cconst_int n2) -> + Cconst_int (n1 / n2) + | (c1, Cconst_int n) when n <> min_int -> + let l = Misc.log2 n in + if n = 1 lsl l then + (* Algorithm: + t = shift-right-signed(c1, l - 1) + t = shift-right(t, W - l) + t = c1 + t + res = shift-right-signed(c1 + t, l) + *) + Cop(Casr, [bind "dividend" c1 (fun c1 -> + let t = asr_int c1 (Cconst_int (l - 1)) in + let t = lsr_int t (Cconst_int (Nativeint.size - l)) in + add_int c1 t); + Cconst_int l]) + else if n < 0 then + sub_int (Cconst_int 0) (div_int c1 (Cconst_int (-n)) dbg) + else begin + let (m, p) = divimm_parameters (Nativeint.of_int n) in + (* Algorithm: + t = multiply-high-signed(c1, m) + if m < 0, t = t + c1 + if p > 0, t = shift-right-signed(t, p) + res = t + sign-bit(c1) + *) + bind "dividend" c1 (fun c1 -> + let t = Cop(Cmulhi, [c1; Cconst_natint m]) in + let t = if m < 0n then Cop(Caddi, [t; c1]) else t in + let t = if p > 0 then Cop(Casr, [t; Cconst_int p]) else t in + add_int t (lsr_int c1 (Cconst_int (Nativeint.size - 1)))) + end + | (c1, c2) when !Clflags.fast -> + Cop(Cdivi, [c1; c2]) + | (c1, c2) -> + bind "divisor" c2 (fun c2 -> + Cifthenelse(c2, + Cop(Cdivi, [c1; c2]), + Cop(Craise (Raise_regular, dbg), + [Cconst_symbol "caml_exn_Division_by_zero"]))) + +let mod_int c1 c2 dbg = + match (c1, c2) with + (c1, Cconst_int 0) -> + Csequence(c1, Cop(Craise (Raise_regular, dbg), + [Cconst_symbol "caml_exn_Division_by_zero"])) + | (c1, Cconst_int (1 | (-1))) -> + Csequence(c1, Cconst_int 0) + | (Cconst_int 0, c2) -> + Csequence(c2, Cconst_int 0) + | (Cconst_int n1, Cconst_int n2) -> + Cconst_int (n1 mod n2) + | (c1, (Cconst_int n as c2)) when n <> min_int -> + let l = Misc.log2 n in + if n = 1 lsl l then + (* Algorithm: + t = shift-right-signed(c1, l - 1) + t = shift-right(t, W - l) + t = c1 + t + t = bit-and(t, -n) + res = c1 - t + *) + bind "dividend" c1 (fun c1 -> + let t = asr_int c1 (Cconst_int (l - 1)) in + let t = lsr_int t (Cconst_int (Nativeint.size - l)) in + let t = add_int c1 t in + let t = Cop(Cand, [t; Cconst_int (-n)]) in + sub_int c1 t) + else + bind "dividend" c1 (fun c1 -> + sub_int c1 (mul_int (div_int c1 c2 dbg) c2)) + | (c1, c2) when !Clflags.fast -> + Cop(Cmodi, [c1; c2]) + | (c1, c2) -> + bind "divisor" c2 (fun c2 -> + Cifthenelse(c2, + Cop(Cmodi, [c1; c2]), + Cop(Craise (Raise_regular, dbg), + [Cconst_symbol "caml_exn_Division_by_zero"]))) (* Division or modulo on boxed integers. The overflow case min_int / -1 can occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *) +let is_different_from x = function + Cconst_int n -> n <> x + | Cconst_natint n -> n <> Nativeint.of_int x + | _ -> false + let safe_divmod_bi mkop mkm1 c1 c2 bi dbg = bind "dividend" c1 (fun c1 -> bind "divisor" c2 (fun c2 -> - let c3 = - if Arch.division_crashes_on_overflow - && (size_int = 4 || bi <> Pint32) - && not (is_different_from (-1) c2) - then - Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int(-1)]), mkop c1 c2, mkm1 c1) - else - mkop c1 c2 in - if !Clflags.fast || is_different_from 0 c2 then - c3 - else - Cifthenelse(c2, c3, - Cop(Craise dbg, - [Cconst_symbol "caml_bucket_Division_by_zero"])))) + let c = mkop c1 c2 dbg in + if Arch.division_crashes_on_overflow + && (size_int = 4 || bi <> Pint32) + && not (is_different_from (-1) c2) + then Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int(-1)]), c, mkm1 c1) + else c)) let safe_div_bi = - safe_divmod_bi (fun c1 c2 -> Cop(Cdivi, [c1;c2])) - (fun c1 -> Cop(Csubi, [Cconst_int 0; c1])) + safe_divmod_bi div_int (fun c1 -> Cop(Csubi, [Cconst_int 0; c1])) let safe_mod_bi = - safe_divmod_bi (fun c1 c2 -> Cop(Cmodi, [c1;c2])) - (fun c1 -> Cconst_int 0) + safe_divmod_bi mod_int (fun c1 -> Cconst_int 0) (* Bool *) @@ -360,13 +545,15 @@ (* String length *) +(* Length of string block *) + let string_length exp = bind "str" exp (fun str -> let tmp_var = Ident.create "tmp" in Clet(tmp_var, Cop(Csubi, [Cop(Clsl, - [Cop(Clsr, [header str; Cconst_int 10]); + [get_size str; Cconst_int log2_size_addr]); Cconst_int 1]), Cop(Csubi, @@ -398,7 +585,7 @@ let make_alloc_generic set_fn tag wordsize args = if wordsize <= Config.max_young_wosize then - Cop(Calloc, Cconst_natint(block_header tag wordsize) :: args) + Cop(Calloc, Cconst_blockheader(block_header tag wordsize) :: args) else begin let id = Ident.create "alloc" in let rec fill_fields idx = function @@ -484,32 +671,20 @@ (* Translate structured constants *) -(* Fabrice: moved to compilenv.ml ---- -let const_label = ref 0 - -let new_const_label () = - incr const_label; - !const_label - -let new_const_symbol () = - incr const_label; - Compilenv.make_symbol (Some (string_of_int !const_label)) - -let structured_constants = ref ([] : (string * structured_constant) list) -*) - let transl_constant = function - Const_base(Const_int n) -> + | Uconst_int n -> int_const n - | Const_base(Const_char c) -> - Cconst_int(((Char.code c) lsl 1) + 1) - | Const_pointer n -> + | Uconst_ptr n -> if n <= max_repr_int && n >= min_repr_int then Cconst_pointer((n lsl 1) + 1) else Cconst_natpointer (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) - | cst -> - Cconst_symbol (Compilenv.new_structured_constant cst false) + | Uconst_ref (label, _) -> + Cconst_symbol label + +let transl_structured_constant cst = + let label = Compilenv.new_structured_constant cst ~shared:true in + Cconst_symbol label (* Translate constant closures *) @@ -520,9 +695,9 @@ let box_int_constant bi n = match bi with - Pnativeint -> Const_base(Const_nativeint n) - | Pint32 -> Const_base(Const_int32 (Nativeint.to_int32 n)) - | Pint64 -> Const_base(Const_int64 (Int64.of_nativeint n)) + Pnativeint -> Uconst_nativeint n + | Pint32 -> Uconst_int32 (Nativeint.to_int32 n) + | Pint64 -> Uconst_int64 (Int64.of_nativeint n) let operations_boxed_int bi = match bi with @@ -539,9 +714,9 @@ let box_int bi arg = match arg with Cconst_int n -> - transl_constant (box_int_constant bi (Nativeint.of_int n)) + transl_structured_constant (box_int_constant bi (Nativeint.of_int n)) | Cconst_natint n -> - transl_constant (box_int_constant bi n) + transl_structured_constant (box_int_constant bi n) | _ -> let arg' = if bi = Pint32 && size_int = 8 && big_endian @@ -824,8 +999,22 @@ Cop(Cstore Byte_unsigned, [add_int (add_int ptr idx) (Cconst_int 7); b8])))) +let max_or_zero a = + bind "size" a (fun a -> + (* equivalent to + Cifthenelse(Cop(Ccmpi Cle, [a; Cconst_int 0]), Cconst_int 0, a) + + if a is positive, sign is 0 hence sign_negation is full of 1 + so sign_negation&a = a + if a is negative, sign is full of 1 hence sign_negation is 0 + so sign_negation&a = 0 *) + let sign = Cop(Casr, [a; Cconst_int (size_int * 8 - 1)]) in + let sign_negation = Cop(Cxor, [sign; Cconst_int (-1)]) in + Cop(Cand, [sign_negation; a])) + let check_bound unsafe dbg a1 a2 k = - if unsafe then k else Csequence(make_checkbound dbg [a1;a2], k) + if unsafe then k + else Csequence(make_checkbound dbg [max_or_zero a1;a2], k) (* Simplification of some primitives into C calls *) @@ -888,28 +1077,9 @@ (* Build switchers both for constants and blocks *) -(* constants first *) - let transl_isout h arg = tag_int (Cop(Ccmpa Clt, [h ; arg])) -let make_switch_gen arg cases acts = - let lcases = Array.length cases in - let new_cases = Array.create lcases 0 in - let store = Switch.mk_store (=) in - - for i = 0 to Array.length cases-1 do - let act = cases.(i) in - let new_act = store.Switch.act_store act in - new_cases.(i) <- new_act - done ; - Cswitch - (arg, new_cases, - Array.map - (fun n -> acts.(n)) - (store.Switch.act_get ())) - - -(* Then for blocks *) +(* Build an actual switch (ie jump table) *) module SArgBlocks = struct @@ -925,19 +1095,97 @@ type act = expression let default = Cexit (0,[]) + let make_const i = Cconst_int i let make_prim p args = Cop (p,args) let make_offset arg n = add_const arg n let make_isout h arg = Cop (Ccmpa Clt, [h ; arg]) let make_isin h arg = Cop (Ccmpa Cge, [h ; arg]) let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot) - let make_switch arg cases actions = - make_switch_gen arg cases actions + let make_switch arg cases actions = Cswitch (arg,cases,actions) let bind arg body = bind "switcher" arg body + let make_catch handler = match handler with + | Cexit (i,[]) -> i,fun e -> e + | _ -> + let i = next_raise_count () in +(* + Printf.eprintf "SHARE CMM: %i\n" i ; + Printcmm.expression Format.str_formatter handler ; + Printf.eprintf "%s\n" (Format.flush_str_formatter ()) ; +*) + i, + (fun body -> match body with + | Cexit (j,_) -> + if i=j then handler + else body + | _ -> Ccatch (i,[],body,handler)) + + let make_exit i = Cexit (i,[]) + end +(* cmm store, as sharing as normally been detected in previous + phases, we only share exits *) +module StoreExp = + Switch.Store + (struct + type t = expression + type key = int + let make_key = function + | Cexit (i,[]) -> Some i + | _ -> None + end) + module SwitcherBlocks = Switch.Make(SArgBlocks) +(* Int switcher, arg in [low..high], + cases is list of individual cases, and is sorted by first component *) + +let transl_int_switch arg low high cases default = match cases with +| [] -> assert false +| _::_ -> + let store = StoreExp.mk_store () in + assert (store.Switch.act_store default = 0) ; + let cases = + List.map + (fun (i,act) -> i,store.Switch.act_store act) + cases in + let rec inters plow phigh pact = function + | [] -> + if phigh = high then [plow,phigh,pact] + else [(plow,phigh,pact); (phigh+1,high,0) ] + | (i,act)::rem -> + if i = phigh+1 then + if pact = act then + inters plow i pact rem + else + (plow,phigh,pact)::inters i i act rem + else (* insert default *) + if pact = 0 then + if act = 0 then + inters plow i 0 rem + else + (plow,i-1,pact):: + inters i i act rem + else (* pact <> 0 *) + (plow,phigh,pact):: + begin + if act = 0 then inters (phigh+1) i 0 rem + else (phigh+1,i-1,0)::inters i i act rem + end in + let inters = match cases with + | [] -> assert false + | (k0,act0)::rem -> + if k0 = low then inters k0 k0 act0 rem + else inters low (k0-1) 0 cases in + bind "switcher" arg + (fun a -> + SwitcherBlocks.zyva + (low,high) + a + (Array.of_list inters) store) + + (* Auxiliary functions for optimizing "let" of boxed numbers (floats and boxed integers *) @@ -946,8 +1194,8 @@ | Boxed_float | Boxed_integer of boxed_integer -let is_unboxed_number = function - Uconst(Const_base(Const_float f), _) -> +let rec is_unboxed_number = function + Uconst(Uconst_ref(_, Uconst_float _)) -> Boxed_float | Uprim(p, _, _) -> begin match simplif_primitive p with @@ -988,9 +1236,10 @@ | Pbbswap bi -> Boxed_integer bi | _ -> No_unboxing end + | Ulet (_, _, e) | Usequence (_, e) -> is_unboxed_number e | _ -> No_unboxing -let subst_boxed_number unbox_fn boxed_id unboxed_id exp = +let subst_boxed_number unbox_fn boxed_id unboxed_id box_chunk box_offset exp = let need_boxed = ref false in let assigned = ref false in let rec subst = function @@ -1004,10 +1253,22 @@ end else Cassign(id, subst arg) | Ctuple argv -> Ctuple(List.map subst argv) - | Cop(Cload _, [Cvar id]) as e -> - if Ident.same id boxed_id then Cvar unboxed_id else e - | Cop(Cload _, [Cop(Cadda, [Cvar id; _])]) as e -> - if Ident.same id boxed_id then Cvar unboxed_id else e + | Cop(Cload chunk, [Cvar id]) as e -> + if not (Ident.same id boxed_id) then e + else if chunk = box_chunk && box_offset = 0 then + Cvar unboxed_id + else begin + need_boxed := true; + e + end + | Cop(Cload chunk, [Cop(Cadda, [Cvar id; Cconst_int ofs])]) as e -> + if not (Ident.same id boxed_id) then e + else if chunk = box_chunk && ofs = box_offset then + Cvar unboxed_id + else begin + need_boxed := true; + e + end | Cop(op, argv) -> Cop(op, List.map subst argv) | Csequence(e1, e2) -> Csequence(subst e1, subst e2) | Cifthenelse(e1, e2, e3) -> Cifthenelse(subst e1, subst e2, subst e3) @@ -1017,7 +1278,10 @@ | Ccatch(nfail, ids, e1, e2) -> Ccatch(nfail, ids, subst e1, subst e2) | Cexit (nfail, el) -> Cexit (nfail, List.map subst el) | Ctrywith(e1, id, e2) -> Ctrywith(subst e1, id, subst e2) - | e -> e in + | Cconst_int _ | Cconst_natint _ | Cconst_float _ | Cconst_symbol _ + | Cconst_pointer _ | Cconst_natpointer _ + | Cconst_blockheader _ as e -> e + in let res = subst exp in (res, !need_boxed, !assigned) @@ -1025,12 +1289,19 @@ let functions = (Queue.create() : ufunction Queue.t) +let strmatch_compile = + let module S = + Strmatch.Make + (struct + let string_block_length = get_size + let transl_switch = transl_int_switch + end) in + S.compile + let rec transl = function Uvar id -> Cvar id - | Uconst (sc, Some const_label) -> - Cconst_symbol const_label - | Uconst (sc, None) -> + | Uconst sc -> transl_constant sc | Uclosure(fundecls, []) -> let lbl = Compilenv.new_const_symbol() in @@ -1098,9 +1369,12 @@ Clet(id, transl exp, transl body) | Boxed_float -> transl_unbox_let box_float unbox_float transl_unbox_float + Double_u 0 id exp body | Boxed_integer bi -> transl_unbox_let (box_int bi) (unbox_int bi) (transl_unbox_int bi) + (if bi = Pint32 then Thirtytwo_signed else Word) + size_addr id exp body end | Uletrec(bindings, body) -> @@ -1112,7 +1386,7 @@ (Pgetglobal id, []) -> Cconst_symbol (Ident.name id) | (Pmakeblock(tag, mut), []) -> - transl_constant(Const_block(tag, [])) + assert false | (Pmakeblock(tag, mut), args) -> make_alloc tag (List.map transl args) | (Pccall prim, args) -> @@ -1125,7 +1399,7 @@ dbg), List.map transl args) | (Pmakearray kind, []) -> - transl_constant(Const_block(0, [])) + transl_structured_constant (Uconst_block(0, [])) | (Pmakearray kind, args) -> begin match kind with Pgenarray -> @@ -1197,6 +1471,11 @@ (untag_int arg) s.us_index_consts s.us_actions_consts, transl_switch (get_tag arg) s.us_index_blocks s.us_actions_blocks)) + | Ustringswitch(arg,sw,d) -> + bind "switch" (transl arg) + (fun arg -> + strmatch_compile arg (Misc.may_map transl d) + (List.map (fun (s,act) -> s,transl act) sw)) | Ustaticfail (nfail, args) -> Cexit (nfail, List.map transl args) | Ucatch(nfail, [], body, handler) -> @@ -1289,9 +1568,11 @@ Cop(Cload Double_u, [if n = 0 then ptr else Cop(Cadda, [ptr; Cconst_int(n * size_float)])])) + | Pint_as_pointer -> + Cop(Cadda, [transl arg; Cconst_int (-1)]) (* Exceptions *) - | Praise -> - Cop(Craise dbg, [transl arg]) + | Praise k -> + Cop(Craise (k, dbg), [transl arg]) (* Integer operations *) | Pnegint -> Cop(Csubi, [Cconst_int 2; transl arg]) @@ -1309,7 +1590,7 @@ if no_overflow_lsl n then add_const (transl arg) (n lsl 1) else - transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n), None)) + transl_prim_2 Paddint arg (Uconst (Uconst_int n)) Debuginfo.none | Poffsetref n -> return_unit @@ -1408,13 +1689,11 @@ | Psubint -> incr_int(sub_int (transl arg1) (transl arg2)) | Pmulint -> - incr_int(Cop(Cmuli, [decr_int(transl arg1); untag_int(transl arg2)])) + incr_int(mul_int (decr_int(transl arg1)) (untag_int(transl arg2))) | Pdivint -> - tag_int(safe_divmod Cdivi (untag_int(transl arg1)) - (untag_int(transl arg2)) dbg) + tag_int(div_int (untag_int(transl arg1)) (untag_int(transl arg2)) dbg) | Pmodint -> - tag_int(safe_divmod Cmodi (untag_int(transl arg1)) - (untag_int(transl arg2)) dbg) + tag_int(mod_int (untag_int(transl arg1)) (untag_int(transl arg2)) dbg) | Pandint -> Cop(Cand, [transl arg1; transl arg2]) | Porint -> @@ -1741,25 +2020,26 @@ fatal_error "Cmmgen.transl_prim_3" and transl_unbox_float = function - Uconst(Const_base(Const_float f), _) -> Cconst_float f + Uconst(Uconst_ref(_, Uconst_float f)) -> Cconst_float f | exp -> unbox_float(transl exp) and transl_unbox_int bi = function - Uconst(Const_base(Const_int32 n), _) -> + Uconst(Uconst_ref(_, Uconst_int32 n)) -> Cconst_natint (Nativeint.of_int32 n) - | Uconst(Const_base(Const_nativeint n), _) -> + | Uconst(Uconst_ref(_, Uconst_nativeint n)) -> Cconst_natint n - | Uconst(Const_base(Const_int64 n), _) -> + | Uconst(Uconst_ref(_, Uconst_int64 n)) -> assert (size_int = 8); Cconst_natint (Int64.to_nativeint n) - | Uprim(Pbintofint bi',[Uconst(Const_base(Const_int i),_)],_) when bi = bi' -> + | Uprim(Pbintofint bi',[Uconst(Uconst_int i)],_) when bi = bi' -> Cconst_int i | exp -> unbox_int bi (transl exp) -and transl_unbox_let box_fn unbox_fn transl_unbox_fn id exp body = +and transl_unbox_let box_fn unbox_fn transl_unbox_fn box_chunk box_offset + id exp body = let unboxed_id = Ident.create (Ident.name id) in let trbody1 = transl body in let (trbody2, need_boxed, is_assigned) = - subst_boxed_number unbox_fn id unboxed_id trbody1 in + subst_boxed_number unbox_fn id unboxed_id box_chunk box_offset trbody1 in if need_boxed && is_assigned then Clet(id, transl exp, trbody1) else @@ -1784,8 +2064,8 @@ and exit_if_true cond nfail otherwise = match cond with - | Uconst (Const_pointer 0, _) -> otherwise - | Uconst (Const_pointer 1, _) -> Cexit (nfail,[]) + | Uconst (Uconst_ptr 0) -> otherwise + | Uconst (Uconst_ptr 1) -> Cexit (nfail,[]) | Uprim(Psequor, [arg1; arg2], _) -> exit_if_true arg1 nfail (exit_if_true arg2 nfail otherwise) | Uprim(Psequand, _, _) -> @@ -1814,8 +2094,8 @@ and exit_if_false cond otherwise nfail = match cond with - | Uconst (Const_pointer 0, _) -> Cexit (nfail,[]) - | Uconst (Const_pointer 1, _) -> otherwise + | Uconst (Uconst_ptr 0) -> Cexit (nfail,[]) + | Uconst (Uconst_ptr 1) -> otherwise | Uprim(Psequand, [arg1; arg2], _) -> exit_if_false arg1 (exit_if_false arg2 otherwise nfail) nfail | Uprim(Psequor, _, _) -> @@ -1846,9 +2126,13 @@ | 0 -> fatal_error "Cmmgen.transl_switch" | 1 -> transl cases.(0) | _ -> + let cases = Array.map transl cases in + let store = StoreExp.mk_store () in + let index = + Array.map + (fun j -> store.Switch.act_store cases.(j)) + index in let n_index = Array.length index in - let actions = Array.map transl cases in - let inters = ref [] and this_high = ref (n_index-1) and this_low = ref (n_index-1) @@ -1865,13 +2149,15 @@ end done ; inters := (0, !this_high, !this_act) :: !inters ; - bind "switcher" arg - (fun a -> - SwitcherBlocks.zyva - (0,n_index-1) - (fun i -> Cconst_int i) - a - (Array.of_list !inters) actions) + match !inters with + | [_] -> cases.(0) + | inters -> + bind "switcher" arg + (fun a -> + SwitcherBlocks.zyva + (0,n_index-1) + a + (Array.of_list inters) store) and transl_letrec bindings cont = let bsz = @@ -1935,99 +2221,42 @@ (* Emit structured constants *) -let immstrings = Hashtbl.create 17 - -let rec emit_constant symb cst cont = +let rec emit_structured_constant symb cst cont = + let emit_block white_header symb cont = + (* Headers for structured constants must be marked black in case we + are in no-naked-pointers mode. See [caml_darken]. *) + let black_header = Nativeint.logor white_header caml_black in + Cint black_header :: Cdefine_symbol symb :: cont + in match cst with - Const_base(Const_float s) -> - Cint(float_header) :: Cdefine_symbol symb :: Cdouble s :: cont - | Const_base(Const_string s) | Const_immstring s -> - Cint(string_header (String.length s)) :: - Cdefine_symbol symb :: - emit_string_constant s cont - | Const_base(Const_int32 n) -> - Cint(boxedint32_header) :: Cdefine_symbol symb :: - emit_boxed_int32_constant n cont - | Const_base(Const_int64 n) -> - Cint(boxedint64_header) :: Cdefine_symbol symb :: - emit_boxed_int64_constant n cont - | Const_base(Const_nativeint n) -> - Cint(boxedintnat_header) :: Cdefine_symbol symb :: - emit_boxed_nativeint_constant n cont - | Const_block(tag, fields) -> - let (emit_fields, cont1) = emit_constant_fields fields cont in - Cint(block_header tag (List.length fields)) :: - Cdefine_symbol symb :: - emit_fields @ cont1 - | Const_float_array(fields) -> - Cint(floatarray_header (List.length fields)) :: - Cdefine_symbol symb :: - Misc.map_end (fun f -> Cdouble f) fields cont - | _ -> fatal_error "gencmm.emit_constant" + | Uconst_float s-> + emit_block float_header symb (Cdouble s :: cont) + | Uconst_string s -> + emit_block (string_header (String.length s)) symb + (emit_string_constant s cont) + | Uconst_int32 n -> + emit_block boxedint32_header symb + (emit_boxed_int32_constant n cont) + | Uconst_int64 n -> + emit_block boxedint64_header symb + (emit_boxed_int64_constant n cont) + | Uconst_nativeint n -> + emit_block boxedintnat_header symb + (emit_boxed_nativeint_constant n cont) + | Uconst_block (tag, csts) -> + let cont = List.fold_right emit_constant csts cont in + emit_block (block_header tag (List.length csts)) symb cont + | Uconst_float_array fields -> + emit_block (floatarray_header (List.length fields)) symb + (Misc.map_end (fun f -> Cdouble f) fields cont) -and emit_constant_fields fields cont = - match fields with - [] -> ([], cont) - | f1 :: fl -> - let (data1, cont1) = emit_constant_field f1 cont in - let (datal, contl) = emit_constant_fields fl cont1 in - (data1 :: datal, contl) - -and emit_constant_field field cont = - match field with - Const_base(Const_int n) -> - (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n), - cont) - | Const_base(Const_char c) -> - (Cint(Nativeint.of_int(((Char.code c) lsl 1) + 1)), cont) - | Const_base(Const_float s) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(float_header) :: Cdefine_label lbl :: Cdouble s :: cont) - | Const_base(Const_string s) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(string_header (String.length s)) :: Cdefine_label lbl :: - emit_string_constant s cont) - | Const_immstring s -> - begin try - (Clabel_address (Hashtbl.find immstrings s), cont) - with Not_found -> - let lbl = Compilenv.new_const_label() in - Hashtbl.add immstrings s lbl; - (Clabel_address lbl, - Cint(string_header (String.length s)) :: Cdefine_label lbl :: - emit_string_constant s cont) - end - | Const_base(Const_int32 n) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(boxedint32_header) :: Cdefine_label lbl :: - emit_boxed_int32_constant n cont) - | Const_base(Const_int64 n) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(boxedint64_header) :: Cdefine_label lbl :: - emit_boxed_int64_constant n cont) - | Const_base(Const_nativeint n) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(boxedintnat_header) :: Cdefine_label lbl :: - emit_boxed_nativeint_constant n cont) - | Const_pointer n -> - (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n), - cont) - | Const_block(tag, fields) -> - let lbl = Compilenv.new_const_label() in - let (emit_fields, cont1) = emit_constant_fields fields cont in - (Clabel_address lbl, - Cint(block_header tag (List.length fields)) :: Cdefine_label lbl :: - emit_fields @ cont1) - | Const_float_array(fields) -> - let lbl = Compilenv.new_const_label() in - (Clabel_address lbl, - Cint(floatarray_header (List.length fields)) :: Cdefine_label lbl :: - Misc.map_end (fun f -> Cdouble f) fields cont) +and emit_constant cst cont = + match cst with + | Uconst_int n | Uconst_ptr n -> + Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n) + :: cont + | Uconst_ref (label, _) -> + Csymbol_address label :: cont and emit_string_constant s cont = let n = size_int - 1 - (String.length s) mod size_int in @@ -2075,7 +2304,7 @@ Cint(Nativeint.of_int (f2.arity lsl 1 + 1)) :: Csymbol_address f2.label :: emit_others (pos + 4) rem in - Cint(closure_header (fundecls_size fundecls)) :: + Cint(black_closure_header (fundecls_size fundecls)) :: Cdefine_symbol symb :: if f1.arity = 1 then Csymbol_address f1.label :: @@ -2093,14 +2322,12 @@ let c = ref cont in List.iter (fun (lbl, global, cst) -> - let cst = emit_constant lbl cst [] in + let cst = emit_structured_constant lbl cst [] in let cst = if global then Cglobal_symbol lbl :: cst else cst in c:= Cdata(cst):: !c) (Compilenv.structured_constants()); -(* structured_constants := []; done in Compilenv.reset() *) - Hashtbl.clear immstrings; (* PR#3979 *) List.iter (fun (symb, fundecls) -> c := Cdata(emit_constant_closure symb fundecls []) :: !c) @@ -2119,10 +2346,18 @@ fun_dbg = Debuginfo.none }] in let c2 = transl_all_functions StringSet.empty c1 in let c3 = emit_all_constants c2 in - Cdata [Cint(block_header 0 size); + let space = + (* These words will be registered as roots and as such must contain + valid values, in case we are in no-naked-pointers mode. Likewise + the block header must be black, below (see [caml_darken]), since + the overall record may be referenced. *) + Array.to_list + (Array.init size (fun _index -> + Cint (Nativeint.of_int 1 (* Val_unit *)))) + in + Cdata ([Cint(black_block_header 0 size); Cglobal_symbol glob; - Cdefine_symbol glob; - Cskip(size * size_addr)] :: c3 + Cdefine_symbol glob] @ space) :: c3 (* CAMLprim value caml_cache_public_method (value meths, value tag, value *cache) @@ -2186,7 +2421,7 @@ *) let apply_function_body arity = - let arg = Array.create arity (Ident.create "arg") in + let arg = Array.make arity (Ident.create "arg") in for i = 1 to arity - 1 do arg.(i) <- Ident.create "arg" done; let clos = Ident.create "clos" in let rec app_fun clos n = @@ -2466,8 +2701,8 @@ let global_data name v = Cdata(Cglobal_symbol name :: - emit_constant name - (Const_base (Const_string (Marshal.to_string v []))) []) + emit_structured_constant name + (Uconst_string (Marshal.to_string v [])) []) let globals_map v = global_data "caml_globals_map" v @@ -2502,15 +2737,18 @@ (* Initialize a predefined exception *) -let predef_exception name = - let bucketname = "caml_bucket_" ^ name in +let predef_exception i name = let symname = "caml_exn_" ^ name in + let cst = Uconst_string name in + let label = Compilenv.new_const_symbol () in + let cont = emit_structured_constant label cst [] in Cdata(Cglobal_symbol symname :: - emit_constant symname (Const_block(0,[Const_base(Const_string name)])) - [ Cglobal_symbol bucketname; - Cint(block_header 0 1); - Cdefine_symbol bucketname; - Csymbol_address symname ]) + emit_structured_constant symname + (Uconst_block(Obj.object_tag, + [ + Uconst_ref(label, cst); + Uconst_int (-i-1); + ])) cont) (* Header for a plugin *) diff -Nru ocaml-4.01.0/asmcomp/cmmgen.mli ocaml-4.02.3/asmcomp/cmmgen.mli --- ocaml-4.01.0/asmcomp/cmmgen.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/cmmgen.mli 2013-11-13 14:55:13.000000000 +0100 @@ -26,5 +26,5 @@ val frame_table: string list -> Cmm.phrase val data_segment_table: string list -> Cmm.phrase val code_segment_table: string list -> Cmm.phrase -val predef_exception: string -> Cmm.phrase +val predef_exception: int -> string -> Cmm.phrase val plugin_header: (Cmx_format.unit_infos * Digest.t) list -> Cmm.phrase diff -Nru ocaml-4.01.0/asmcomp/cmm.ml ocaml-4.02.3/asmcomp/cmm.ml --- ocaml-4.01.0/asmcomp/cmm.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/cmm.ml 2014-04-25 10:41:13.000000000 +0200 @@ -70,7 +70,7 @@ | Cload of memory_chunk | Calloc | Cstore of memory_chunk - | Caddi | Csubi | Cmuli | Cdivi | Cmodi + | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Ccmpi of comparison | Cadda | Csuba @@ -79,16 +79,17 @@ | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf of comparison - | Craise of Debuginfo.t + | Craise of Lambda.raise_kind * Debuginfo.t | Ccheckbound of Debuginfo.t type expression = Cconst_int of int | Cconst_natint of nativeint - | Cconst_float of string + | Cconst_float of float | Cconst_symbol of string | Cconst_pointer of int | Cconst_natpointer of nativeint + | Cconst_blockheader of nativeint | Cvar of Ident.t | Clet of Ident.t * expression * expression | Cassign of Ident.t * expression @@ -117,8 +118,8 @@ | Cint16 of int | Cint32 of nativeint | Cint of nativeint - | Csingle of string - | Cdouble of string + | Csingle of float + | Cdouble of float | Csymbol_address of string | Clabel_address of int | Cstring of string diff -Nru ocaml-4.01.0/asmcomp/cmm.mli ocaml-4.02.3/asmcomp/cmm.mli --- ocaml-4.01.0/asmcomp/cmm.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/cmm.mli 2014-04-25 10:41:13.000000000 +0200 @@ -56,7 +56,7 @@ | Cload of memory_chunk | Calloc | Cstore of memory_chunk - | Caddi | Csubi | Cmuli | Cdivi | Cmodi + | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Ccmpi of comparison | Cadda | Csuba @@ -65,16 +65,17 @@ | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf of comparison - | Craise of Debuginfo.t + | Craise of Lambda.raise_kind * Debuginfo.t | Ccheckbound of Debuginfo.t type expression = Cconst_int of int | Cconst_natint of nativeint - | Cconst_float of string + | Cconst_float of float | Cconst_symbol of string | Cconst_pointer of int | Cconst_natpointer of nativeint + | Cconst_blockheader of nativeint | Cvar of Ident.t | Clet of Ident.t * expression * expression | Cassign of Ident.t * expression @@ -103,8 +104,8 @@ | Cint16 of int | Cint32 of nativeint | Cint of nativeint - | Csingle of string - | Cdouble of string + | Csingle of float + | Cdouble of float | Csymbol_address of string | Clabel_address of int | Cstring of string diff -Nru ocaml-4.01.0/asmcomp/cmx_format.mli ocaml-4.02.3/asmcomp/cmx_format.mli --- ocaml-4.01.0/asmcomp/cmx_format.mli 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/asmcomp/cmx_format.mli 2014-05-07 02:34:20.000000000 +0200 @@ -26,8 +26,9 @@ { mutable ui_name: string; (* Name of unit implemented *) mutable ui_symbol: string; (* Prefix for symbols *) mutable ui_defines: string list; (* Unit and sub-units implemented *) - mutable ui_imports_cmi: (string * Digest.t) list; (* Interfaces imported *) - mutable ui_imports_cmx: (string * Digest.t) list; (* Infos imported *) + mutable ui_imports_cmi: + (string * Digest.t option) list; (* Interfaces imported *) + mutable ui_imports_cmx:(string * Digest.t option) list; (* Infos imported *) mutable ui_approx: Clambda.value_approximation; (* Approx of the structure*) mutable ui_curry_fun: int list; (* Currying functions needed *) mutable ui_apply_fun: int list; (* Apply functions needed *) @@ -49,8 +50,8 @@ type dynunit = { dynu_name: string; dynu_crc: Digest.t; - dynu_imports_cmi: (string * Digest.t) list; - dynu_imports_cmx: (string * Digest.t) list; + dynu_imports_cmi: (string * Digest.t option) list; + dynu_imports_cmx: (string * Digest.t option) list; dynu_defines: string list; } diff -Nru ocaml-4.01.0/asmcomp/coloring.ml ocaml-4.02.3/asmcomp/coloring.ml --- ocaml-4.01.0/asmcomp/coloring.ml 2013-01-13 17:57:36.000000000 +0100 +++ ocaml-4.02.3/asmcomp/coloring.ml 2014-08-18 20:26:49.000000000 +0200 @@ -47,7 +47,7 @@ if reg.spill then begin (* Preallocate the registers in the stack *) let nslots = Proc.num_stack_slots.(cl) in - let conflict = Array.create nslots false in + let conflict = Array.make nslots false in List.iter (fun r -> match r.loc with @@ -84,14 +84,14 @@ (* Where to start the search for a suitable register. Used to introduce some "randomness" in the choice between registers with equal scores. This offers more opportunities for scheduling. *) - let start_register = Array.create Proc.num_register_classes 0 in + let start_register = Array.make Proc.num_register_classes 0 in (* Assign a location to a register, the best we can. *) let assign_location reg = let cl = Proc.register_class reg in let first_reg = Proc.first_available_register.(cl) in let num_regs = Proc.num_available_registers.(cl) in - let score = Array.create num_regs 0 in + let score = Array.make num_regs 0 in let best_score = ref (-1000000) and best_reg = ref (-1) in let start = start_register.(cl) in if num_regs <> 0 then begin @@ -161,7 +161,7 @@ end else begin (* Sorry, we must put the pseudoreg in a stack location *) let nslots = Proc.num_stack_slots.(cl) in - let score = Array.create nslots 0 in + let score = Array.make nslots 0 in (* Compute the scores as for registers *) List.iter (fun (r, w) -> diff -Nru ocaml-4.01.0/asmcomp/comballoc.ml ocaml-4.02.3/asmcomp/comballoc.ml --- ocaml-4.01.0/asmcomp/comballoc.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/comballoc.ml 2013-11-13 14:55:13.000000000 +0100 @@ -27,7 +27,7 @@ let rec combine i allocstate = match i.desc with - Iend | Ireturn | Iexit _ | Iraise -> + Iend | Ireturn | Iexit _ | Iraise _ -> (i, allocated_size allocstate) | Iop(Ialloc sz) -> begin match allocstate with diff -Nru ocaml-4.01.0/asmcomp/compilenv.ml ocaml-4.02.3/asmcomp/compilenv.ml --- ocaml-4.01.0/asmcomp/compilenv.ml 2013-07-23 16:48:47.000000000 +0200 +++ ocaml-4.02.3/asmcomp/compilenv.ml 2014-05-25 18:45:09.000000000 +0200 @@ -27,8 +27,30 @@ let global_infos_table = (Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t) -let structured_constants = - ref ([] : (string * bool * Lambda.structured_constant) list) +module CstMap = + Map.Make(struct + type t = Clambda.ustructured_constant + let compare = Clambda.compare_structured_constants + (* PR#6442: it is incorrect to use Pervasives.compare on values of type t + because it compares "0.0" and "-0.0" equal. *) + end) + +type structured_constants = + { + strcst_shared: string CstMap.t; + strcst_all: (string * Clambda.ustructured_constant) list; + } + +let structured_constants_empty = + { + strcst_shared = CstMap.empty; + strcst_all = []; + } + +let structured_constants = ref structured_constants_empty + + +let exported_constants = Hashtbl.create 17 let current_unit = { ui_name = ""; @@ -69,7 +91,8 @@ current_unit.ui_apply_fun <- []; current_unit.ui_send_fun <- []; current_unit.ui_force_link <- false; - structured_constants := [] + Hashtbl.clear exported_constants; + structured_constants := structured_constants_empty let current_unit_infos () = current_unit @@ -83,10 +106,19 @@ | None -> prefix | Some id -> prefix ^ "__" ^ id +let symbol_in_current_unit name = + let prefix = "caml" ^ current_unit.ui_symbol in + name = prefix || + (let lp = String.length prefix in + String.length name >= 2 + lp + && String.sub name 0 lp = prefix + && name.[lp] = '_' + && name.[lp + 1] = '_') + let read_unit_info filename = let ic = open_in_bin filename in try - let buffer = input_bytes ic (String.length cmx_magic_number) in + let buffer = really_input_string ic (String.length cmx_magic_number) in if buffer <> cmx_magic_number then begin close_in ic; raise(Error(Not_a_unit_info filename)) @@ -101,7 +133,7 @@ let read_library_info filename = let ic = open_in_bin filename in - let buffer = input_bytes ic (String.length cmxa_magic_number) in + let buffer = really_input_string ic (String.length cmxa_magic_number) in if buffer <> cmxa_magic_number then raise(Error(Not_a_unit_info filename)); let infos = (input_value ic : library_infos) in @@ -111,9 +143,6 @@ (* Read and cache info on global identifiers *) -let cmx_not_found_crc = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" - let get_global_info global_ident = ( let modname = Ident.name global_ident in if modname = current_unit.ui_name then @@ -129,9 +158,9 @@ let (ui, crc) = read_unit_info filename in if ui.ui_name <> modname then raise(Error(Illegal_renaming(modname, ui.ui_name, filename))); - (Some ui, crc) + (Some ui, Some crc) with Not_found -> - (None, cmx_not_found_crc) in + (None, None) in current_unit.ui_imports_cmx <- (modname, crc) :: current_unit.ui_imports_cmx; Hashtbl.add global_infos_table modname infos; @@ -199,7 +228,7 @@ close_out oc let save_unit_info filename = - current_unit.ui_imports_cmi <- Env.imported_units(); + current_unit.ui_imports_cmi <- Env.imports(); write_unit_info current_unit filename @@ -214,12 +243,39 @@ incr const_label; make_symbol (Some (string_of_int !const_label)) -let new_structured_constant cst global = - let lbl = new_const_symbol() in - structured_constants := (lbl, global, cst) :: !structured_constants; - lbl +let snapshot () = !structured_constants +let backtrack s = structured_constants := s -let structured_constants () = !structured_constants +let new_structured_constant cst ~shared = + let {strcst_shared; strcst_all} = !structured_constants in + if shared then + try + CstMap.find cst strcst_shared + with Not_found -> + let lbl = new_const_symbol() in + structured_constants := + { + strcst_shared = CstMap.add cst lbl strcst_shared; + strcst_all = (lbl, cst) :: strcst_all; + }; + lbl + else + let lbl = new_const_symbol() in + structured_constants := + { + strcst_shared; + strcst_all = (lbl, cst) :: strcst_all; + }; + lbl + +let add_exported_constant s = + Hashtbl.replace exported_constants s () + +let structured_constants () = + List.map + (fun (lbl, cst) -> + (lbl, Hashtbl.mem exported_constants lbl, cst) + ) (!structured_constants).strcst_all (* Error report *) @@ -236,3 +292,10 @@ fprintf ppf "%a@ contains the description for unit\ @ %s when %s was expected" Location.print_filename filename name modname + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff -Nru ocaml-4.01.0/asmcomp/compilenv.mli ocaml-4.02.3/asmcomp/compilenv.mli --- ocaml-4.01.0/asmcomp/compilenv.mli 2013-04-29 16:57:38.000000000 +0200 +++ ocaml-4.02.3/asmcomp/compilenv.mli 2014-05-07 02:34:20.000000000 +0200 @@ -31,6 +31,10 @@ corresponds to symbol [id] in the compilation unit [u] (or the current unit). *) +val symbol_in_current_unit: string -> bool + (* Return true if the given asm symbol belongs to the + current compilation unit, false otherwise. *) + val symbol_for_global: Ident.t -> string (* Return the asm symbol that refers to the given global identifier *) @@ -50,9 +54,19 @@ val new_const_symbol : unit -> string val new_const_label : unit -> int -val new_structured_constant : Lambda.structured_constant -> bool -> string -val structured_constants : - unit -> (string * bool * Lambda.structured_constant) list + +val new_structured_constant: + Clambda.ustructured_constant -> + shared:bool -> (* can be shared with another structually equal constant *) + string +val structured_constants: + unit -> (string * bool * Clambda.ustructured_constant) list +val add_exported_constant: string -> unit + +type structured_constants +val snapshot: unit -> structured_constants +val backtrack: structured_constants -> unit + val read_unit_info: string -> unit_infos * Digest.t (* Read infos and MD5 from a [.cmx] file. *) @@ -65,10 +79,6 @@ honored by [symbol_for_global] and [global_approx] without looking at the corresponding .cmx file. *) -val cmx_not_found_crc: Digest.t - (* Special digest used in the [ui_imports_cmx] list to signal - that no [.cmx] file was found and used for the imported unit *) - val read_library_info: string -> library_infos type error = diff -Nru ocaml-4.01.0/asmcomp/CSEgen.ml ocaml-4.02.3/asmcomp/CSEgen.ml --- ocaml-4.01.0/asmcomp/CSEgen.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/CSEgen.ml 2014-10-09 11:21:33.000000000 +0200 @@ -0,0 +1,322 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Common subexpression elimination by value numbering over extended + basic blocks. *) + +open Mach + +type valnum = int + +(* We maintain sets of equations of the form + valnums = operation(valnums) + plus a mapping from registers to valnums (value numbers). *) + +type rhs = operation * valnum array + +module Equations = + Map.Make(struct type t = rhs let compare = Pervasives.compare end) + +type numbering = + { num_next: int; (* next fresh value number *) + num_eqs: valnum array Equations.t; (* mapping rhs -> valnums *) + num_reg: valnum Reg.Map.t } (* mapping register -> valnum *) + +let empty_numbering = + { num_next = 0; num_eqs = Equations.empty; num_reg = Reg.Map.empty } + +(** Generate a fresh value number [v] and associate it to register [r]. + Returns a pair [(n',v)] with the updated value numbering [n']. *) + +let fresh_valnum_reg n r = + let v = n.num_next in + ({n with num_next = v + 1; num_reg = Reg.Map.add r v n.num_reg}, v) + +(* Same, for a set of registers [rs]. *) + +let array_fold_transf (f: numbering -> 'a -> numbering * 'b) n (a: 'a array) + : numbering * 'b array = + match Array.length a with + | 0 -> (n, [||]) + | 1 -> let (n', b) = f n a.(0) in (n', [|b|]) + | l -> let b = Array.make l 0 and n = ref n in + for i = 0 to l - 1 do + let (n', x) = f !n a.(i) in + b.(i) <- x; n := n' + done; + (!n, b) + +let fresh_valnum_regs n rs = + array_fold_transf fresh_valnum_reg n rs + +(** [valnum_reg n r] returns the value number for the contents of + register [r]. If none exists, a fresh value number is returned + and associated with register [r]. The possibly updated numbering + is also returned. [valnum_regs] is similar, but for an array of + registers. *) + +let valnum_reg n r = + try + (n, Reg.Map.find r n.num_reg) + with Not_found -> + fresh_valnum_reg n r + +let valnum_regs n rs = + array_fold_transf valnum_reg n rs + +(* Look up the set of equations for an equation with the given rhs. + Return [Some res] if there is one, where [res] is the lhs. *) + +let find_equation n rhs = + try + Some(Equations.find rhs n.num_eqs) + with Not_found -> + None + +(* Find a register containing the given value number. *) + +let find_reg_containing n v = + Reg.Map.fold (fun r v' res -> if v' = v then Some r else res) + n.num_reg None + +(* Find a set of registers containing the given value numbers. *) + +let find_regs_containing n vs = + match Array.length vs with + | 0 -> Some [||] + | 1 -> begin match find_reg_containing n vs.(0) with + | None -> None + | Some r -> Some [|r|] + end + | l -> let rs = Array.make l Reg.dummy in + begin try + for i = 0 to l - 1 do + match find_reg_containing n vs.(i) with + | None -> raise Exit + | Some r -> rs.(i) <- r + done; + Some rs + with Exit -> + None + end + +(* Associate the given value number to the given result register, + without adding new equations. *) + +let set_known_reg n r v = + { n with num_reg = Reg.Map.add r v n.num_reg } + +(* Associate the given value numbers to the given result registers, + without adding new equations. *) + +let array_fold2 f n a1 a2 = + let l = Array.length a1 in + assert (l = Array.length a2); + let n = ref n in + for i = 0 to l - 1 do n := f !n a1.(i) a2.(i) done; + !n + +let set_known_regs n rs vs = + array_fold2 set_known_reg n rs vs + +(* Record the effect of a move: no new equations, but the result reg + maps to the same value number as the argument reg. *) + +let set_move n src dst = + let (n1, v) = valnum_reg n src in + { n1 with num_reg = Reg.Map.add dst v n1.num_reg } + +(* Record the equation [fresh valnums = rhs] and associate the given + result registers [rs] to [fresh valnums]. *) + +let set_fresh_regs n rs rhs = + let (n1, vs) = fresh_valnum_regs n rs in + { n1 with num_eqs = Equations.add rhs vs n.num_eqs } + +(* Forget everything we know about the given result registers, + which are receiving unpredictable values at run-time. *) + +let set_unknown_regs n rs = + { n with num_reg = Array.fold_right Reg.Map.remove rs n.num_reg } + +(* Keep only the equations satisfying the given predicate. *) + +let filter_equations pred n = + { n with num_eqs = Equations.filter (fun (op,_) res -> pred op) n.num_eqs } + +(* Prepend a set of moves before [i] to assign [srcs] to [dsts]. *) + +let insert_single_move i src dst = instr_cons (Iop Imove) [|src|] [|dst|] i + +let insert_move srcs dsts i = + match Array.length srcs with + | 0 -> i + | 1 -> instr_cons (Iop Imove) srcs dsts i + | l -> (* Parallel move: first copy srcs into tmps one by one, + then copy tmps into dsts one by one *) + let tmps = Reg.createv_like srcs in + let i1 = array_fold2 insert_single_move i tmps dsts in + array_fold2 insert_single_move i1 srcs tmps + +(* Classification of operations *) + +type op_class = + | Op_pure (* pure arithmetic, produce one or several result *) + | Op_checkbound (* checkbound-style: no result, can raise an exn *) + | Op_load (* memory load *) + | Op_store of bool (* memory store, false = init, true = assign *) + | Op_other (* anything else that does not allocate nor store in memory *) + +class cse_generic = object (self) + +(* Default classification of operations. Can be overriden in + processor-specific files to classify specific operations better. *) + +method class_of_operation op = + match op with + | Imove | Ispill | Ireload -> assert false (* treated specially *) + | Iconst_int _ | Iconst_float _ | Iconst_symbol _ + | Iconst_blockheader _ -> Op_pure + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ -> assert false (* treated specially *) + | Istackoffset _ -> Op_other + | Iload(_,_) -> Op_load + | Istore(_,_,asg) -> Op_store asg + | Ialloc _ -> assert false (* treated specially *) + | Iintop(Icheckbound) -> Op_checkbound + | Iintop _ -> Op_pure + | Iintop_imm(Icheckbound, _) -> Op_checkbound + | Iintop_imm(_, _) -> Op_pure + | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Ifloatofint | Iintoffloat -> Op_pure + | Ispecific _ -> Op_other + +(* Operations that are so cheap that it isn't worth factoring them. *) + +method is_cheap_operation op = + match op with + | Iconst_int _ | Iconst_blockheader _ -> true + | _ -> false + +(* Forget all equations involving memory loads. Performed after a + non-initializing store *) + +method private kill_loads n = + filter_equations (fun o -> self#class_of_operation o <> Op_load) n + +(* Perform CSE on the given instruction [i] and its successors. + [n] is the value numbering current at the beginning of [i]. *) + +method private cse n i = + match i.desc with + | Iend | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) + | Iexit _ | Iraise _ -> + i + | Iop (Imove | Ispill | Ireload) -> + (* For moves, we associate the same value number to the result reg + as to the argument reg. *) + let n1 = set_move n i.arg.(0) i.res.(0) in + {i with next = self#cse n1 i.next} + | Iop (Icall_ind | Icall_imm _ | Iextcall _) -> + (* For function calls, we should at least forget: + - equations involving memory loads, since the callee can + perform arbitrary memory stores; + - equations involving arithmetic operations that can + produce bad pointers into the heap (see below for Ialloc); + - mappings from hardware registers to value numbers, + since the callee does not preserve these registers. + That doesn't leave much usable information: checkbounds + could be kept, but won't be usable for CSE as one of their + arguments is always a memory load. For simplicity, we + just forget everything. *) + {i with next = self#cse empty_numbering i.next} + | Iop (Ialloc _) -> + (* For allocations, we must avoid extending the live range of a + pseudoregister across the allocation if this pseudoreg can + contain a value that looks like a pointer into the heap but + is not a pointer to the beginning of a Caml object. PR#6484 + is an example of such a value (a derived pointer into a + block). In the absence of more precise typing information, + we just forget everything. *) + {i with next = self#cse empty_numbering i.next} + | Iop op -> + begin match self#class_of_operation op with + | Op_pure | Op_checkbound | Op_load -> + let (n1, varg) = valnum_regs n i.arg in + let n2 = set_unknown_regs n1 (Proc.destroyed_at_oper i.desc) in + begin match find_equation n1 (op, varg) with + | Some vres -> + (* This operation was computed earlier. *) + (* Are there registers that hold the results computed earlier? *) + begin match find_regs_containing n1 vres with + | Some res when (not (self#is_cheap_operation op)) + && (not (Proc.regs_are_volatile res)) -> + (* We can replace res <- op args with r <- move res, + provided res are stable (non-volatile) registers. + If the operation is very cheap to compute, e.g. + an integer constant, don't bother. *) + let n3 = set_known_regs n1 i.res vres in + (* This is n1 above and not n2 because the move + does not destroy any regs *) + insert_move res i.res (self#cse n3 i.next) + | _ -> + (* We already computed the operation but lost its + results. Associate the result registers to + the result valnums of the previous operation. *) + let n3 = set_known_regs n2 i.res vres in + {i with next = self#cse n3 i.next} + end + | None -> + (* This operation produces a result we haven't seen earlier. *) + let n3 = set_fresh_regs n2 i.res (op, varg) in + {i with next = self#cse n3 i.next} + end + | Op_store false | Op_other -> + (* An initializing store or an "other" operation do not invalidate + any equations, but we do not know anything about the results. *) + let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in + let n2 = set_unknown_regs n1 i.res in + {i with next = self#cse n2 i.next} + | Op_store true -> + (* A non-initializing store can invalidate + anything we know about prior loads. *) + let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in + let n2 = set_unknown_regs n1 i.res in + let n3 = self#kill_loads n2 in + {i with next = self#cse n3 i.next} + end + (* For control structures, we set the numbering to empty at every + join point, but propagate the current numbering across fork points. *) + | Iifthenelse(test, ifso, ifnot) -> + let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in + {i with desc = Iifthenelse(test, self#cse n1 ifso, self#cse n1 ifnot); + next = self#cse empty_numbering i.next} + | Iswitch(index, cases) -> + let n1 = set_unknown_regs n (Proc.destroyed_at_oper i.desc) in + {i with desc = Iswitch(index, Array.map (self#cse n1) cases); + next = self#cse empty_numbering i.next} + | Iloop(body) -> + {i with desc = Iloop(self#cse empty_numbering body); + next = self#cse empty_numbering i.next} + | Icatch(nfail, body, handler) -> + {i with desc = Icatch(nfail, self#cse n body, + self#cse empty_numbering handler); + next = self#cse empty_numbering i.next} + | Itrywith(body, handler) -> + {i with desc = Itrywith(self#cse n body, + self#cse empty_numbering handler); + next = self#cse empty_numbering i.next} + +method fundecl f = + {f with fun_body = self#cse empty_numbering f.fun_body} + +end diff -Nru ocaml-4.01.0/asmcomp/CSEgen.mli ocaml-4.02.3/asmcomp/CSEgen.mli --- ocaml-4.01.0/asmcomp/CSEgen.mli 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/CSEgen.mli 2014-07-18 16:07:35.000000000 +0200 @@ -0,0 +1,35 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Common subexpression elimination by value numbering over extended + basic blocks. *) + +type op_class = + | Op_pure (* pure, produce one result *) + | Op_checkbound (* checkbound-style: no result, can raise an exn *) + | Op_load (* memory load *) + | Op_store of bool (* memory store, false = init, true = assign *) + | Op_other (* anything else that does not allocate nor store in memory *) + +class cse_generic : object + (* The following methods can be overriden to handle processor-specific + operations. *) + + method class_of_operation: Mach.operation -> op_class + + method is_cheap_operation: Mach.operation -> bool + (* Operations that are so cheap that it isn't worth factoring them. *) + + (* The following method is the entry point and should not be overridden *) + method fundecl: Mach.fundecl -> Mach.fundecl + +end diff -Nru ocaml-4.01.0/asmcomp/deadcode.ml ocaml-4.02.3/asmcomp/deadcode.ml --- ocaml-4.01.0/asmcomp/deadcode.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/deadcode.ml 2014-05-16 16:52:07.000000000 +0200 @@ -0,0 +1,67 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Dead code elimination: remove pure instructions whose results are + not used. *) + +open Mach + +(* [deadcode i] returns a pair of an optimized instruction [i'] + and a set of registers live "before" instruction [i]. *) + +let rec deadcode i = + match i.desc with + | Iend | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) | Iraise _ -> + (i, Reg.add_set_array i.live i.arg) + | Iop op -> + let (s, before) = deadcode i.next in + if Proc.op_is_pure op (* no side effects *) + && Reg.disjoint_set_array before i.res (* results are not used after *) + && not (Proc.regs_are_volatile i.arg) (* no stack-like hard reg *) + && not (Proc.regs_are_volatile i.res) (* is involved *) + then begin + assert (Array.length i.res > 0); (* sanity check *) + (s, before) + end else begin + ({i with next = s}, Reg.add_set_array i.live i.arg) + end + | Iifthenelse(test, ifso, ifnot) -> + let (ifso', _) = deadcode ifso in + let (ifnot', _) = deadcode ifnot in + let (s, _) = deadcode i.next in + ({i with desc = Iifthenelse(test, ifso', ifnot'); next = s}, + Reg.add_set_array i.live i.arg) + | Iswitch(index, cases) -> + let cases' = Array.map (fun c -> fst (deadcode c)) cases in + let (s, _) = deadcode i.next in + ({i with desc = Iswitch(index, cases'); next = s}, + Reg.add_set_array i.live i.arg) + | Iloop(body) -> + let (body', _) = deadcode body in + let (s, _) = deadcode i.next in + ({i with desc = Iloop body'; next = s}, i.live) + | Icatch(nfail, body, handler) -> + let (body', _) = deadcode body in + let (handler', _) = deadcode handler in + let (s, _) = deadcode i.next in + ({i with desc = Icatch(nfail, body', handler'); next = s}, i.live) + | Iexit nfail -> + (i, i.live) + | Itrywith(body, handler) -> + let (body', _) = deadcode body in + let (handler', _) = deadcode handler in + let (s, _) = deadcode i.next in + ({i with desc = Itrywith(body', handler'); next = s}, i.live) + +let fundecl f = + let (new_body, _) = deadcode f.fun_body in + {f with fun_body = new_body} diff -Nru ocaml-4.01.0/asmcomp/deadcode.mli ocaml-4.02.3/asmcomp/deadcode.mli --- ocaml-4.01.0/asmcomp/deadcode.mli 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/deadcode.mli 2014-04-26 11:38:29.000000000 +0200 @@ -0,0 +1,16 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Dead code elimination: remove pure instructions whose results are + not used. *) + +val fundecl: Mach.fundecl -> Mach.fundecl diff -Nru ocaml-4.01.0/asmcomp/emitaux.ml ocaml-4.02.3/asmcomp/emitaux.ml --- ocaml-4.01.0/asmcomp/emitaux.ml 2013-06-03 20:03:59.000000000 +0200 +++ ocaml-4.02.3/asmcomp/emitaux.ml 2015-05-06 19:37:43.000000000 +0200 @@ -88,16 +88,10 @@ done; if !pos > 0 then emit_char '\n' -(* PR#4813: assemblers do strange things with float literals indeed, - so we convert to IEEE representation ourselves and emit float - literals as 32- or 64-bit integers. *) - -let emit_float64_directive directive f = - let x = Int64.bits_of_float (float_of_string f) in +let emit_float64_directive directive x = emit_printf "\t%s\t0x%Lx\n" directive x -let emit_float64_split_directive directive f = - let x = Int64.bits_of_float (float_of_string f) in +let emit_float64_split_directive directive x = let lo = Int64.logand x 0xFFFF_FFFFL and hi = Int64.shift_right_logical x 32 in emit_printf "\t%s\t0x%Lx, 0x%Lx\n" @@ -105,8 +99,7 @@ (if Arch.big_endian then hi else lo) (if Arch.big_endian then lo else hi) -let emit_float32_directive directive f = - let x = Int32.bits_of_float (float_of_string f) in +let emit_float32_directive directive x = emit_printf "\t%s\t0x%lx\n" directive x (* Record live pointers at call points *) @@ -202,6 +195,15 @@ emit_string "\t.cfi_adjust_cfa_offset\t"; emit_int n; emit_string "\n"; end +let cfi_offset ~reg ~offset = + if is_cfi_enabled () then begin + emit_string "\t.cfi_offset "; + emit_int reg; + emit_string ", "; + emit_int offset; + emit_string "\n" + end + (* Emit debug information *) (* This assoc list is expected to be very short *) @@ -221,9 +223,9 @@ let emit_debug_info dbg = if is_cfi_enabled () && (!Clflags.debug || Config.with_frame_pointers) - && not (Debuginfo.is_none dbg) then begin + && dbg.Debuginfo.dinfo_line > 0 (* PR#6243 *) + then begin let line = dbg.Debuginfo.dinfo_line in - assert (line <> 0); (* clang errors out on zero line numbers *) let file_name = dbg.Debuginfo.dinfo_file in let file_num = try List.assoc file_name !file_pos_nums @@ -239,3 +241,7 @@ emit_int file_num; emit_char '\t'; emit_int line; emit_char '\n' end + +let reset () = + reset_debug_info (); + frame_descriptors := [] diff -Nru ocaml-4.01.0/asmcomp/emitaux.mli ocaml-4.02.3/asmcomp/emitaux.mli --- ocaml-4.01.0/asmcomp/emitaux.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/emitaux.mli 2015-05-06 19:37:43.000000000 +0200 @@ -23,10 +23,11 @@ val emit_string_literal: string -> unit val emit_string_directive: string -> string -> unit val emit_bytes_directive: string -> string -> unit -val emit_float64_directive: string -> string -> unit -val emit_float64_split_directive: string -> string -> unit -val emit_float32_directive: string -> string -> unit +val emit_float64_directive: string -> int64 -> unit +val emit_float64_split_directive: string -> int64 -> unit +val emit_float32_directive: string -> int32 -> unit +val reset : unit -> unit val reset_debug_info: unit -> unit val emit_debug_info: Debuginfo.t -> unit @@ -55,3 +56,4 @@ val cfi_startproc : unit -> unit val cfi_endproc : unit -> unit val cfi_adjust_cfa_offset : int -> unit +val cfi_offset : reg:int -> offset:int -> unit diff -Nru ocaml-4.01.0/asmcomp/i386/arch.ml ocaml-4.02.3/asmcomp/i386/arch.ml --- ocaml-4.01.0/asmcomp/i386/arch.ml 2012-11-09 17:15:29.000000000 +0100 +++ ocaml-4.02.3/asmcomp/i386/arch.ml 2014-06-02 19:10:31.000000000 +0200 @@ -31,11 +31,12 @@ type specific_operation = Ilea of addressing_mode (* Lea gives scaled adds *) - | Istore_int of nativeint * addressing_mode (* Store an integer constant *) - | Istore_symbol of string * addressing_mode (* Store a symbol *) + | Istore_int of nativeint * addressing_mode * bool + (* Store an integer constant *) + | Istore_symbol of string * addressing_mode * bool (* Store a symbol *) | Ioffset_loc of int * addressing_mode (* Add a constant to a location *) | Ipush (* Push regs on stack *) - | Ipush_int of nativeint (* Push an integer constant *) + | Ipush_int of nativeint (* Push an integer constant *) | Ipush_symbol of string (* Push a symbol *) | Ipush_load of addressing_mode (* Load a scalar and push *) | Ipush_load_float of addressing_mode (* Load a float and push *) @@ -105,11 +106,14 @@ let print_specific_operation printreg op ppf arg = match op with | Ilea addr -> print_addressing printreg addr ppf arg - | Istore_int(n, addr) -> - fprintf ppf "[%a] := %s" (print_addressing printreg addr) arg - (Nativeint.to_string n) - | Istore_symbol(lbl, addr) -> - fprintf ppf "[%a] := \"%s\"" (print_addressing printreg addr) arg lbl + | Istore_int(n, addr, is_assign) -> + fprintf ppf "[%a] := %nd %s" + (print_addressing printreg addr) arg n + (if is_assign then "(assign)" else "(init)") + | Istore_symbol(lbl, addr, is_assign) -> + fprintf ppf "[%a] := \"%s\" %s" + (print_addressing printreg addr) arg lbl + (if is_assign then "(assign)" else "(init)") | Ioffset_loc(n, addr) -> fprintf ppf "[%a] +:= %i" (print_addressing printreg addr) arg n | Ipush -> @@ -152,5 +156,7 @@ let stack_alignment = match Config.system with - | "macosx" -> 16 - | _ -> 4 + | "win32" -> 4 (* MSVC *) + | _ -> 16 +(* PR#6038: GCC and Clang seem to require 16-byte alignment nowadays, + even if only MacOS X's ABI formally requires it *) diff -Nru ocaml-4.01.0/asmcomp/i386/CSE.ml ocaml-4.02.3/asmcomp/i386/CSE.ml --- ocaml-4.01.0/asmcomp/i386/CSE.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/i386/CSE.ml 2014-05-21 17:08:11.000000000 +0200 @@ -0,0 +1,47 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for the i386 *) + +open Cmm +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + (* Operations that affect the floating-point stack cannot be factored *) + | Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Iintoffloat | Ifloatofint + | Iload((Single | Double | Double_u), _) -> Op_other + (* Specific ops *) + | Ispecific(Ilea _) -> Op_pure + | Ispecific(Istore_int(_, _, is_asg)) -> Op_store is_asg + | Ispecific(Istore_symbol(_, _, is_asg)) -> Op_store is_asg + | Ispecific(Ioffset_loc(_, _)) -> Op_store true + | Ispecific _ -> Op_other + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int _ | Iconst_blockheader _ -> true + | Iconst_symbol _ -> true + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff -Nru ocaml-4.01.0/asmcomp/i386/emit.mlp ocaml-4.02.3/asmcomp/i386/emit.mlp --- ocaml-4.01.0/asmcomp/i386/emit.mlp 2013-03-19 08:22:12.000000000 +0100 +++ ocaml-4.02.3/asmcomp/i386/emit.mlp 2014-04-26 12:40:22.000000000 +0200 @@ -412,15 +412,16 @@ (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = + let repr = Int64.bits_of_float cst in try - List.assoc cst !float_constants + List.assoc repr !float_constants with Not_found -> let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; + float_constants := (repr, lbl) :: !float_constants; lbl let emit_float_constant (cst, lbl) = @@ -458,15 +459,15 @@ else ` movl {emit_reg src}, {emit_reg dst}\n` end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if n = 0n then begin match i.res.(0).loc with Reg n -> ` xorl {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> ` movl $0, {emit_reg i.res.(0)}\n` end else ` movl ${emit_nativeint n}, {emit_reg i.res.(0)}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` fldz\n` | 0x8000_0000_0000_0000L -> (* -0.0 *) @@ -476,7 +477,7 @@ | 0xBFF0_0000_0000_0000L -> (* -1.0 *) ` fld1\n fchs\n` | _ -> - let lbl = add_float_constant s in + let lbl = add_float_constant f in ` fldl {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> @@ -543,7 +544,7 @@ | Double | Double_u -> ` fldl {emit_addressing addr i.arg 0}\n` end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> begin match chunk with | Word | Thirtytwo_signed | Thirtytwo_unsigned -> ` movl {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n` @@ -615,6 +616,8 @@ | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %ecx *) ` {emit_string(instr_for_intop op)} %cl, {emit_reg i.res.(0)}\n` + | Lop(Iintop Imulh) -> + ` imull {emit_reg i.arg.(1)}\n` | Lop(Iintop op) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` @@ -624,21 +627,6 @@ ` incl {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> ` decl {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Idiv, n)) -> - let l = Misc.log2 n in - let lbl = new_label() in - output_test_zero i.arg.(0); - ` jge {emit_label lbl}\n`; - ` addl ${emit_int(n-1)}, {emit_reg i.arg.(0)}\n`; - `{emit_label lbl}: sarl ${emit_int l}, {emit_reg i.arg.(0)}\n` - | Lop(Iintop_imm(Imod, n)) -> - let lbl = new_label() in - ` movl {emit_reg i.arg.(0)}, %eax\n`; - ` testl %eax, %eax\n`; - ` jge {emit_label lbl}\n`; - ` addl ${emit_int(n-1)}, %eax\n`; - `{emit_label lbl}: andl ${emit_int(-n)}, %eax\n`; - ` subl %eax, {emit_reg i.arg.(0)}\n` | Lop(Iintop_imm(op, n)) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} ${emit_int n}, {emit_reg i.res.(0)}\n` @@ -696,9 +684,9 @@ stack_offset := !stack_offset + 8 | Lop(Ispecific(Ilea addr)) -> ` lea {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> + | Lop(Ispecific(Istore_int(n, addr, _))) -> ` movl ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> ` movl ${emit_symbol s}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> ` addl ${emit_int n}, {emit_addressing addr i.arg 0}\n` @@ -830,11 +818,16 @@ ` addl ${emit_int (trap_frame_size - 4)}, %esp\n`; cfi_adjust_cfa_offset (-trap_frame_size); stack_offset := !stack_offset - trap_frame_size - | Lraise -> - if !Clflags.debug then begin + | Lraise k -> + begin match !Clflags.debug, k with + | true, Lambda.Raise_regular -> ` call {emit_symbol "caml_raise_exn"}\n`; record_frame Reg.Set.empty i.dbg - end else begin + | true, Lambda.Raise_reraise -> + ` call {emit_symbol "caml_reraise_exn"}\n`; + record_frame Reg.Set.empty i.dbg + | false, _ + | true, Lambda.Raise_notrace -> ` movl {emit_symbol "caml_exception_pointer"}, %esp\n`; ` popl {emit_symbol "caml_exception_pointer"}\n`; if trap_frame_size > 8 then @@ -968,9 +961,9 @@ | Cint n -> ` .long {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".long" f + emit_float32_directive ".long" (Int32.bits_of_float f) | Cdouble f -> - emit_float64_split_directive ".long" f + emit_float64_split_directive ".long" (Int64.bits_of_float f) | Csymbol_address s -> ` .long {emit_symbol s}\n` | Clabel_address lbl -> diff -Nru ocaml-4.01.0/asmcomp/i386/emit_nt.mlp ocaml-4.02.3/asmcomp/i386/emit_nt.mlp --- ocaml-4.01.0/asmcomp/i386/emit_nt.mlp 2013-03-19 08:22:12.000000000 +0100 +++ ocaml-4.02.3/asmcomp/i386/emit_nt.mlp 2014-04-29 11:58:51.000000000 +0200 @@ -62,7 +62,10 @@ let emit_symbol s = emit_string "_"; Emitaux.emit_symbol '$' s +(* Output a 32 or 64 bit integer in hex *) + let emit_int32 n = emit_printf "0%lxh" n +let emit_int64 n = emit_printf "0%Lxh" n (* Output a label *) @@ -361,36 +364,20 @@ (* Floating-point constants *) -let float_constants = ref ([] : (string * int) list) +let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = + let repr = Int64.bits_of_float cst in try - List.assoc cst !float_constants + List.assoc repr !float_constants with Not_found -> let lbl = new_label() in - float_constants := (cst, lbl) :: !float_constants; + float_constants := (repr, lbl) :: !float_constants; lbl -let emit_float s = - (* MASM doesn't like floating-point constants such as 2e9. - Turn them into 2.0e9. *) - let pos_e = ref (-1) and pos_dot = ref (-1) in - for i = 0 to String.length s - 1 do - match s.[i] with - 'e'|'E' -> pos_e := i - | '.' -> pos_dot := i - | _ -> () - done; - if !pos_dot < 0 && !pos_e >= 0 then begin - emit_string (String.sub s 0 !pos_e); - emit_string ".0"; - emit_string (String.sub s !pos_e (String.length s - !pos_e)) - end else - emit_string s - let emit_float_constant (cst, lbl) = - `{emit_label lbl} REAL8 {emit_float cst}\n` + `{emit_label lbl} QWORD {emit_int64 cst}\n` (* Output the assembly code for an instruction *) @@ -419,15 +406,15 @@ else ` mov {emit_reg dst}, {emit_reg src}\n` end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if n = 0n then begin match i.res.(0).loc with Reg n -> ` xor {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | _ -> ` mov {emit_reg i.res.(0)}, 0\n` end else ` mov {emit_reg i.res.(0)}, {emit_nativeint n}\n` - | Lop(Iconst_float s) -> - begin match Int64.bits_of_float (float_of_string s) with + | Lop(Iconst_float f) -> + begin match Int64.bits_of_float f with | 0x0000_0000_0000_0000L -> (* +0.0 *) ` fldz\n` | 0x8000_0000_0000_0000L -> (* -0.0 *) @@ -437,7 +424,7 @@ | 0xBFF0_0000_0000_0000L -> (* -1.0 *) ` fld1\n fchs\n` | _ -> - let lbl = add_float_constant s in + let lbl = add_float_constant f in ` fld {emit_label lbl}\n` end | Lop(Iconst_symbol s) -> @@ -493,7 +480,7 @@ | Double | Double_u -> ` fld REAL8 PTR {emit_addressing addr i.arg 0}\n` end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> begin match chunk with | Word | Thirtytwo_signed | Thirtytwo_unsigned -> ` mov DWORD PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` @@ -565,6 +552,8 @@ | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %ecx *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, cl\n` + | Lop(Iintop Imulh) -> + ` imul {emit_reg i.arg.(1)}\n` | Lop(Iintop op) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n` @@ -574,21 +563,6 @@ ` inc {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> ` dec {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Idiv, n)) -> - let l = Misc.log2 n in - let lbl = new_label() in - output_test_zero i.arg.(0); - ` jge {emit_label lbl}\n`; - ` add {emit_reg i.arg.(0)}, {emit_int(n-1)}\n`; - `{emit_label lbl}: sar {emit_reg i.arg.(0)}, {emit_int l}\n` - | Lop(Iintop_imm(Imod, n)) -> - let lbl = new_label() in - ` mov eax, {emit_reg i.arg.(0)}\n`; - ` test eax, eax\n`; - ` jge {emit_label lbl}\n`; - ` add eax, {emit_int(n-1)}\n`; - `{emit_label lbl}: and eax, {emit_int(-n)}\n`; - ` sub {emit_reg i.arg.(0)}, eax\n` | Lop(Iintop_imm(op, n)) -> (* We have i.arg.(0) = i.res.(0) *) ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_int n}\n` @@ -644,9 +618,9 @@ stack_offset := !stack_offset + 8 | Lop(Ispecific(Ilea addr)) -> ` lea {emit_reg i.res.(0)}, DWORD PTR {emit_addressing addr i.arg 0}\n` - | Lop(Ispecific(Istore_int(n, addr))) -> + | Lop(Ispecific(Istore_int(n, addr, _))) -> ` mov DWORD PTR {emit_addressing addr i.arg 0},{emit_nativeint n}\n` - | Lop(Ispecific(Istore_symbol(s, addr))) -> + | Lop(Ispecific(Istore_symbol(s, addr, _))) -> add_used_symbol s ; ` mov DWORD PTR {emit_addressing addr i.arg 0},OFFSET {emit_symbol s}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> @@ -769,11 +743,16 @@ ` pop _caml_exception_pointer\n`; ` add esp, 4\n`; stack_offset := !stack_offset - 8 - | Lraise -> - if !Clflags.debug then begin + | Lraise k -> + begin match !Clflags.debug, k with + | true, Lambda.Raise_regular -> ` call _caml_raise_exn\n`; record_frame Reg.Set.empty i.dbg - end else begin + | true, Lambda.Raise_reraise -> + ` call _caml_reraise_exn\n`; + record_frame Reg.Set.empty i.dbg + | false, _ + | true, Lambda.Raise_notrace -> ` mov esp, _caml_exception_pointer\n`; ` pop _caml_exception_pointer\n`; ` ret\n` @@ -824,9 +803,9 @@ | Cint32 n -> ` DWORD {emit_nativeint n}\n` | Csingle f -> - ` REAL4 {emit_float f}\n` + ` DWORD {emit_int32 (Int32.bits_of_float f)}\n` | Cdouble f -> - ` REAL8 {emit_float f}\n` + ` QWORD {emit_int64 (Int64.bits_of_float f)}\n` | Csymbol_address s -> add_used_symbol s ; ` DWORD {emit_symbol s}\n` @@ -861,6 +840,7 @@ ` EXTERN _caml_alloc3: PROC\n`; ` EXTERN _caml_ml_array_bound_error: PROC\n`; ` EXTERN _caml_raise_exn: PROC\n`; + ` EXTERN _caml_reraise_exn: PROC\n`; ` .DATA\n`; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in add_def_symbol lbl_begin; diff -Nru ocaml-4.01.0/asmcomp/i386/proc.ml ocaml-4.02.3/asmcomp/i386/proc.ml --- ocaml-4.01.0/asmcomp/i386/proc.ml 2013-07-23 16:48:47.000000000 +0200 +++ ocaml-4.02.3/asmcomp/i386/proc.ml 2014-08-18 20:26:49.000000000 +0200 @@ -72,7 +72,7 @@ (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 7 Reg.dummy in + let v = Array.make 7 Reg.dummy in for i = 0 to 6 do v.(i) <- Reg.at_location Int (Reg i) done; v @@ -111,7 +111,7 @@ 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 loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref (-64) in @@ -154,6 +154,21 @@ let loc_exn_bucket = eax +(* Volatile registers: the x87 top of FP stack is *) + +let reg_is_volatile = function + | { typ = Float; loc = Reg _ } -> true + | _ -> false + +let regs_are_volatile rs = + try + for i = 0 to Array.length rs - 1 do + if reg_is_volatile rs.(i) then raise Exit + done; + false + with Exit -> + true + (* Registers destroyed by operations *) let destroyed_at_c_call = (* ebx, esi, edi, ebp preserved *) @@ -163,8 +178,7 @@ Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs | Iop(Iextcall(_, false)) -> destroyed_at_c_call | Iop(Iintop(Idiv | Imod)) -> [| eax; edx |] - | Iop(Iintop_imm(Imod, _)) -> [| eax |] - | Iop(Ialloc _) -> [| eax |] + | Iop(Ialloc _ | Iintop Imulh) -> [| eax |] | Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |] | Iop(Iintoffloat) -> [| eax |] | Iifthenelse(Ifloattest(_, _), _, _) -> [| eax |] @@ -183,6 +197,17 @@ Iintoffloat -> [| 6; max_int |] | _ -> [|7; max_int |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Ispecific(Ilea _) -> true + | Ispecific _ -> false + | _ -> true + (* Layout of the stack frame *) let num_stack_slots = [| 0; 0 |] diff -Nru ocaml-4.01.0/asmcomp/i386/reload.ml ocaml-4.02.3/asmcomp/i386/reload.ml --- ocaml-4.01.0/asmcomp/i386/reload.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/i386/reload.ml 2013-11-19 08:01:54.000000000 +0100 @@ -57,9 +57,11 @@ if stackp arg.(0) then let r = self#makereg arg.(0) in ([|r|], [|r|]) else (arg, res) - | Iintop(Ilsl|Ilsr|Iasr) | Iintop_imm(_, _) | Ifloatofint | Iintoffloat | - Ispecific(Ipush) -> + | Iintop(Imulh | Ilsl | Ilsr | Iasr) | Iintop_imm(_, _) + | Ifloatofint | Iintoffloat | Ispecific(Ipush) -> (* The argument(s) can be either in register or on stack *) + (* Note: Imulh: arg(0 and res(0) already forced in regs + Ilsl, Ilsr, Iasr: arg(1) already forced in regs *) (arg, res) | _ -> (* Other operations: all args and results in registers *) super#reload_operation op arg res diff -Nru ocaml-4.01.0/asmcomp/i386/selection.ml ocaml-4.02.3/asmcomp/i386/selection.ml --- ocaml-4.01.0/asmcomp/i386/selection.ml 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/asmcomp/i386/selection.ml 2014-04-26 12:40:22.000000000 +0200 @@ -110,8 +110,12 @@ Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) -> ([|res.(0); arg.(1)|], res, false) (* Two-address unary operations *) - | Iintop_imm((Iadd|Isub|Imul|Idiv|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) -> + | Iintop_imm((Iadd|Isub|Imul|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) -> (res, res, false) + (* For imull, first arg must be in eax, eax is clobbered, and result is in + edx. *) + | Iintop(Imulh) -> + ([| eax; arg.(1) |], [| edx |], true) (* For shifts with variable shift count, second arg must be in ecx *) | Iintop(Ilsl|Ilsr|Iasr) -> ([|res.(0); ecx|], res, false) @@ -122,10 +126,6 @@ ([| eax; ecx |], [| eax |], true) | Iintop(Imod) -> ([| eax; ecx |], [| edx |], true) - (* For mod with immediate operand, arg must not be in eax. - Keep it simple, force it in edx. *) - | Iintop_imm(Imod, _) -> - ([| edx |], [| edx |], true) (* For floating-point operations and floating-point loads, the result is always left at the top of the floating-point stack *) | Iconst_float _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf @@ -135,7 +135,7 @@ (* For storing a byte, the argument must be in eax...edx. (But for a short, any reg will do!) Keep it simple, just force the argument to be in edx. *) - | Istore((Byte_unsigned | Byte_signed), addr) -> + | Istore((Byte_unsigned | Byte_signed), addr, _) -> let newarg = Array.copy arg in newarg.(0) <- edx; (newarg, res, false) @@ -178,20 +178,20 @@ | (Ascaledadd(e1, e2, scale), d) -> (Iindexed2scaled(scale, d), Ctuple[e1; e2]) -method! select_store addr exp = +method! select_store is_assign addr exp = match exp with Cconst_int n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) - | Cconst_natint n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) + | (Cconst_natint n | Cconst_blockheader n) -> + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_pointer n -> - (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) + (Ispecific(Istore_int(Nativeint.of_int n, addr, is_assign)), Ctuple []) | Cconst_natpointer n -> - (Ispecific(Istore_int(n, addr)), Ctuple []) + (Ispecific(Istore_int(n, addr, is_assign)), Ctuple []) | Cconst_symbol s -> - (Ispecific(Istore_symbol(s, addr)), Ctuple []) + (Ispecific(Istore_symbol(s, addr, is_assign)), Ctuple []) | _ -> - super#select_store addr exp + super#select_store is_assign addr exp method! select_operation op args = match op with @@ -202,19 +202,6 @@ | (Iindexed2 0, _) -> super#select_operation op args | (addr, arg) -> (Ispecific(Ilea addr), [arg]) end - (* Recognize (x / cst) and (x % cst) only if cst is a power of 2. *) - | Cdivi -> - begin match args with - [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg1]) - | _ -> (Iintop Idiv, args) - end - | Cmodi -> - begin match args with - [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Imod, n), [arg1]) - | _ -> (Iintop Imod, args) - end (* Recognize float arithmetic with memory. In passing, apply Ershov's algorithm to reduce stack usage *) | Caddf -> @@ -241,6 +228,9 @@ | Cextcall(fn, ty_res, false, dbg) when !fast_math && List.mem fn inline_float_ops -> (Ispecific(Ifloatspecial fn), args) + (* i386 does not support immediate operands for multiply high signed *) + | Cmulhi -> + (Iintop Imulh, args) (* Default *) | _ -> super#select_operation op args @@ -298,6 +288,9 @@ (Ispecific(Ipush_load_float addr), arg) | _ -> (Ispecific(Ipush), exp) +method! mark_c_tailcall = + Proc.contains_calls := true + method! emit_extcall_args env args = let rec size_pushes = function | [] -> 0 diff -Nru ocaml-4.01.0/asmcomp/.ignore ocaml-4.02.3/asmcomp/.ignore --- ocaml-4.01.0/asmcomp/.ignore 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/asmcomp/.ignore 2014-04-27 11:31:59.000000000 +0200 @@ -4,3 +4,4 @@ selection.ml reload.ml scheduling.ml +CSE.ml diff -Nru ocaml-4.01.0/asmcomp/interf.ml ocaml-4.02.3/asmcomp/interf.ml --- ocaml-4.01.0/asmcomp/interf.ml 2013-03-19 08:22:12.000000000 +0100 +++ ocaml-4.02.3/asmcomp/interf.ml 2013-11-13 14:55:13.000000000 +0100 @@ -111,17 +111,21 @@ | Itrywith(body, handler) -> add_interf_set Proc.destroyed_at_raise handler.live; interf body; interf handler; interf i.next - | Iraise -> () in + | Iraise _ -> () in (* Add a preference from one reg to another. Do not add anything if the two registers conflict, - or if the source register already has a location. *) + or if the source register already has a location, + or if the two registers belong to different classes. + (The last case can occur e.g. on Sparc when passing + float arguments in integer registers, PR#6227.) *) let add_pref weight r1 r2 = if weight > 0 then begin let i = r1.stamp and j = r2.stamp in if i <> j && r1.loc = Unknown + && Proc.register_class r1 = Proc.register_class r2 && (let p = if i < j then (i, j) else (j, i) in not (IntPairSet.mem p !mat)) then r1.prefer <- (r2, weight) :: r1.prefer @@ -178,7 +182,7 @@ () | Itrywith(body, handler) -> prefer weight body; prefer weight handler; prefer weight i.next - | Iraise -> () + | Iraise _ -> () in interf fundecl.fun_body; prefer 8 fundecl.fun_body diff -Nru ocaml-4.01.0/asmcomp/linearize.ml ocaml-4.02.3/asmcomp/linearize.ml --- ocaml-4.01.0/asmcomp/linearize.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/linearize.ml 2014-08-18 20:26:49.000000000 +0200 @@ -42,10 +42,10 @@ | Lsetuptrap of label | Lpushtrap | Lpoptrap - | Lraise + | Lraise of Lambda.raise_kind let has_fallthrough = function - | Lreturn | Lbranch _ | Lswitch _ | Lraise + | Lreturn | Lbranch _ | Lswitch _ | Lraise _ | Lop Itailcall_ind | Lop (Itailcall_imm _) -> false | _ -> true @@ -126,9 +126,9 @@ match n.desc with Lend -> n | Llabel _ -> n -(* Do not discard Lpoptrap or Istackoffset instructions, +(* Do not discard Lpoptrap/Lpushtrap or Istackoffset instructions, as this may cause a stack imbalance later during assembler generation. *) - | Lpoptrap -> n + | Lpoptrap | Lpushtrap -> n | Lop(Istackoffset _) -> n | _ -> discard_dead_code n.next @@ -148,20 +148,30 @@ else discard_dead_code n -(* Current labels for exit handler *) +let try_depth = ref 0 + +(* Association list: exit handler -> (handler label, try-nesting factor) *) let exit_label = ref [] -let find_exit_label k = +let find_exit_label_try_depth k = try List.assoc k !exit_label with | Not_found -> Misc.fatal_error "Linearize.find_exit_label" +let find_exit_label k = + let (label, t) = find_exit_label_try_depth k in + assert(t = !try_depth); + label + let is_next_catch n = match !exit_label with -| (n0,_)::_ when n0=n -> true +| (n0,(_,t))::_ when n0=n && t = !try_depth -> true | _ -> false +let local_exit k = + snd (find_exit_label_try_depth k) = !try_depth + (* Linearize an instruction [i]: add it in front of the continuation [n] *) let rec linear i n = @@ -187,15 +197,15 @@ | _, Iend, Lbranch lbl -> copy_instr (Lcondbranch(invert_test test, lbl)) i (linear ifso n1) | Iexit nfail1, Iexit nfail2, _ - when is_next_catch nfail1 -> + when is_next_catch nfail1 && local_exit nfail2 -> let lbl2 = find_exit_label nfail2 in copy_instr (Lcondbranch (invert_test test, lbl2)) i (linear ifso n1) - | Iexit nfail, _, _ -> + | Iexit nfail, _, _ when local_exit nfail -> let n2 = linear ifnot n1 and lbl = find_exit_label nfail in copy_instr (Lcondbranch(test, lbl)) i n2 - | _, Iexit nfail, _ -> + | _, Iexit nfail, _ when local_exit nfail -> let n2 = linear ifso n1 in let lbl = find_exit_label nfail in copy_instr (Lcondbranch(invert_test test, lbl)) i n2 @@ -214,7 +224,7 @@ (linear ifso (add_branch lbl_end nelse)) end | Iswitch(index, cases) -> - let lbl_cases = Array.create (Array.length cases) 0 in + let lbl_cases = Array.make (Array.length cases) 0 in let (lbl_end, n1) = get_label(linear i.Mach.next n) in let n2 = ref (discard_dead_code n1) in for i = Array.length cases - 1 downto 0 do @@ -242,23 +252,43 @@ | Icatch(io, body, handler) -> let (lbl_end, n1) = get_label(linear i.Mach.next n) in let (lbl_handler, n2) = get_label(linear handler n1) in - exit_label := (io, lbl_handler) :: !exit_label ; + exit_label := (io, (lbl_handler, !try_depth)) :: !exit_label ; let n3 = linear body (add_branch lbl_end n2) in exit_label := List.tl !exit_label; n3 | Iexit nfail -> - let n1 = linear i.Mach.next n in - let lbl = find_exit_label nfail in - add_branch lbl n1 + let lbl, t = find_exit_label_try_depth nfail in + (* We need to re-insert dummy pushtrap (which won't be executed), + so as to preserve stack offset during assembler generation. + It would make sense to have a special pseudo-instruction + only to inform the later pass about this stack offset + (corresponding to N traps). + *) + let rec loop i tt = + if t = tt then i + else loop (cons_instr Lpushtrap i) (tt - 1) + in + let n1 = loop (linear i.Mach.next n) !try_depth in + let rec loop i tt = + if t = tt then i + else loop (cons_instr Lpoptrap i) (tt - 1) + in + loop (add_branch lbl n1) !try_depth | Itrywith(body, handler) -> let (lbl_join, n1) = get_label (linear i.Mach.next n) in + incr try_depth; let (lbl_body, n2) = get_label (cons_instr Lpushtrap (linear body (cons_instr Lpoptrap n1))) in + decr try_depth; cons_instr (Lsetuptrap lbl_body) (linear handler (add_branch lbl_join n2)) - | Iraise -> - copy_instr Lraise i (discard_dead_code n) + | Iraise k -> + copy_instr (Lraise k) i (discard_dead_code n) + +let reset () = + label_counter := 99; + exit_label := [] let fundecl f = { fun_name = f.Mach.fun_name; diff -Nru ocaml-4.01.0/asmcomp/linearize.mli ocaml-4.02.3/asmcomp/linearize.mli --- ocaml-4.01.0/asmcomp/linearize.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/linearize.mli 2014-05-09 14:01:21.000000000 +0200 @@ -36,7 +36,7 @@ | Lsetuptrap of label | Lpushtrap | Lpoptrap - | Lraise + | Lraise of Lambda.raise_kind val has_fallthrough : instruction_desc -> bool val end_instr: instruction @@ -50,4 +50,5 @@ fun_fast: bool; fun_dbg : Debuginfo.t } +val reset : unit -> unit val fundecl: Mach.fundecl -> fundecl diff -Nru ocaml-4.01.0/asmcomp/liveness.ml ocaml-4.02.3/asmcomp/liveness.ml --- ocaml-4.01.0/asmcomp/liveness.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/liveness.ml 2014-05-16 16:52:07.000000000 +0200 @@ -16,13 +16,13 @@ open Mach let live_at_exit = ref [] + let find_live_at_exit k = try List.assoc k !live_at_exit with - | Not_found -> Misc.fatal_error "Spill.find_live_at_exit" + | Not_found -> Misc.fatal_error "Liveness.find_live_at_exit" -let live_at_break = ref Reg.Set.empty let live_at_raise = ref Reg.Set.empty let rec live i finally = @@ -37,8 +37,34 @@ i.live <- finally; finally | Ireturn | Iop(Itailcall_ind) | Iop(Itailcall_imm _) -> - (* i.live remains empty since no regs are live across *) + i.live <- Reg.Set.empty; (* no regs are live across *) Reg.set_of_array i.arg + | Iop op -> + let after = live i.next finally in + if Proc.op_is_pure op (* no side effects *) + && Reg.disjoint_set_array after i.res (* results are not used after *) + && not (Proc.regs_are_volatile i.arg) (* no stack-like hard reg *) + && not (Proc.regs_are_volatile i.res) (* is involved *) + then begin + (* This operation is dead code. Ignore its arguments. *) + i.live <- after; + after + end else begin + let across_after = Reg.diff_set_array after i.res in + let across = + match op with + | Icall_ind | Icall_imm _ | Iextcall _ + | Iintop Icheckbound | Iintop_imm(Icheckbound, _) -> + (* The function call may raise an exception, branching to the + nearest enclosing try ... with. Similarly for bounds checks. + Hence, everything that must be live at the beginning of + the exception handler must also be live across this instr. *) + Reg.Set.union across_after !live_at_raise + | _ -> + across_after in + i.live <- across; + Reg.add_set_array across i.arg + end | Iifthenelse(test, ifso, ifnot) -> let at_join = live i.next finally in let at_fork = Reg.Set.union (live ifso at_join) (live ifnot at_join) in @@ -89,24 +115,13 @@ live_at_raise := saved_live_at_raise; i.live <- before_body; before_body - | Iraise -> - (* i.live remains empty since no regs are live across *) + | Iraise _ -> + i.live <- !live_at_raise; Reg.add_set_array !live_at_raise i.arg - | _ -> - let across_after = Reg.diff_set_array (live i.next finally) i.res in - let across = - match i.desc with - Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _) - | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) -> - (* The function call may raise an exception, branching to the - nearest enclosing try ... with. Similarly for bounds checks. - Hence, everything that must be live at the beginning of - the exception handler must also be live across this instr. *) - Reg.Set.union across_after !live_at_raise - | _ -> - across_after in - i.live <- across; - Reg.add_set_array across i.arg + +let reset () = + live_at_raise := Reg.Set.empty; + live_at_exit := [] let fundecl ppf f = let initially_live = live f.fun_body Reg.Set.empty in diff -Nru ocaml-4.01.0/asmcomp/liveness.mli ocaml-4.02.3/asmcomp/liveness.mli --- ocaml-4.01.0/asmcomp/liveness.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/liveness.mli 2014-05-09 14:01:21.000000000 +0200 @@ -15,4 +15,5 @@ open Format +val reset : unit -> unit val fundecl: formatter -> Mach.fundecl -> unit diff -Nru ocaml-4.01.0/asmcomp/mach.ml ocaml-4.02.3/asmcomp/mach.ml --- ocaml-4.01.0/asmcomp/mach.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/mach.ml 2014-04-26 12:40:22.000000000 +0200 @@ -17,7 +17,7 @@ | Iunsigned of Cmm.comparison type integer_operation = - Iadd | Isub | Imul | Idiv | Imod + Iadd | Isub | Imul | Imulh | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Icomp of integer_comparison | Icheckbound @@ -36,8 +36,9 @@ | Ispill | Ireload | Iconst_int of nativeint - | Iconst_float of string + | Iconst_float of float | Iconst_symbol of string + | Iconst_blockheader of nativeint | Icall_ind | Icall_imm of string | Itailcall_ind @@ -45,7 +46,7 @@ | Iextcall of string * bool | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode - | Istore of Cmm.memory_chunk * Arch.addressing_mode + | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool | Ialloc of int | Iintop of integer_operation | Iintop_imm of integer_operation * int @@ -71,7 +72,7 @@ | Icatch of int * instruction * instruction | Iexit of int | Itrywith of instruction * instruction - | Iraise + | Iraise of Lambda.raise_kind type fundecl = { fun_name: string; @@ -125,6 +126,6 @@ | Iexit _ -> () | Itrywith(body, handler) -> instr_iter f body; instr_iter f handler; instr_iter f i.next - | Iraise -> () + | Iraise _ -> () | _ -> instr_iter f i.next diff -Nru ocaml-4.01.0/asmcomp/mach.mli ocaml-4.02.3/asmcomp/mach.mli --- ocaml-4.01.0/asmcomp/mach.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/mach.mli 2014-04-26 12:40:22.000000000 +0200 @@ -17,7 +17,7 @@ | Iunsigned of Cmm.comparison type integer_operation = - Iadd | Isub | Imul | Idiv | Imod + Iadd | Isub | Imul | Imulh | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Icomp of integer_comparison | Icheckbound @@ -36,16 +36,18 @@ | Ispill | Ireload | Iconst_int of nativeint - | Iconst_float of string + | Iconst_float of float | Iconst_symbol of string + | Iconst_blockheader of nativeint | Icall_ind | Icall_imm of string | Itailcall_ind | Itailcall_imm of string - | Iextcall of string * bool + | Iextcall of string * bool (* false = noalloc, true = alloc *) | Istackoffset of int | Iload of Cmm.memory_chunk * Arch.addressing_mode - | Istore of Cmm.memory_chunk * Arch.addressing_mode + | Istore of Cmm.memory_chunk * Arch.addressing_mode * bool + (* false = initialization, true = assignment *) | Ialloc of int | Iintop of integer_operation | Iintop_imm of integer_operation * int @@ -71,7 +73,7 @@ | Icatch of int * instruction * instruction | Iexit of int | Itrywith of instruction * instruction - | Iraise + | Iraise of Lambda.raise_kind type fundecl = { fun_name: string; diff -Nru ocaml-4.01.0/asmcomp/power/CSE.ml ocaml-4.02.3/asmcomp/power/CSE.ml --- ocaml-4.01.0/asmcomp/power/CSE.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/power/CSE.ml 2014-05-21 17:08:11.000000000 +0200 @@ -0,0 +1,37 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for the PowerPC *) + +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Imultaddf | Imultsubf) -> Op_pure + | Ispecific(Ialloc_far _) -> Op_other + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int n | Iconst_blockheader n -> n <= 32767n && n >= -32768n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff -Nru ocaml-4.01.0/asmcomp/power/emit.mlp ocaml-4.02.3/asmcomp/power/emit.mlp --- ocaml-4.01.0/asmcomp/power/emit.mlp 2013-06-24 10:16:27.000000000 +0200 +++ ocaml-4.02.3/asmcomp/power/emit.mlp 2015-06-10 11:27:36.000000000 +0200 @@ -45,13 +45,6 @@ | Incoming n -> frame_size() + n | Outgoing n -> n -(* Whether stack backtraces are supported *) - -let supports_backtraces = - match Config.system with - | "rhapsody" -> true - | _ -> false - (* Output a symbol *) let emit_symbol = @@ -236,7 +229,7 @@ (* Record floating-point and large integer literals *) -let float_literals = ref ([] : (string * int) list) +let float_literals = ref ([] : (int64 * int) list) let int_literals = ref ([] : (nativeint * int) list) (* Record external C functions to be called in a position-independent way @@ -266,15 +259,16 @@ (* Names for various instructions *) let name_for_intop = function - Iadd -> "add" - | Imul -> if ppc64 then "mulld" else "mullw" - | Idiv -> if ppc64 then "divd" else "divw" - | Iand -> "and" - | Ior -> "or" - | Ixor -> "xor" - | Ilsl -> if ppc64 then "sld" else "slw" - | Ilsr -> if ppc64 then "srd" else "srw" - | Iasr -> if ppc64 then "srad" else "sraw" + Iadd -> "add" + | Imul -> if ppc64 then "mulld" else "mullw" + | Imulh -> if ppc64 then "mulhd" else "mulhw" + | Idiv -> if ppc64 then "divd" else "divw" + | Iand -> "and" + | Ior -> "or" + | Ixor -> "xor" + | Ilsl -> if ppc64 then "sld" else "slw" + | Ilsr -> if ppc64 then "srd" else "srw" + | Iasr -> if ppc64 then "srad" else "sraw" | _ -> Misc.fatal_error "Emit.Intop" let name_for_intop_imm = function @@ -314,127 +308,87 @@ (* Label of glue code for calling the GC *) let call_gc_label = ref 0 -(* Fixup conditional branches that exceed hardware allowed range *) +module BR = Branch_relaxation.Make (struct + type distance = int + + module Cond_branch = struct + type t = Branch + + let all = [Branch] + + let max_displacement = function + (* 14-bit signed offset in words. *) + | Branch -> 8192 + + let classify_instr = function + | Lop (Ialloc _) + (* [Ialloc_far] does not need to be here, since its code sequence + never involves any conditional branches that might need relaxing. *) + | Lcondbranch _ + | Lcondbranch3 _ -> Some Branch + | _ -> None + end -let load_store_size = function - Ibased(s, d) -> 2 - | Iindexed ofs -> if is_immediate ofs then 1 else 3 - | Iindexed2 -> 1 - -let instr_size = function - Lend -> 0 - | Lop(Imove | Ispill | Ireload) -> 1 - | Lop(Iconst_int n) -> if is_native_immediate n then 1 else 2 - | Lop(Iconst_float s) -> 2 - | Lop(Iconst_symbol s) -> 2 - | Lop(Icall_ind) -> 2 - | Lop(Icall_imm s) -> 1 - | Lop(Itailcall_ind) -> 5 - | Lop(Itailcall_imm s) -> if s = !function_name then 1 else 4 - | Lop(Iextcall(s, true)) -> 3 - | Lop(Iextcall(s, false)) -> if pic_externals then 4 else 1 - | Lop(Istackoffset n) -> 1 - | Lop(Iload(chunk, addr)) -> + let offset_pc_at_branch = 1 + + let load_store_size = function + | Ibased(s, d) -> 2 + | Iindexed ofs -> if is_immediate ofs then 1 else 3 + | Iindexed2 -> 1 + + let instr_size = function + | Lend -> 0 + | Lop(Imove | Ispill | Ireload) -> 1 + | Lop(Iconst_int n | Iconst_blockheader n) -> + if is_native_immediate n then 1 else 2 + | Lop(Iconst_float s) -> 2 + | Lop(Iconst_symbol s) -> 2 + | Lop(Icall_ind) -> 2 + | Lop(Icall_imm s) -> 1 + | Lop(Itailcall_ind) -> 5 + | Lop(Itailcall_imm s) -> if s = !function_name then 1 else 4 + | Lop(Iextcall(s, true)) -> 3 + | Lop(Iextcall(s, false)) -> if pic_externals then 4 else 1 + | Lop(Istackoffset n) -> 1 + | Lop(Iload(chunk, addr)) -> if chunk = Byte_signed then load_store_size addr + 1 else load_store_size addr - | Lop(Istore(chunk, addr)) -> load_store_size addr - | Lop(Ialloc n) -> 4 - | Lop(Ispecific(Ialloc_far n)) -> 5 - | Lop(Iintop Imod) -> 3 - | Lop(Iintop(Icomp cmp)) -> 4 - | Lop(Iintop op) -> 1 - | Lop(Iintop_imm(Idiv, n)) -> 2 - | Lop(Iintop_imm(Imod, n)) -> 4 - | Lop(Iintop_imm(Icomp cmp, n)) -> 4 - | Lop(Iintop_imm(op, n)) -> 1 - | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1 - | Lop(Ifloatofint) -> 9 - | Lop(Iintoffloat) -> 4 - | Lop(Ispecific sop) -> 1 - | Lreloadretaddr -> 2 - | Lreturn -> 2 - | Llabel lbl -> 0 - | Lbranch lbl -> 1 - | Lcondbranch(tst, lbl) -> 2 - | Lcondbranch3(lbl0, lbl1, lbl2) -> + | Lop(Istore(chunk, addr, _)) -> load_store_size addr + | Lop(Ialloc n) -> 4 + | Lop(Ispecific(Ialloc_far n)) -> 5 + | Lop(Iintop Imod) -> 3 + | Lop(Iintop(Icomp cmp)) -> 4 + | Lop(Iintop op) -> 1 + | Lop(Iintop_imm(Icomp cmp, n)) -> 4 + | Lop(Iintop_imm(op, n)) -> 1 + | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf) -> 1 + | Lop(Ifloatofint) -> 9 + | Lop(Iintoffloat) -> 4 + | Lop(Ispecific sop) -> 1 + | Lreloadretaddr -> 2 + | Lreturn -> 2 + | Llabel lbl -> 0 + | Lbranch lbl -> 1 + | Lcondbranch(tst, lbl) -> 2 + | Lcondbranch3(lbl0, lbl1, lbl2) -> 1 + (if lbl0 = None then 0 else 1) + (if lbl1 = None then 0 else 1) + (if lbl2 = None then 0 else 1) - | Lswitch jumptbl -> 8 - | Lsetuptrap lbl -> 1 - | Lpushtrap -> 4 - | Lpoptrap -> 2 - | Lraise -> 6 - -let label_map code = - let map = Hashtbl.create 37 in - let rec fill_map pc instr = - match instr.desc with - Lend -> (pc, map) - | Llabel lbl -> Hashtbl.add map lbl pc; fill_map pc instr.next - | op -> fill_map (pc + instr_size op) instr.next - in fill_map 0 code - -let max_branch_offset = 8180 -(* 14-bit signed offset in words. Remember to cut some slack - for multi-word instructions where the branch can be anywhere in - the middle. 12 words of slack is plenty. *) - -let branch_overflows map pc_branch lbl_dest = - let pc_dest = Hashtbl.find map lbl_dest in - let delta = pc_dest - (pc_branch + 1) in - delta <= -max_branch_offset || delta >= max_branch_offset - -let opt_branch_overflows map pc_branch opt_lbl_dest = - match opt_lbl_dest with - None -> false - | Some lbl_dest -> branch_overflows map pc_branch lbl_dest - -let fixup_branches codesize map code = - let expand_optbranch lbl n arg next = - match lbl with - None -> next - | Some l -> - instr_cons (Lcondbranch(Iinttest_imm(Isigned Ceq, n), l)) - arg [||] next in - let rec fixup did_fix pc instr = - match instr.desc with - Lend -> did_fix - | Lcondbranch(test, lbl) when branch_overflows map pc lbl -> - let lbl2 = new_label() in - let cont = - instr_cons (Lbranch lbl) [||] [||] - (instr_cons (Llabel lbl2) [||] [||] instr.next) in - instr.desc <- Lcondbranch(invert_test test, lbl2); - instr.next <- cont; - fixup true (pc + 2) instr.next - | Lcondbranch3(lbl0, lbl1, lbl2) - when opt_branch_overflows map pc lbl0 - || opt_branch_overflows map pc lbl1 - || opt_branch_overflows map pc lbl2 -> - let cont = - expand_optbranch lbl0 0 instr.arg - (expand_optbranch lbl1 1 instr.arg - (expand_optbranch lbl2 2 instr.arg instr.next)) in - instr.desc <- cont.desc; - instr.next <- cont.next; - fixup true pc instr - | Lop(Ialloc n) when codesize - pc >= max_branch_offset -> - instr.desc <- Lop(Ispecific(Ialloc_far n)); - fixup true (pc + 4) instr.next - | op -> - fixup did_fix (pc + instr_size op) instr.next - in fixup false 0 code - -(* Iterate branch expansion till all conditional branches are OK *) - -let rec branch_normalization code = - let (codesize, map) = label_map code in - if codesize >= max_branch_offset && fixup_branches codesize map code - then branch_normalization code - else () - + | Lswitch jumptbl -> 8 + | Lsetuptrap lbl -> 1 + | Lpushtrap -> 4 + | Lpoptrap -> 2 + | Lraise _ -> 6 + + let relax_allocation ~num_words = Lop (Ispecific (Ialloc_far num_words)) + + (* [classify_addr], above, never identifies these instructions as needing + relaxing. As such, these functions should never be called. *) + let relax_specific_op _ = assert false + let relax_intop_checkbound () = assert false + let relax_intop_imm_checkbound ~bound:_ = assert false +end) (* Output the assembly code for an instruction *) @@ -460,7 +414,7 @@ | (_, _) -> fatal_error "Emit: Imove" end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if is_native_immediate n then ` li {emit_reg i.res.(0)}, {emit_nativeint n}\n` else if n >= -0x8000_0000n && n <= 0x7FFF_FFFFn then begin @@ -473,9 +427,9 @@ ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; ` {emit_string lg} {emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n` end - | Lop(Iconst_float s) -> + | Lop(Iconst_float f) -> let lbl = new_label() in - float_literals := (s, lbl) :: !float_literals; + float_literals := (Int64.bits_of_float f, lbl) :: !float_literals; ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; ` lfd {emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n` | Lop(Iconst_symbol s) -> @@ -555,7 +509,7 @@ emit_load_store loadinstr addr i.arg 0 i.res.(0); if chunk = Byte_signed then ` extsb {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> let storeinstr = match chunk with Byte_unsigned | Byte_signed -> "stb" @@ -597,7 +551,7 @@ emit_set_comp c i.res.(0) end | Lop(Iintop Icheckbound) -> - if !Clflags.debug && supports_backtraces then + if !Clflags.debug then record_frame Reg.Set.empty i.dbg; ` {emit_string tglle} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Iintop op) -> @@ -605,16 +559,6 @@ ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Iintop_imm(Isub, n)) -> ` addi {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int(-n)}\n` - | Lop(Iintop_imm(Idiv, n)) -> (* n is guaranteed to be a power of 2 *) - let l = Misc.log2 n in - ` {emit_string sragi} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int l}\n`; - ` addze {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Imod, n)) -> (* n is guaranteed to be a power of 2 *) - let l = Misc.log2 n in - ` {emit_string sragi} {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int l}\n`; - ` addze {emit_gpr 0}, {emit_gpr 0}\n`; - ` {emit_string slgi} {emit_gpr 0}, {emit_gpr 0}, {emit_int l}\n`; - ` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n` | Lop(Iintop_imm(Icomp cmp, n)) -> begin match cmp with Isigned c -> @@ -625,7 +569,7 @@ emit_set_comp c i.res.(0) end | Lop(Iintop_imm(Icheckbound, n)) -> - if !Clflags.debug && supports_backtraces then + if !Clflags.debug then record_frame Reg.Set.empty i.dbg; ` {emit_string tglle}i {emit_reg i.arg.(0)}, {emit_int n}\n` | Lop(Iintop_imm(op, n)) -> @@ -645,8 +589,7 @@ ` fcfid {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` end else begin let lbl = new_label() in - float_literals := ("4.503601774854144e15", lbl) :: !float_literals; - (* That float above represents 0x4330000080000000 *) + float_literals := (0x4330000080000000L, lbl) :: !float_literals; ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; ` lfd {emit_fpr 0}, {emit_lower emit_label lbl}({emit_gpr 11})\n`; ` lis {emit_gpr 0}, 0x4330\n`; @@ -767,17 +710,22 @@ ` {emit_string lg} {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`; ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; stack_offset := !stack_offset - 16 - | Lraise -> - if !Clflags.debug && supports_backtraces then begin + | Lraise k -> + begin match !Clflags.debug, k with + | true, Lambda.Raise_regular -> ` bl {emit_symbol "caml_raise_exn"}\n`; record_frame Reg.Set.empty i.dbg - end else begin + | true, Lambda.Raise_reraise -> + ` bl {emit_symbol "caml_reraise_exn"}\n`; + record_frame Reg.Set.empty i.dbg + | false, _ + | true, Lambda.Raise_notrace -> ` {emit_string lg} {emit_gpr 0}, 0({emit_gpr 29})\n`; ` mr {emit_gpr 1}, {emit_gpr 29}\n`; - ` mtlr {emit_gpr 0}\n`; + ` mtctr {emit_gpr 0}\n`; ` {emit_string lg} {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`; ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; - ` blr\n` + ` bctr\n` end and emit_delay = function @@ -861,7 +809,10 @@ ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int(-n)}\n` end; `{emit_label !tailrec_entry_point}:\n`; - branch_normalization fundecl.fun_body; + (* On this target, there is at most one "out of line" code block per + function: a single "call GC" point. It comes immediately after the + function's body. *) + BR.relax fundecl.fun_body ~max_out_of_line_code_offset:0; emit_all fundecl.fun_body; (* Emit the glue code to call the GC *) if !call_gc_label > 0 then begin @@ -911,11 +862,11 @@ | Cint n -> ` {emit_string datag} {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".long" f + emit_float32_directive ".long" (Int32.bits_of_float f) | Cdouble f -> if ppc64 - then emit_float64_directive ".quad" f - else emit_float64_split_directive ".long" f + then emit_float64_directive ".quad" (Int64.bits_of_float f) + else emit_float64_split_directive ".long" (Int64.bits_of_float f) | Csymbol_address s -> ` {emit_string datag} {emit_symbol s}\n` | Clabel_address lbl -> diff -Nru ocaml-4.01.0/asmcomp/power/proc.ml ocaml-4.02.3/asmcomp/power/proc.ml --- ocaml-4.01.0/asmcomp/power/proc.ml 2013-06-24 10:16:27.000000000 +0200 +++ ocaml-4.02.3/asmcomp/power/proc.ml 2014-08-18 20:26:49.000000000 +0200 @@ -83,11 +83,11 @@ (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 23 Reg.dummy in + let v = Array.make 23 Reg.dummy in for i = 0 to 22 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 31 Reg.dummy in + let v = Array.make 31 Reg.dummy in for i = 0 to 30 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v let all_phys_regs = @@ -103,7 +103,7 @@ let calling_conventions first_int last_int first_float last_float make_stack stack_ofs arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref stack_ofs in @@ -157,7 +157,7 @@ let poweropen_external_conventions first_int last_int first_float last_float arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref (14 * size_addr) in @@ -200,6 +200,10 @@ let loc_exn_bucket = phys_reg 0 +(* Volatile registers: none *) + +let regs_are_volatile rs = false + (* Registers destroyed by operations *) let destroyed_at_c_call = @@ -224,6 +228,17 @@ Iextcall(_, _) -> [| 15; 18 |] | _ -> [| 23; 30 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Ispecific(Imultaddf | Imultsubf) -> true + | Ispecific _ -> false + | _ -> true + (* Layout of the stack *) let num_stack_slots = [| 0; 0 |] diff -Nru ocaml-4.01.0/asmcomp/power/scheduling.ml ocaml-4.02.3/asmcomp/power/scheduling.ml --- ocaml-4.01.0/asmcomp/power/scheduling.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/power/scheduling.ml 2014-04-26 12:40:22.000000000 +0200 @@ -26,7 +26,7 @@ | Iload(_, _) -> 2 | Iconst_float _ -> 2 (* turned into a load *) | Iconst_symbol _ -> 1 - | Iintop Imul -> 9 + | Iintop(Imul | Imulh) -> 9 | Iintop_imm(Imul, _) -> 5 | Iintop(Idiv | Imod) -> 36 | Iaddf | Isubf -> 4 @@ -44,12 +44,10 @@ method oper_issue_cycles = function Iconst_float _ | Iconst_symbol _ -> 2 | Iload(_, Ibased(_, _)) -> 2 - | Istore(_, Ibased(_, _)) -> 2 + | Istore(_, Ibased(_, _), _) -> 2 | Ialloc _ -> 4 | Iintop(Imod) -> 40 (* assuming full stall *) | Iintop(Icomp _) -> 4 - | Iintop_imm(Idiv, _) -> 2 - | Iintop_imm(Imod, _) -> 4 | Iintop_imm(Icomp _, _) -> 4 | Ifloatofint -> 9 | Iintoffloat -> 4 diff -Nru ocaml-4.01.0/asmcomp/power/selection.ml ocaml-4.02.3/asmcomp/power/selection.ml --- ocaml-4.01.0/asmcomp/power/selection.ml 2013-06-21 17:00:10.000000000 +0200 +++ ocaml-4.02.3/asmcomp/power/selection.ml 2013-11-19 08:01:54.000000000 +0100 @@ -61,16 +61,8 @@ method! select_operation op args = match (op, args) with - (* Prevent the recognition of (x / cst) and (x % cst) when cst is not - a power of 2, which do not correspond to an instruction. *) - (Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg]) - | (Cdivi, _) -> - (Iintop Idiv, args) - | (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Imod, n), [arg]) - | (Cmodi, _) -> - (Iintop Imod, args) + (* PowerPC does not support immediate operands for multiply high *) + (Cmulhi, _) -> (Iintop Imulh, args) (* The and, or and xor instructions have a different range of immediate operands than the other instructions *) | (Cand, _) -> self#select_logical Iand args diff -Nru ocaml-4.01.0/asmcomp/printclambda.ml ocaml-4.02.3/asmcomp/printclambda.ml --- ocaml-4.01.0/asmcomp/printclambda.ml 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/asmcomp/printclambda.ml 2014-04-25 10:41:13.000000000 +0200 @@ -15,15 +15,33 @@ open Asttypes open Clambda -let rec pr_idents ppf = function - | [] -> () - | h::t -> fprintf ppf "%a %a" Ident.print h pr_idents t +let rec structured_constant ppf = function + | Uconst_float x -> fprintf ppf "%F" x + | Uconst_int32 x -> fprintf ppf "%ldl" x + | Uconst_int64 x -> fprintf ppf "%LdL" x + | Uconst_nativeint x -> fprintf ppf "%ndn" x + | Uconst_block (tag, l) -> + fprintf ppf "block(%i" tag; + List.iter (fun u -> fprintf ppf ",%a" uconstant u) l; + fprintf ppf ")" + | Uconst_float_array [] -> + fprintf ppf "floatarray()" + | Uconst_float_array (f1 :: fl) -> + fprintf ppf "floatarray(%F" f1; + List.iter (fun f -> fprintf ppf ",%F" f) fl; + fprintf ppf ")" + | Uconst_string s -> fprintf ppf "%S" s + +and uconstant ppf = function + | Uconst_ref (s, c) -> + fprintf ppf "%S=%a" s structured_constant c + | Uconst_int i -> fprintf ppf "%i" i + | Uconst_ptr i -> fprintf ppf "%ia" i let rec lam ppf = function | Uvar id -> Ident.print ppf id - | Uconst (cst,_) -> - Printlambda.structured_constant ppf cst + | Uconst c -> uconstant ppf c | Udirect_apply(f, largs, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in @@ -36,7 +54,7 @@ let idents ppf = List.iter (fprintf ppf "@ %a" Ident.print)in let one_fun ppf f = - fprintf ppf "(fun@ %s@ %d @[<2>%a@] @[<2>%a@])" + fprintf ppf "@[<2>(fun@ %s@ %d @[<2>%a@]@ @[<2>%a@]@])" f.label f.arity idents f.params lam f.body in let funs ppf = List.iter (fprintf ppf "@ %a" one_fun) in @@ -68,23 +86,38 @@ List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(%a%a)@]" Printlambda.primitive prim lams largs | Uswitch(larg, sw) -> - let switch ppf sw = - let spc = ref false in - for i = 0 to Array.length sw.us_index_consts - 1 do - let n = sw.us_index_consts.(i) in - let l = sw.us_actions_consts.(n) in - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case int %i:@ %a@]" i lam l; - done; - for i = 0 to Array.length sw.us_index_blocks - 1 do - let n = sw.us_index_blocks.(i) in - let l = sw.us_actions_blocks.(n) in - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case tag %i:@ %a@]" i lam l; + let print_case tag index i ppf = + for j = 0 to Array.length index - 1 do + if index.(j) = i then fprintf ppf "case %s %i:" tag j + done in + let print_cases tag index cases ppf = + for i = 0 to Array.length cases - 1 do + fprintf ppf "@ @[<2>%t@ %a@]" + (print_case tag index i) sequence cases.(i) done in + let switch ppf sw = + print_cases "int" sw.us_index_consts sw.us_actions_consts ppf ; + print_cases "tag" sw.us_index_blocks sw.us_actions_blocks ppf in fprintf ppf - "@[<1>(switch %a@ @[%a@])@]" + "@[@[<2>(switch@ %a@ @]%a)@]" lam larg switch sw + | Ustringswitch(larg,sw,d) -> + let switch ppf sw = + let spc = ref false in + List.iter + (fun (s,l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case \"%s\":@ %a@]" + (String.escaped s) lam l) + sw ; + begin match d with + | Some d -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam d + | None -> () + end in + fprintf ppf + "@[<1>(switch %a@ @[%a@])@]" lam larg switch sw | Ustaticfail (i, ls) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in @@ -132,3 +165,29 @@ let clambda ppf ulam = fprintf ppf "%a@." lam ulam + + +let rec approx ppf = function + Value_closure(fundesc, a) -> + Format.fprintf ppf "@[<2>function %s@ arity %i" + fundesc.fun_label fundesc.fun_arity; + if fundesc.fun_closed then begin + Format.fprintf ppf "@ (closed)" + end; + if fundesc.fun_inline <> None then begin + Format.fprintf ppf "@ (inline)" + end; + Format.fprintf ppf "@ -> @ %a@]" approx a + | Value_tuple a -> + let tuple ppf a = + for i = 0 to Array.length a - 1 do + if i > 0 then Format.fprintf ppf ";@ "; + Format.fprintf ppf "%i: %a" i approx a.(i) + done in + Format.fprintf ppf "@[(%a)@]" tuple a + | Value_unknown -> + Format.fprintf ppf "_" + | Value_const c -> + fprintf ppf "@[const(%a)@]" uconstant c + | Value_global_field (s, i) -> + fprintf ppf "@[global(%s,%i)@]" s i diff -Nru ocaml-4.01.0/asmcomp/printclambda.mli ocaml-4.02.3/asmcomp/printclambda.mli --- ocaml-4.01.0/asmcomp/printclambda.mli 2012-02-22 09:43:39.000000000 +0100 +++ ocaml-4.02.3/asmcomp/printclambda.mli 2014-03-06 18:03:16.000000000 +0100 @@ -14,3 +14,5 @@ open Format val clambda: formatter -> ulambda -> unit +val approx: formatter -> value_approximation -> unit +val structured_constant: formatter -> ustructured_constant -> unit diff -Nru ocaml-4.01.0/asmcomp/printcmm.ml ocaml-4.02.3/asmcomp/printcmm.ml --- ocaml-4.01.0/asmcomp/printcmm.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/printcmm.ml 2014-04-25 10:41:13.000000000 +0200 @@ -60,6 +60,7 @@ | Caddi -> "+" | Csubi -> "-" | Cmuli -> "*" + | Cmulhi -> "*h" | Cdivi -> "/" | Cmodi -> "mod" | Cand -> "and" @@ -81,13 +82,14 @@ | Cfloatofint -> "floatofint" | Cintoffloat -> "intoffloat" | Ccmpf c -> Printf.sprintf "%sf" (comparison c) - | Craise d -> "raise" ^ Debuginfo.to_string d + | Craise (k, d) -> Lambda.raise_kind k ^ Debuginfo.to_string d | Ccheckbound d -> "checkbound" ^ Debuginfo.to_string d let rec expr ppf = function | Cconst_int n -> fprintf ppf "%i" n - | Cconst_natint n -> fprintf ppf "%s" (Nativeint.to_string n) - | Cconst_float s -> fprintf ppf "%s" s + | Cconst_natint n | Cconst_blockheader n -> + fprintf ppf "%s" (Nativeint.to_string n) + | Cconst_float n -> fprintf ppf "%F" n | Cconst_symbol s -> fprintf ppf "\"%s\"" s | Cconst_pointer n -> fprintf ppf "%ia" n | Cconst_natpointer n -> fprintf ppf "%sa" (Nativeint.to_string n) @@ -186,8 +188,8 @@ | Cint16 n -> fprintf ppf "int16 %i" n | Cint32 n -> fprintf ppf "int32 %s" (Nativeint.to_string n) | Cint n -> fprintf ppf "int %s" (Nativeint.to_string n) - | Csingle f -> fprintf ppf "single %s" f - | Cdouble f -> fprintf ppf "double %s" f + | Csingle f -> fprintf ppf "single %F" f + | Cdouble f -> fprintf ppf "double %F" f | Csymbol_address s -> fprintf ppf "addr \"%s\"" s | Clabel_address l -> fprintf ppf "addr L%i" l | Cstring s -> fprintf ppf "string \"%s\"" s diff -Nru ocaml-4.01.0/asmcomp/printlinear.ml ocaml-4.02.3/asmcomp/printlinear.ml --- ocaml-4.01.0/asmcomp/printlinear.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/printlinear.ml 2013-11-13 14:55:13.000000000 +0100 @@ -60,8 +60,8 @@ fprintf ppf "push trap" | Lpoptrap -> fprintf ppf "pop trap" - | Lraise -> - fprintf ppf "raise %a" reg i.arg.(0) + | Lraise k -> + fprintf ppf "%s %a" (Lambda.raise_kind k) reg i.arg.(0) end; if not (Debuginfo.is_none i.dbg) then fprintf ppf " %s" (Debuginfo.to_string i.dbg) diff -Nru ocaml-4.01.0/asmcomp/printmach.ml ocaml-4.02.3/asmcomp/printmach.ml --- ocaml-4.01.0/asmcomp/printmach.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/printmach.ml 2014-04-26 12:40:22.000000000 +0200 @@ -18,8 +18,8 @@ open Mach let reg ppf r = - if String.length r.name > 0 then - fprintf ppf "%s" r.name + if not (Reg.anonymous r) then + fprintf ppf "%s" (Reg.name r) else fprintf ppf "%s" (match r.typ with Addr -> "A" | Int -> "I" | Float -> "F"); fprintf ppf "/%i" r.stamp; @@ -70,6 +70,7 @@ | Iadd -> " + " | Isub -> " - " | Imul -> " * " + | Imulh -> " *h " | Idiv -> " div " | Imod -> " mod " | Iand -> " & " @@ -102,8 +103,9 @@ | Imove -> regs ppf arg | Ispill -> fprintf ppf "%a (spill)" regs arg | Ireload -> fprintf ppf "%a (reload)" regs arg - | Iconst_int n -> fprintf ppf "%s" (Nativeint.to_string n) - | Iconst_float s -> fprintf ppf "%s" s + | Iconst_int n + | Iconst_blockheader n -> fprintf ppf "%s" (Nativeint.to_string n) + | Iconst_float f -> fprintf ppf "%F" f | Iconst_symbol s -> fprintf ppf "\"%s\"" s | Icall_ind -> fprintf ppf "call %a" regs arg | Icall_imm lbl -> fprintf ppf "call \"%s\" %a" lbl regs arg @@ -111,18 +113,19 @@ | Itailcall_imm lbl -> fprintf ppf "tailcall \"%s\" %a" lbl regs arg | Iextcall(lbl, alloc) -> fprintf ppf "extcall \"%s\" %a%s" lbl regs arg - (if not alloc then "" else " (noalloc)") + (if alloc then "" else " (noalloc)") | Istackoffset n -> fprintf ppf "offset stack %i" n | Iload(chunk, addr) -> fprintf ppf "%s[%a]" (Printcmm.chunk chunk) (Arch.print_addressing reg addr) arg - | Istore(chunk, addr) -> - fprintf ppf "%s[%a] := %a" + | Istore(chunk, addr, is_assign) -> + fprintf ppf "%s[%a] := %a %s" (Printcmm.chunk chunk) (Arch.print_addressing reg addr) (Array.sub arg 1 (Array.length arg - 1)) reg arg.(0) + (if is_assign then "(assign)" else "(init)") | Ialloc n -> fprintf ppf "alloc %i" n | Iintop(op) -> fprintf ppf "%a%s%a" reg arg.(0) (intop op) reg arg.(1) | Iintop_imm(op, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intop op) n @@ -177,8 +180,8 @@ | Itrywith(body, handler) -> fprintf ppf "@[try@,%a@;<0 -2>with@,%a@;<0 -2>endtry@]" instr body instr handler - | Iraise -> - fprintf ppf "raise %a" reg i.arg.(0) + | Iraise k -> + fprintf ppf "%s %a" (Lambda.raise_kind k) reg i.arg.(0) end; if not (Debuginfo.is_none i.dbg) then fprintf ppf "%s" (Debuginfo.to_string i.dbg); diff -Nru ocaml-4.01.0/asmcomp/proc.mli ocaml-4.02.3/asmcomp/proc.mli --- ocaml-4.01.0/asmcomp/proc.mli 2013-06-03 20:03:59.000000000 +0200 +++ ocaml-4.02.3/asmcomp/proc.mli 2014-05-16 16:52:07.000000000 +0200 @@ -40,6 +40,12 @@ val destroyed_at_oper: Mach.instruction_desc -> Reg.t array val destroyed_at_raise: Reg.t array +(* Volatile registers: those that change value when read *) +val regs_are_volatile: Reg.t array -> bool + +(* Pure operations *) +val op_is_pure: Mach.operation -> bool + (* Info for laying out the stack frame *) val num_stack_slots: int array val contains_calls: bool ref diff -Nru ocaml-4.01.0/asmcomp/reg.ml ocaml-4.02.3/asmcomp/reg.ml --- ocaml-4.01.0/asmcomp/reg.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/reg.ml 2014-08-18 20:26:49.000000000 +0200 @@ -12,12 +12,30 @@ open Cmm +module Raw_name = struct + type t = + | Anon + | R + | Ident of Ident.t + + let create_from_ident ident = Ident ident + + let to_string t = + match t with + | Anon -> None + | R -> Some "R" + | Ident ident -> + let name = Ident.name ident in + if String.length name <= 0 then None else Some name +end + type t = - { mutable name: string; + { mutable raw_name: Raw_name.t; stamp: int; typ: Cmm.machtype_component; mutable loc: location; mutable spill: bool; + mutable part: int option; mutable interf: t list; mutable prefer: (t * int) list; mutable degree: int; @@ -37,44 +55,65 @@ type reg = t let dummy = - { name = ""; stamp = 0; typ = Int; loc = Unknown; spill = false; - interf = []; prefer = []; degree = 0; spill_cost = 0; visited = false } + { raw_name = Raw_name.Anon; stamp = 0; typ = Int; loc = Unknown; + spill = false; interf = []; prefer = []; degree = 0; spill_cost = 0; + visited = false; part = None; + } let currstamp = ref 0 let reg_list = ref([] : t list) let create ty = - let r = { name = ""; stamp = !currstamp; typ = ty; loc = Unknown; - spill = false; interf = []; prefer = []; degree = 0; - spill_cost = 0; visited = false } in + let r = { raw_name = Raw_name.Anon; stamp = !currstamp; typ = ty; + loc = Unknown; spill = false; interf = []; prefer = []; degree = 0; + spill_cost = 0; visited = false; part = None; } in reg_list := r :: !reg_list; incr currstamp; r let createv tyv = let n = Array.length tyv in - let rv = Array.create n dummy in + let rv = Array.make n dummy in for i = 0 to n-1 do rv.(i) <- create tyv.(i) done; rv let createv_like rv = let n = Array.length rv in - let rv' = Array.create n dummy in + let rv' = Array.make n dummy in for i = 0 to n-1 do rv'.(i) <- create rv.(i).typ done; rv' let clone r = let nr = create r.typ in - nr.name <- r.name; + nr.raw_name <- r.raw_name; nr let at_location ty loc = - let r = { name = "R"; stamp = !currstamp; typ = ty; loc = loc; spill = false; - interf = []; prefer = []; degree = 0; spill_cost = 0; - visited = false } in + let r = { raw_name = Raw_name.R; stamp = !currstamp; typ = ty; loc; + spill = false; interf = []; prefer = []; degree = 0; + spill_cost = 0; visited = false; part = None; } in incr currstamp; r +let anonymous t = + match Raw_name.to_string t.raw_name with + | None -> true + | Some _raw_name -> false + +let name t = + match Raw_name.to_string t.raw_name with + | None -> "" + | Some raw_name -> + let with_spilled = + if t.spill then + "spilled-" ^ raw_name + else + raw_name + in + match t.part with + | None -> with_spilled + | Some part -> with_spilled ^ "#" ^ string_of_int part + let first_virtual_reg_stamp = ref (-1) let reset() = @@ -139,6 +178,16 @@ else inter_all(i+1) in inter_all 0 +let disjoint_set_array s v = + match Array.length v with + 0 -> true + | 1 -> not (Set.mem v.(0) s) + | n -> let rec disjoint_all i = + if i >= n then true + else if Set.mem v.(i) s then false + else disjoint_all (i+1) + in disjoint_all 0 + let set_of_array v = match Array.length v with 0 -> Set.empty diff -Nru ocaml-4.01.0/asmcomp/reg.mli ocaml-4.02.3/asmcomp/reg.mli --- ocaml-4.01.0/asmcomp/reg.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/reg.mli 2014-04-26 11:31:18.000000000 +0200 @@ -12,12 +12,18 @@ (* Pseudo-registers *) +module Raw_name : sig + type t + val create_from_ident : Ident.t -> t +end + type t = - { mutable name: string; (* Name (for printing) *) + { mutable raw_name: Raw_name.t; (* Name *) stamp: int; (* Unique stamp *) typ: Cmm.machtype_component; (* Type of contents *) mutable loc: location; (* Actual location *) mutable spill: bool; (* "true" to force stack allocation *) + mutable part: int option; (* Zero-based index of part of value *) mutable interf: t list; (* Other regs live simultaneously *) mutable prefer: (t * int) list; (* Preferences for other regs *) mutable degree: int; (* Number of other regs live sim. *) @@ -41,12 +47,18 @@ val clone: t -> t val at_location: Cmm.machtype_component -> location -> t +val anonymous : t -> bool + +(* Name for printing *) +val name : t -> string + module Set: Set.S with type elt = t module Map: Map.S with type key = t val add_set_array: Set.t -> t array -> Set.t val diff_set_array: Set.t -> t array -> Set.t val inter_set_array: Set.t -> t array -> Set.t +val disjoint_set_array: Set.t -> t array -> bool val set_of_array: t array -> Set.t val reset: unit -> unit diff -Nru ocaml-4.01.0/asmcomp/reloadgen.ml ocaml-4.02.3/asmcomp/reloadgen.ml --- ocaml-4.01.0/asmcomp/reloadgen.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/reloadgen.ml 2014-08-18 20:26:49.000000000 +0200 @@ -54,7 +54,7 @@ method private makeregs rv = let n = Array.length rv in - let newv = Array.create n Reg.dummy in + let newv = Array.make n Reg.dummy in for i = 0 to n-1 do newv.(i) <- self#makereg rv.(i) done; newv @@ -88,7 +88,7 @@ already at the correct position (e.g. on stack for some arguments). However, something needs to be done for the function pointer in indirect calls. *) - Iend | Ireturn | Iop(Itailcall_imm _) | Iraise -> i + Iend | Ireturn | Iop(Itailcall_imm _) | Iraise _ -> i | Iop(Itailcall_ind) -> let newarg = self#makereg1 i.arg in insert_moves i.arg newarg diff -Nru ocaml-4.01.0/asmcomp/schedgen.ml ocaml-4.02.3/asmcomp/schedgen.ml --- ocaml-4.01.0/asmcomp/schedgen.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/schedgen.ml 2014-06-05 12:04:27.000000000 +0200 @@ -138,6 +138,8 @@ class virtual scheduler_generic = object (self) +val mutable trywith_nesting = 0 + (* Determine whether an operation ends a basic block or not. Can be overridden for some processors to signal specific instructions that terminate a basic block. *) @@ -154,9 +156,16 @@ (* Determine whether an instruction ends a basic block or not *) -method private instr_in_basic_block instr = +(* PR#2719: it is generally incorrect to schedule checkbound instructions + within a try ... with Invalid_argument _ -> ... + Hence, a checkbound instruction within a try...with block ends the + current basic block. *) + +method private instr_in_basic_block instr try_nesting = match instr.desc with - Lop op -> self#oper_in_basic_block op + Lop op -> + self#oper_in_basic_block op && + not (try_nesting > 0 && self#is_checkbound op) | Lreloadretaddr -> true | _ -> false @@ -165,7 +174,7 @@ load or store instructions (e.g. on the I386). *) method is_store = function - Istore(_, _) -> true + Istore(_, _, _) -> true | _ -> false method is_load = function @@ -336,8 +345,8 @@ if son.emitted_ancestors = son.ancestors then new_queue := son :: !new_queue) node.sons; - instr_cons node.instr.desc node.instr.arg node.instr.res - (self#reschedule !new_queue (date + issue_cycles) cont) + { node.instr with next = + self#reschedule !new_queue (date + issue_cycles) cont } end (* Entry point *) @@ -345,19 +354,21 @@ method schedule_fundecl f = - let rec schedule i = + let rec schedule i try_nesting = match i.desc with - Lend -> i + | Lend -> i + | Lpushtrap -> { i with next = schedule i.next (try_nesting + 1) } + | Lpoptrap -> { i with next = schedule i.next (try_nesting - 1) } | _ -> - if self#instr_in_basic_block i then begin + if self#instr_in_basic_block i try_nesting then begin clear_code_dag(); - schedule_block [] i + schedule_block [] i try_nesting end else - { i with next = schedule i.next } + { i with next = schedule i.next try_nesting } - and schedule_block ready_queue i = - if self#instr_in_basic_block i then - schedule_block (self#add_instruction ready_queue i) i.next + and schedule_block ready_queue i try_nesting = + if self#instr_in_basic_block i try_nesting then + schedule_block (self#add_instruction ready_queue i) i.next try_nesting else begin let critical_outputs = match i.desc with @@ -366,11 +377,11 @@ | Lreturn -> [||] | _ -> i.arg in List.iter (fun x -> ignore (longest_path critical_outputs x)) ready_queue; - self#reschedule ready_queue 0 (schedule i) + self#reschedule ready_queue 0 (schedule i try_nesting) end in if f.fun_fast then begin - let new_body = schedule f.fun_body in + let new_body = schedule f.fun_body 0 in clear_code_dag(); { fun_name = f.fun_name; fun_body = new_body; @@ -380,3 +391,5 @@ f end + +let reset () = clear_code_dag () diff -Nru ocaml-4.01.0/asmcomp/schedgen.mli ocaml-4.02.3/asmcomp/schedgen.mli --- ocaml-4.01.0/asmcomp/schedgen.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/schedgen.mli 2014-05-09 14:01:21.000000000 +0200 @@ -42,3 +42,5 @@ (* Entry point *) method schedule_fundecl : Linearize.fundecl -> Linearize.fundecl end + +val reset : unit -> unit diff -Nru ocaml-4.01.0/asmcomp/selectgen.ml ocaml-4.02.3/asmcomp/selectgen.ml --- ocaml-4.01.0/asmcomp/selectgen.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/selectgen.ml 2014-08-18 20:26:49.000000000 +0200 @@ -33,7 +33,7 @@ end | Calloc -> typ_addr | Cstore c -> typ_void - | Caddi | Csubi | Cmuli | Cdivi | Cmodi | + | Caddi | Csubi | Cmuli | Cmulhi | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Ccmpi _ | Ccmpa _ | Ccmpf _ -> typ_int | Cadda | Csuba -> typ_addr @@ -47,7 +47,8 @@ let size_expr env exp = let rec size localenv = function - Cconst_int _ | Cconst_natint _ -> Arch.size_int + Cconst_int _ | Cconst_natint _ + | Cconst_blockheader _ -> Arch.size_int | Cconst_symbol _ | Cconst_pointer _ | Cconst_natpointer _ -> Arch.size_addr | Cconst_float _ -> Arch.size_float @@ -85,7 +86,7 @@ let all_regs_anonymous rv = try for i = 0 to Array.length rv - 1 do - if String.length rv.(i).name > 0 then raise Exit + if not (Reg.anonymous rv.(i)) then raise Exit done; true with Exit -> @@ -93,10 +94,11 @@ let name_regs id rv = if Array.length rv = 1 then - rv.(0).name <- Ident.name id + rv.(0).raw_name <- Raw_name.create_from_ident id else for i = 0 to Array.length rv - 1 do - rv.(i).name <- Ident.name id ^ "#" ^ string_of_int i + rv.(i).raw_name <- Raw_name.create_from_ident id; + rv.(i).part <- Some i done (* "Join" two instruction sequences, making sure they return their results @@ -109,12 +111,12 @@ | (Some r1, Some r2) -> let l1 = Array.length r1 in assert (l1 = Array.length r2); - let r = Array.create l1 Reg.dummy in + let r = Array.make l1 Reg.dummy in for i = 0 to l1-1 do - if String.length r1.(i).name = 0 then begin + if Reg.anonymous r1.(i) then begin r.(i) <- r1.(i); seq2#insert_move r2.(i) r1.(i) - end else if String.length r2.(i).name = 0 then begin + end else if Reg.anonymous r2.(i) then begin r.(i) <- r2.(i); seq1#insert_move r1.(i) r2.(i) end else begin @@ -137,7 +139,7 @@ None -> None | Some template -> let size_res = Array.length template in - let res = Array.create size_res Reg.dummy in + let res = Array.make size_res Reg.dummy in for i = 0 to size_res - 1 do res.(i) <- Reg.create template.(i).typ done; @@ -153,7 +155,7 @@ let debuginfo_op = function | Capply(_, dbg) -> dbg | Cextcall(_, _, _, dbg) -> dbg - | Craise dbg -> dbg + | Craise (_, dbg) -> dbg | Ccheckbound dbg -> dbg | _ -> Debuginfo.none @@ -177,6 +179,7 @@ method is_simple_expr = function Cconst_int _ -> true | Cconst_natint _ -> true + | Cconst_blockheader _ -> true | Cconst_float _ -> true | Cconst_symbol _ -> true | Cconst_pointer _ -> true @@ -206,8 +209,39 @@ (* Default instruction selection for stores (of words) *) -method select_store addr arg = - (Istore(Word, addr), arg) +method select_store is_assign addr arg = + (Istore(Word, addr, is_assign), arg) + +(* call marking methods, documented in selectgen.mli *) + +method mark_call = + Proc.contains_calls := true + +method mark_tailcall = () + +method mark_c_tailcall = () + +method mark_instr = function + | Iop (Icall_ind | Icall_imm _ | Iextcall _) -> + self#mark_call + | Iop (Itailcall_ind | Itailcall_imm _) -> + self#mark_tailcall + | Iop (Ialloc _) -> + self#mark_call (* caml_alloc*, caml_garbage_collection *) + | Iop (Iintop Icheckbound | Iintop_imm(Icheckbound, _)) -> + self#mark_c_tailcall (* caml_ml_array_bound_error *) + | Iraise raise_kind -> + begin match raise_kind with + | Lambda.Raise_notrace -> () + | Lambda.Raise_regular | Lambda.Raise_reraise -> + if !Clflags.debug then (* PR#6239 *) + (* caml_stash_backtrace; we #mark_call rather than + #mark_c_tailcall to get a good stack backtrace *) + self#mark_call + end + | Itrywith _ -> + self#mark_call + | _ -> () (* Default instruction selection for operators *) @@ -222,28 +256,19 @@ | (Cstore chunk, [arg1; arg2]) -> let (addr, eloc) = self#select_addressing chunk arg1 in if chunk = Word then begin - let (op, newarg2) = self#select_store addr arg2 in + let (op, newarg2) = self#select_store true addr arg2 in (op, [newarg2; eloc]) end else begin - (Istore(chunk, addr), [arg2; eloc]) + (Istore(chunk, addr, true), [arg2; eloc]) (* Inversion addr/datum in Istore *) end | (Calloc, _) -> (Ialloc 0, args) | (Caddi, _) -> self#select_arith_comm Iadd args | (Csubi, _) -> self#select_arith Isub args - | (Cmuli, [arg1; Cconst_int n]) -> - let l = Misc.log2 n in - if n = 1 lsl l - then (Iintop_imm(Ilsl, l), [arg1]) - else self#select_arith_comm Imul args - | (Cmuli, [Cconst_int n; arg1]) -> - let l = Misc.log2 n in - if n = 1 lsl l - then (Iintop_imm(Ilsl, l), [arg1]) - else self#select_arith_comm Imul args | (Cmuli, _) -> self#select_arith_comm Imul args - | (Cdivi, _) -> self#select_arith Idiv args - | (Cmodi, _) -> self#select_arith_comm Imod args + | (Cmulhi, _) -> self#select_arith_comm Imulh args + | (Cdivi, _) -> (Iintop Idiv, args) + | (Cmodi, _) -> (Iintop Imod, args) | (Cand, _) -> self#select_arith_comm Iand args | (Cor, _) -> self#select_arith_comm Ior args | (Cxor, _) -> self#select_arith_comm Ixor args @@ -400,6 +425,9 @@ | Cconst_natint n -> let r = self#regs_for typ_int in Some(self#insert_op (Iconst_int n) [||] r) + | Cconst_blockheader n -> + let r = self#regs_for typ_int in + Some(self#insert_op (Iconst_blockheader n) [||] r) | Cconst_float n -> let r = self#regs_for typ_float in Some(self#insert_op (Iconst_float n) [||] r) @@ -441,13 +469,13 @@ | Some(simple_list, ext_env) -> Some(self#emit_tuple ext_env simple_list) end - | Cop(Craise dbg, [arg]) -> + | Cop(Craise (k, dbg), [arg]) -> begin match self#emit_expr env arg with None -> None | Some r1 -> let rd = [|Proc.loc_exn_bucket|] in self#insert (Iop Imove) r1 rd; - self#insert_debug Iraise dbg rd [||]; + self#insert_debug (Iraise k) dbg rd [||]; None end | Cop(Ccmpf comp, args) -> @@ -461,7 +489,6 @@ let dbg = debuginfo_op op in match new_op with Icall_ind -> - Proc.contains_calls := true; let r1 = self#emit_tuple env new_args in let rarg = Array.sub r1 1 (Array.length r1 - 1) in let rd = self#regs_for ty in @@ -473,7 +500,6 @@ self#insert_move_results loc_res rd stack_ofs; Some rd | Icall_imm lbl -> - Proc.contains_calls := true; let r1 = self#emit_tuple env new_args in let rd = self#regs_for ty in let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in @@ -483,7 +509,6 @@ self#insert_move_results loc_res rd stack_ofs; Some rd | Iextcall(lbl, alloc) -> - Proc.contains_calls := true; let (loc_arg, stack_ofs) = self#emit_extcall_args env new_args in let rd = self#regs_for ty in @@ -492,7 +517,6 @@ self#insert_move_results loc_res rd stack_ofs; Some rd | Ialloc _ -> - Proc.contains_calls := true; let rd = self#regs_for typ_addr in let size = size_expr env (Ctuple new_args) in self#insert (Iop(Ialloc size)) [||] rd; @@ -567,7 +591,6 @@ None end | Ctrywith(e1, v, e2) -> - Proc.contains_calls := true; let (r1, s1) = self#emit_sequence env e1 in let rv = self#regs_for typ_addr in let (r2, s2) = self#emit_sequence (Tbl.add v rv env) e2 in @@ -654,16 +677,16 @@ ref (Arch.offset_addressing Arch.identity_addressing (-Arch.size_int)) in List.iter (fun e -> - let (op, arg) = self#select_store !a e in + let (op, arg) = self#select_store false !a e in match self#emit_expr env arg with None -> assert false | Some regs -> match op with - Istore(_, _) -> + Istore(_, _, _) -> for i = 0 to Array.length regs - 1 do let r = regs.(i) in let kind = if r.typ = Float then Double_u else Word in - self#insert (Iop(Istore(kind, !a))) + self#insert (Iop(Istore(kind, !a, false))) (Array.append [|r|] regs_addr) [||]; a := Arch.offset_addressing !a (size_component r.typ) done @@ -704,7 +727,6 @@ self#insert (Iop Itailcall_ind) (Array.append [|r1.(0)|] loc_arg) [||] end else begin - Proc.contains_calls := true; let rd = self#regs_for ty in let loc_res = Proc.loc_results rd in self#insert_move_args rarg loc_arg stack_ofs; @@ -724,7 +746,6 @@ self#insert_moves r1 loc_arg'; self#insert (Iop(Itailcall_imm lbl)) loc_arg' [||] end else begin - Proc.contains_calls := true; let rd = self#regs_for ty in let loc_res = Proc.loc_results rd in self#insert_move_args r1 loc_arg stack_ofs; @@ -774,7 +795,6 @@ let s2 = self#emit_tail_sequence new_env e2 in self#insert (Icatch(nfail, s1, s2)) [||] [||] | Ctrywith(e1, v, e2) -> - Proc.contains_calls := true; let (opt_r1, s1) = self#emit_sequence env e1 in let rv = self#regs_for typ_addr in let s2 = self#emit_tail_sequence (Tbl.add v rv env) e2 in @@ -814,9 +834,11 @@ f.Cmm.fun_args rargs Tbl.empty in self#insert_moves loc_arg rarg; self#emit_tail env f.Cmm.fun_body; + let body = self#extract in + instr_iter (fun instr -> self#mark_instr instr.Mach.desc) body; { fun_name = f.Cmm.fun_name; fun_args = loc_arg; - fun_body = self#extract; + fun_body = body; fun_fast = f.Cmm.fun_fast; fun_dbg = f.Cmm.fun_dbg } @@ -835,3 +857,7 @@ let _ = Simplif.is_tail_native_heuristic := is_tail_call + +let reset () = + catch_regs := []; + current_function_name := "" diff -Nru ocaml-4.01.0/asmcomp/selectgen.mli ocaml-4.02.3/asmcomp/selectgen.mli --- ocaml-4.01.0/asmcomp/selectgen.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/selectgen.mli 2014-05-09 14:01:21.000000000 +0200 @@ -35,7 +35,8 @@ method select_condition : Cmm.expression -> Mach.test * Cmm.expression (* Can be overridden to deal with special test instructions *) method select_store : - Arch.addressing_mode -> Cmm.expression -> Mach.operation * Cmm.expression + bool -> Arch.addressing_mode -> Cmm.expression -> + Mach.operation * Cmm.expression (* Can be overridden to deal with special store constant instructions *) method regs_for : Cmm.machtype -> Reg.t array (* Return an array of fresh registers of the given type. @@ -58,6 +59,30 @@ (* Fill a freshly allocated block. Can be overridden for architectures that do not provide Arch.offset_addressing. *) + method mark_call : unit + (* informs the code emitter that the current function is non-leaf: + it may perform a (non-tail) call; by default, sets + [Proc.contains_calls := true] *) + + method mark_tailcall : unit + (* informs the code emitter that the current function may end with + a tail-call; by default, does nothing *) + + method mark_c_tailcall : unit + (* informs the code emitter that the current function may call + a C function that never returns; by default, does nothing. + + It is unecessary to save the stack pointer in this situation + (which is the main purpose of tracking leaf functions) but some + architectures still need to ensure that the stack is properly + aligned when the C function is called. This is achieved by + overloading this method to set [Proc.contains_calls := true] *) + + method mark_instr : Mach.instruction_desc -> unit + (* dispatches on instructions to call one of the marking function + above; overloading this is useful if Ispecific instructions need + marking *) + (* The following method is the entry point and should not be overridden *) method emit_fundecl : Cmm.fundecl -> Mach.fundecl @@ -76,3 +101,5 @@ (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> Reg.t array option method emit_tail : (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> unit end + +val reset : unit -> unit diff -Nru ocaml-4.01.0/asmcomp/sparc/CSE.ml ocaml-4.02.3/asmcomp/sparc/CSE.ml --- ocaml-4.01.0/asmcomp/sparc/CSE.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/sparc/CSE.ml 2014-05-21 17:08:11.000000000 +0200 @@ -0,0 +1,30 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for Sparc *) + +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic (* as super *) + +method! is_cheap_operation op = + match op with + | Iconst_int n | Iconst_blockheader n -> n <= 4095n && n >= -4096n + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff -Nru ocaml-4.01.0/asmcomp/sparc/emit.mlp ocaml-4.02.3/asmcomp/sparc/emit.mlp --- ocaml-4.01.0/asmcomp/sparc/emit.mlp 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/asmcomp/sparc/emit.mlp 2014-04-26 12:40:22.000000000 +0200 @@ -64,7 +64,7 @@ if Config.system = "sunos" then "_" else "" let emit_symbol s = - if String.length s >= 1 & s.[0] = '.' + if String.length s >= 1 && s.[0] = '.' then emit_string s else begin emit_string symbol_prefix; Emitaux.emit_symbol '$' s end @@ -190,7 +190,7 @@ (* Record floating-point constants *) -let float_constants = ref ([] : (int * string) list) +let float_constants = ref ([] : (int * int64) list) let emit_float_constant (lbl, cst) = rodata (); @@ -302,18 +302,18 @@ | (_, _) -> fatal_error "Emit: Imove" end - | Lop(Iconst_int n) -> + | Lop(Iconst_int n | Iconst_blockheader n) -> if is_native_immediate n then ` mov {emit_nativeint n}, {emit_reg i.res.(0)}\n` else begin ` sethi %hi({emit_nativeint n}), %g1\n`; ` or %g1, %lo({emit_nativeint n}), {emit_reg i.res.(0)}\n` end - | Lop(Iconst_float s) -> + | Lop(Iconst_float f) -> (* On UltraSPARC, the fzero instruction could be used to set a floating point register pair to zero. *) let lbl = new_label() in - float_constants := (lbl, s) :: !float_constants; + float_constants := (lbl, Int64.bits_of_float f) :: !float_constants; ` sethi %hi({emit_label lbl}), %g1\n`; ` ldd [%g1 + %lo({emit_label lbl})], {emit_reg i.res.(0)}\n` | Lop(Iconst_symbol s) -> @@ -375,7 +375,7 @@ | _ -> "ld" in emit_load loadinstr addr i.arg dest end - | Lop(Istore(chunk, addr)) -> + | Lop(Istore(chunk, addr, _)) -> let src = i.arg.(0) in begin match chunk with Double_u -> @@ -443,36 +443,15 @@ ` sra {emit_reg i.arg.(0)}, 31, %g1\n`; ` wr %g1, %y\n`; ` sdiv {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` + | Lop(Iintop Imulh) -> + ` smul {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, %g1\n`; + ` rd %y, {emit_reg i.res.(0)}\n` | Lop(Iintop op) -> let instr = name_for_int_operation op in ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Ilsl, 1)) -> (* UltraSPARC has two add units but only one shifter. *) ` add {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n` - | Lop(Iintop_imm(Idiv, n)) -> - let l = Misc.log2 n in - if n = 1 lsl l then begin - let lbl = new_label() in - ` cmp {emit_reg i.arg.(0)}, 0\n`; - ` bge {emit_label lbl}\n`; - ` mov {emit_reg i.arg.(0)}, %g1\n`; (* in delay slot *) - ` add %g1, {emit_int (n-1)}, %g1\n`; - `{emit_label lbl}:\n`; - ` sra %g1, {emit_int l}, {emit_reg i.res.(0)}\n` - end else begin - ` sra {emit_reg i.arg.(0)}, 31, %g1\n`; - ` wr %g1, %y\n`; - ` sdiv {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n` - end - | Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *) - let lbl = new_label() in - ` tst {emit_reg i.arg.(0)}\n`; - ` bge {emit_label lbl}\n`; - ` andcc {emit_reg i.arg.(0)}, {emit_int (n-1)}, {emit_reg i.res.(0)}\n`; (* in delay slot *) - ` be {emit_label lbl}\n`; - ` nop\n`; - ` sub {emit_reg i.res.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`; - `{emit_label lbl}:\n` | Lop(Iintop_imm(Icomp cmp, n)) -> ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; if !arch_version = SPARC_V9 then begin @@ -496,6 +475,9 @@ ` bleu {emit_label !range_check_trap}\n`; ` nop\n` (* delay slot *) end + | Lop(Iintop_imm(Imulh, n)) -> + ` smul {emit_reg i.arg.(0)}, {emit_int n}, %g1\n`; + ` rd %y, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(op, n)) -> let instr = name_for_int_operation op in ` {emit_string instr} {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n` @@ -603,7 +585,7 @@ ` ld [%sp + 100], %l5\n`; ` add %sp, 8, %sp\n`; stack_offset := !stack_offset - 8 - | Lraise -> + | Lraise _ -> ` ld [%l5 + 96], %g1\n`; ` mov %l5, %sp\n`; ` ld [%sp + 100], %l5\n`; @@ -618,7 +600,7 @@ that does not branch. *) let is_one_instr_op = function - Idiv | Imod | Icomp _ | Icheckbound -> false + Imulh | Idiv | Imod | Icomp _ | Icheckbound -> false | _ -> true let is_one_instr i = @@ -627,10 +609,10 @@ begin match op with Imove | Ispill | Ireload -> i.arg.(0).typ <> Float && i.res.(0).typ <> Float - | Iconst_int n -> is_native_immediate n + | Iconst_int n | Iconst_blockheader n -> is_native_immediate n | Istackoffset _ -> true - | Iload(_, Iindexed n) -> i.res.(0).typ <> Float & is_immediate n - | Istore(_, Iindexed n) -> i.arg.(0).typ <> Float & is_immediate n + | Iload(_, Iindexed n) -> i.res.(0).typ <> Float && is_immediate n + | Istore(_, Iindexed n, _) -> i.arg.(0).typ <> Float && is_immediate n | Iintop(op) -> is_one_instr_op op | Iintop_imm(op, _) -> is_one_instr_op op | Iaddf | Isubf | Imulf | Idivf -> true @@ -660,15 +642,15 @@ emit_instr i.next (Some i); emit_all i.next.next | {next = {desc = Lop(Itailcall_imm s)}} - when s = !function_name & is_one_instr i -> + when s = !function_name && is_one_instr i -> emit_instr i.next (Some i); emit_all i.next.next | {next = {desc = Lop(Icall_ind)}} - when is_one_instr i & no_interference i.res i.next.arg -> + when is_one_instr i && no_interference i.res i.next.arg -> emit_instr i.next (Some i); emit_all i.next.next | {next = {desc = Lcondbranch(_, _)}} - when is_one_instr i & no_interference i.res i.next.arg -> + when is_one_instr i && no_interference i.res i.next.arg -> emit_instr i.next (Some i); emit_all i.next.next | _ -> @@ -724,9 +706,9 @@ | Cint n -> ` .word {emit_nativeint n}\n` | Csingle f -> - emit_float32_directive ".word" f + emit_float32_directive ".word" (Int32.bits_of_float f) | Cdouble f -> - emit_float64_split_directive ".word" f + emit_float64_split_directive ".word" (Int64.bits_of_float f) | Csymbol_address s -> ` .word {emit_symbol s}\n` | Clabel_address lbl -> diff -Nru ocaml-4.01.0/asmcomp/sparc/proc.ml ocaml-4.02.3/asmcomp/sparc/proc.ml --- ocaml-4.01.0/asmcomp/sparc/proc.ml 2013-06-03 20:03:59.000000000 +0200 +++ ocaml-4.02.3/asmcomp/sparc/proc.ml 2014-08-18 20:26:49.000000000 +0200 @@ -81,12 +81,12 @@ (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 19 Reg.dummy in + let v = Array.make 19 Reg.dummy in for i = 0 to 18 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 32 Reg.dummy in + let v = Array.make 32 Reg.dummy in for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v @@ -105,7 +105,7 @@ 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 loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in @@ -171,6 +171,10 @@ let loc_exn_bucket = phys_reg 0 (* $o0 *) +(* Volatile registers: none *) + +let regs_are_volatile rs = false + (* Registers destroyed by operations *) let destroyed_at_c_call = (* %l0-%l4, %i0-%i5 preserved *) @@ -196,6 +200,15 @@ Iextcall(_, _) -> [| 11; 0 |] | _ -> [| 19; 15 |] +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | _ -> true + (* Layout of the stack *) let num_stack_slots = [| 0; 0 |] diff -Nru ocaml-4.01.0/asmcomp/sparc/scheduling.ml ocaml-4.02.3/asmcomp/sparc/scheduling.ml --- ocaml-4.01.0/asmcomp/sparc/scheduling.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/sparc/scheduling.ml 2013-11-19 08:01:54.000000000 +0100 @@ -47,8 +47,6 @@ | Ialloc _ -> 6 | Iintop(Icomp _) -> 4 | Iintop(Icheckbound) -> 2 - | Iintop_imm(Idiv, _) -> 5 - | Iintop_imm(Imod, _) -> 5 | Iintop_imm(Icomp _, _) -> 4 | Iintop_imm(Icheckbound, _) -> 2 | Inegf -> 2 diff -Nru ocaml-4.01.0/asmcomp/sparc/selection.ml ocaml-4.02.3/asmcomp/sparc/selection.ml --- ocaml-4.01.0/asmcomp/sparc/selection.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/sparc/selection.ml 2013-11-19 08:01:54.000000000 +0100 @@ -38,23 +38,13 @@ method! select_operation op args = match (op, args) with (* For SPARC V7 multiplication, division and modulus are turned into - calls to C library routines, except if the dividend is a power of 2. + calls to C library routines. For SPARC V8 and V9, use hardware multiplication and division, but C library routine for modulus. *) - (Cmuli, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Ilsl, Misc.log2 n), [arg]) - | (Cmuli, [Cconst_int n; arg]) when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Ilsl, Misc.log2 n), [arg]) - | (Cmuli, _) when !arch_version = SPARC_V7 -> + (Cmuli, _) when !arch_version = SPARC_V7 -> (Iextcall(".umul", false), args) - | (Cdivi, [arg; Cconst_int n]) - when self#is_immediate n && n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg]) | (Cdivi, _) when !arch_version = SPARC_V7 -> (Iextcall(".div", false), args) - | (Cmodi, [arg; Cconst_int n]) - when self#is_immediate n && n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Imod, n), [arg]) | (Cmodi, _) -> (Iextcall(".rem", false), args) | _ -> diff -Nru ocaml-4.01.0/asmcomp/spill.ml ocaml-4.02.3/asmcomp/spill.ml --- ocaml-4.01.0/asmcomp/spill.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/spill.ml 2014-08-18 20:26:49.000000000 +0200 @@ -40,7 +40,7 @@ with Not_found -> let spill_r = Reg.create r.typ in spill_r.spill <- true; - if String.length r.name > 0 then spill_r.name <- "spilled-" ^ r.name; + if not (Reg.anonymous r) then spill_r.raw_name <- r.raw_name; spill_env := Reg.Map.add r spill_r !spill_env; spill_r @@ -64,7 +64,7 @@ let max_pressure = Proc.max_register_pressure op in let regs = Reg.add_set_array live_regs res_regs in (* Compute the pressure in each register class *) - let pressure = Array.create Proc.num_register_classes 0 in + let pressure = Array.make Proc.num_register_classes 0 in Reg.Set.iter (fun r -> if Reg.Set.mem r spilled then () else begin @@ -233,12 +233,17 @@ (i, Reg.Set.empty) | Itrywith(body, handler) -> let (new_body, after_body) = reload body before in - let (new_handler, after_handler) = reload handler handler.live in + (* All registers live at the beginning of the handler are destroyed, + except the exception bucket *) + let before_handler = + Reg.Set.remove Proc.loc_exn_bucket + (Reg.add_set_array handler.live handler.arg) in + let (new_handler, after_handler) = reload handler before_handler in let (new_next, finally) = reload i.next (Reg.Set.union after_body after_handler) in (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next, finally) - | Iraise -> + | Iraise _ -> (add_reloads (Reg.inter_set_array before i.arg) i, Reg.Set.empty) (* Second pass: add spill instructions based on what we've decided to reload. @@ -379,15 +384,19 @@ spill_at_raise := saved_spill_at_raise; (instr_cons (Itrywith(new_body, new_handler)) i.arg i.res new_next, before_body) - | Iraise -> + | Iraise _ -> (i, !spill_at_raise) (* Entry point *) -let fundecl f = +let reset () = spill_env := Reg.Map.empty; use_date := Reg.Map.empty; - current_date := 0; + current_date := 0 + +let fundecl f = + reset (); + let (body1, _) = reload f.fun_body Reg.Set.empty in let (body2, tospill_at_entry) = spill body1 Reg.Set.empty in let new_body = diff -Nru ocaml-4.01.0/asmcomp/spill.mli ocaml-4.02.3/asmcomp/spill.mli --- ocaml-4.01.0/asmcomp/spill.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/spill.mli 2014-05-09 14:22:35.000000000 +0200 @@ -14,3 +14,4 @@ before register allocation. *) val fundecl: Mach.fundecl -> Mach.fundecl +val reset : unit -> unit diff -Nru ocaml-4.01.0/asmcomp/split.ml ocaml-4.02.3/asmcomp/split.ml --- ocaml-4.01.0/asmcomp/split.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/split.ml 2014-08-18 20:26:49.000000000 +0200 @@ -30,7 +30,7 @@ None -> rv | Some s -> let n = Array.length rv in - let nv = Array.create n Reg.dummy in + let nv = Array.make n Reg.dummy in for i = 0 to n-1 do nv.(i) <- subst_reg rv.(i) s done; nv @@ -184,8 +184,8 @@ rename i.next (merge_substs sub_body sub_handler i.next) in (instr_cons (Itrywith(new_body, new_handler)) [||] [||] new_next, sub_next) - | Iraise -> - (instr_cons_debug Iraise (subst_regs i.arg sub) [||] i.dbg i.next, + | Iraise k -> + (instr_cons_debug (Iraise k) (subst_regs i.arg sub) [||] i.dbg i.next, None) (* Second pass: replace registers by their final representatives *) @@ -195,8 +195,13 @@ (* Entry point *) -let fundecl f = +let reset () = equiv_classes := Reg.Map.empty; + exit_subst := [] + +let fundecl f = + reset (); + let new_args = Array.copy f.fun_args in let (new_body, sub_body) = rename f.fun_body (Some Reg.Map.empty) in repres_regs new_args; diff -Nru ocaml-4.01.0/asmcomp/split.mli ocaml-4.02.3/asmcomp/split.mli --- ocaml-4.01.0/asmcomp/split.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmcomp/split.mli 2014-05-09 14:01:21.000000000 +0200 @@ -13,3 +13,5 @@ (* Renaming of registers at reload points to split live ranges. *) val fundecl: Mach.fundecl -> Mach.fundecl + +val reset : unit -> unit diff -Nru ocaml-4.01.0/asmcomp/strmatch.ml ocaml-4.02.3/asmcomp/strmatch.ml --- ocaml-4.01.0/asmcomp/strmatch.ml 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/strmatch.ml 2014-04-12 12:17:02.000000000 +0200 @@ -0,0 +1,389 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Translation of string matching from closed lambda to C-- *) + +open Lambda +open Cmm + +module type I = sig + val string_block_length : Cmm.expression -> Cmm.expression + val transl_switch : + Cmm.expression -> int -> int -> + (int * Cmm.expression) list -> Cmm.expression -> + Cmm.expression +end + +module Make(I:I) = struct + +(* Debug *) + + let dbg = false + + let mask = + let open Nativeint in + sub (shift_left one 8) one + + let pat_as_string p = + let rec digits k n p = + if n <= 0 then k + else + let d = Nativeint.to_int (Nativeint.logand mask p) in + let d = Char.escaped (Char.chr d) in + digits (d::k) (n-1) (Nativeint.shift_right_logical p 8) in + let ds = digits [] Arch.size_addr p in + let ds = + if Arch.big_endian then ds else List.rev ds in + String.concat "" ds + + let do_pp_cases chan cases = + List.iter + (fun (ps,_) -> + Printf.fprintf chan " [%s]\n" + (String.concat "; " (List.map pat_as_string ps))) + cases + + let pp_cases chan tag cases = + Printf.eprintf "%s:\n" tag ; + do_pp_cases chan cases + + let pp_match chan tag idxs cases = + Printf.eprintf + "%s: idx=[%s]\n" tag + (String.concat "; " (List.map string_of_int idxs)) ; + do_pp_cases chan cases + +(* Utilities *) + + let gen_cell_id () = Ident.create "cell" + let gen_size_id () = Ident.create "size" + + let mk_let_cell id str ind body = + let cell = + Cop(Cload Word,[Cop(Cadda,[str;Cconst_int(Arch.size_int*ind)])]) in + Clet(id, cell, body) + + let mk_let_size id str body = + let size = I.string_block_length str in + Clet(id, size, body) + + let mk_cmp_gen cmp_op id nat ifso ifnot = + let test = Cop (Ccmpi cmp_op, [ Cvar id; Cconst_natpointer nat ]) in + Cifthenelse (test, ifso, ifnot) + + let mk_lt = mk_cmp_gen Clt + let mk_eq = mk_cmp_gen Ceq + + module IntArg = + struct + type t = int + let compare (x:int) (y:int) = + if x < y then -1 + else if x > y then 1 + else 0 + end + + let interval m0 n = + let rec do_rec m = + if m >= n then [] + else m::do_rec (m+1) in + do_rec m0 + + +(*****************************************************) +(* Compile strings to a lists of words [native ints] *) +(*****************************************************) + + let pat_of_string str = + let len = String.length str in + let n = len / Arch.size_addr + 1 in + let get_byte i = + if i < len then int_of_char str.[i] + else if i < n * Arch.size_addr - 1 then 0 + else n * Arch.size_addr - 1 - len in + let mk_word ind = + let w = ref 0n in + let imin = ind * Arch.size_addr + and imax = (ind + 1) * Arch.size_addr - 1 in + if Arch.big_endian then + for i = imin to imax do + w := Nativeint.logor (Nativeint.shift_left !w 8) + (Nativeint.of_int (get_byte i)); + done + else + for i = imax downto imin do + w := Nativeint.logor (Nativeint.shift_left !w 8) + (Nativeint.of_int (get_byte i)); + done; + !w in + let rec mk_words ind = + if ind >= n then [] + else mk_word ind::mk_words (ind+1) in + mk_words 0 + +(*****************************) +(* Discriminating heuristics *) +(*****************************) + + module IntSet = Set.Make(IntArg) + module NativeSet = Set.Make(Nativeint) + + let rec add_one sets ps = match sets,ps with + | [],[] -> [] + | set::sets,p::ps -> + let sets = add_one sets ps in + NativeSet.add p set::sets + | _,_ -> assert false + + let count_arities cases = match cases with + | [] -> assert false + | (ps,_)::_ -> + let sets = + List.fold_left + (fun sets (ps,_) -> add_one sets ps) + (List.map (fun _ -> NativeSet.empty) ps) cases in + List.map NativeSet.cardinal sets + + let count_arities_first cases = + let set = + List.fold_left + (fun set case -> match case with + | (p::_,_) -> NativeSet.add p set + | _ -> assert false) + NativeSet.empty cases in + NativeSet.cardinal set + + let count_arities_length cases = + let set = + List.fold_left + (fun set (ps,_) -> IntSet.add (List.length ps) set) + IntSet.empty cases in + IntSet.cardinal set + + let best_col = + let rec do_rec kbest best k = function + | [] -> kbest + | x::xs -> + if x < best then + do_rec k x (k+1) xs + else + do_rec kbest best (k+1) xs in + let smallest = do_rec (-1) max_int 0 in + fun cases -> + let ars = count_arities cases in + smallest ars + + let swap_list = + let rec do_rec k xs = match xs with + | [] -> assert false + | x::xs -> + if k <= 0 then [],x,xs + else + let xs,mid,ys = do_rec (k-1) xs in + x::xs,mid,ys in + fun k xs -> + let xs,x,ys = do_rec k xs in + x::xs @ ys + + let swap k idxs cases = + if k = 0 then idxs,cases + else + let idxs = swap_list k idxs + and cases = + List.map + (fun (ps,act) -> swap_list k ps,act) + cases in + if dbg then begin + pp_match stderr "SWAP" idxs cases + end ; + idxs,cases + + let best_first idxs cases = match idxs with + | []|[_] -> idxs,cases (* optimisation: one column only *) + | _ -> + let k = best_col cases in + swap k idxs cases + +(************************************) +(* Divide according to first column *) +(************************************) + + module Divide(O:Set.OrderedType) = struct + + module OMap = Map.Make(O) + + let do_find key env = + try OMap.find key env + with Not_found -> assert false + + let divide cases = + let env = + List.fold_left + (fun env (p,psact) -> + let old = + try OMap.find p env + with Not_found -> [] in + OMap.add p ((psact)::old) env) + OMap.empty cases in + let r = OMap.fold (fun key v k -> (key,v)::k) env [] in + List.rev r (* Now sorted *) + end + +(***************) +(* Compilation *) +(***************) + +(* Group by cell *) + + module DivideNative = Divide(Nativeint) + + let by_cell cases = + DivideNative.divide + (List.map + (fun case -> match case with + | (p::ps),act -> p,(ps,act) + | [],_ -> assert false) + cases) + +(* Split into two halves *) + + let rec do_split idx env = match env with + | [] -> assert false + | (midkey,_ as x)::rem -> + if idx <= 0 then [],midkey,env + else + let lt,midkey,ge = do_split (idx-1) rem in + x::lt,midkey,ge + + let split_env len env = do_split (len/2) env + +(* Switch according to one cell *) + +(* + Emit the switch, here as a comparison tree. + Argument compile_rec is to be called to compile the rest of patterns, + as match_on_cell can be called in two different contexts : + from do_compile_pats and top_compile below. + *) + let match_oncell compile_rec str default idx env = + let id = gen_cell_id () in + let rec comp_rec env = + let len = List.length env in + if len <= 3 then + List.fold_right + (fun (key,cases) ifnot -> + mk_eq id key + (compile_rec str default cases) + ifnot) + env default + else + let lt,midkey,ge = split_env len env in + mk_lt id midkey (comp_rec lt) (comp_rec ge) in + mk_let_cell id str idx (comp_rec env) + +(* + Recursive 'list of cells' compile function: + - choose the matched cell and switch on it + - notice: patterns (and idx) all have the same length + *) + + let rec do_compile_pats idxs str default cases = + if dbg then begin + pp_match stderr "COMPILE" idxs cases + end ; + match idxs with + | [] -> + begin match cases with + | [] -> default + | (_,e)::_ -> e + end + | _::_ -> + let idxs,cases = best_first idxs cases in + begin match idxs with + | [] -> assert false + | idx::idxs -> + match_oncell + (do_compile_pats idxs) str default idx (by_cell cases) + end + + +(* Group by size *) + + module DivideInt = Divide(IntArg) + + + let by_size cases = + DivideInt.divide + (List.map + (fun (ps,_ as case) -> List.length ps,case) + cases) +(* + Switch according to pattern size + Argument from_ind is the starting index, it can be zero + or one (when the swicth on the cell 0 has already been performed. + In that latter case pattern len is string length-1 and is corrected. + *) + + let compile_by_size from_ind str default cases = + let size_cases = + List.map + (fun (len,cases) -> + let len = len+from_ind in + let act = + do_compile_pats + (interval from_ind len) + str default cases in + (len,act)) + (by_size cases) in + let id = gen_size_id () in + let switch = I.transl_switch (Cvar id) 1 max_int size_cases default in + mk_let_size id str switch + +(* + Compilation entry point: we choose to switch + either on size or on first cell, using the + 'least discriminant' heuristics. + *) + let top_compile str default cases = + let a_len = count_arities_length cases + and a_fst = count_arities_first cases in + if a_len <= a_fst then begin + if dbg then pp_cases stderr "SIZE" cases ; + compile_by_size 0 str default cases + end else begin + if dbg then pp_cases stderr "FIRST COL" cases ; + let compile_size_rest str default cases = + compile_by_size 1 str default cases in + match_oncell compile_size_rest str default 0 (by_cell cases) + end + +(* Module entry point *) + + let catch arg k = match arg with + | Cexit (e,[]) -> k arg + | _ -> + let e = next_raise_count () in + Ccatch (e,[],k (Cexit (e,[])),arg) + + let compile str default cases = +(* We do not attempt to really optimise default=None *) + let cases,default = match cases,default with + | (_,e)::cases,None + | cases,Some e -> cases,e + | [],None -> assert false in + let cases = + List.rev_map + (fun (s,act) -> pat_of_string s,act) + cases in + catch default (fun default -> top_compile str default cases) + + end diff -Nru ocaml-4.01.0/asmcomp/strmatch.mli ocaml-4.02.3/asmcomp/strmatch.mli --- ocaml-4.01.0/asmcomp/strmatch.mli 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmcomp/strmatch.mli 2014-04-07 17:43:20.000000000 +0200 @@ -0,0 +1,28 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Translation of string matching from closed lambda to C-- *) + +module type I = sig + val string_block_length : Cmm.expression -> Cmm.expression + val transl_switch : + Cmm.expression -> int -> int -> + (int * Cmm.expression) list -> Cmm.expression -> + Cmm.expression +end + +module Make(I:I) : sig + (* Compile stringswitch (arg,cases,d) + Note: cases should not contain string duplicates *) + val compile : Cmm.expression (* arg *) -> Cmm.expression option (* d *) -> + (string * Cmm.expression) list (* cases *)-> Cmm.expression +end diff -Nru ocaml-4.01.0/asmrun/amd64nt.asm ocaml-4.02.3/asmrun/amd64nt.asm --- ocaml-4.01.0/asmrun/amd64nt.asm 2013-06-03 20:03:59.000000000 +0200 +++ ocaml-4.02.3/asmrun/amd64nt.asm 2013-11-13 14:55:13.000000000 +0100 @@ -29,6 +29,7 @@ EXTRN caml_last_return_address: QWORD EXTRN caml_gc_regs: QWORD EXTRN caml_exception_pointer: QWORD + EXTRN caml_backtrace_pos: DWORD EXTRN caml_backtrace_active: DWORD EXTRN caml_stash_backtrace: NEAR @@ -306,6 +307,8 @@ pop r14 ; Recover previous exception handler ret ; Branch to handler L110: + mov caml_backtrace_pos, 0 +L111: mov r12, rax ; Save exception bucket in r12 mov rcx, rax ; Arg 1: exception bucket mov rdx, [rsp] ; Arg 2: PC of raise @@ -318,19 +321,28 @@ pop r14 ; Recover previous exception handler ret ; Branch to handler + PUBLIC caml_reraise_exn + ALIGN 16 +caml_reraise_exn: + test caml_backtrace_active, 1 + jne L111 + mov rsp, r14 ; Cut stack + pop r14 ; Recover previous exception handler + ret ; Branch to handler + ; Raise an exception from C PUBLIC caml_raise_exception ALIGN 16 caml_raise_exception: test caml_backtrace_active, 1 - jne L111 + jne L112 mov rax, rcx ; First argument is exn bucket mov rsp, caml_exception_pointer pop r14 ; Recover previous exception handler mov r15, caml_young_ptr ; Reload alloc ptr ret -L111: +L112: mov r12, rcx ; Save exception bucket in r12 ; Arg 1: exception bucket mov rdx, caml_last_return_address ; Arg 2: PC of raise diff -Nru ocaml-4.01.0/asmrun/amd64.S ocaml-4.02.3/asmrun/amd64.S --- ocaml-4.01.0/asmrun/amd64.S 2013-07-23 16:48:47.000000000 +0200 +++ ocaml-4.02.3/asmrun/amd64.S 2015-05-06 17:10:59.000000000 +0200 @@ -32,7 +32,7 @@ .align FUNCTION_ALIGN; \ name: -#elif defined(SYS_mingw64) +#elif defined(SYS_mingw64) || defined(SYS_cygwin) #define LBL(x) .L##x #define G(r) r @@ -90,7 +90,7 @@ #endif -#if defined(__PIC__) && !defined(SYS_mingw64) +#if defined(__PIC__) && !defined(SYS_mingw64) && !defined(SYS_cygwin) /* Position-independent operations on global variables. */ @@ -99,6 +99,10 @@ movq GREL(dstlabel)(%rip), %r11 ; \ movq srcreg, (%r11) +#define STORE_VAR32(srcreg,dstlabel) \ + movq GREL(dstlabel)(%rip), %r11 ; \ + movl srcreg, (%r11) + /* Load global [srclabel] in register [dstreg]. Clobbers %r11. */ #define LOAD_VAR(srclabel,dstreg) \ movq GREL(srclabel)(%rip), %r11 ; \ @@ -144,6 +148,9 @@ #define STORE_VAR(srcreg,dstlabel) \ movq srcreg, G(dstlabel)(%rip) +#define STORE_VAR32(srcreg,dstlabel) \ + movl srcreg, G(dstlabel)(%rip) + #define LOAD_VAR(srclabel,dstreg) \ movq G(srclabel)(%rip), dstreg @@ -172,7 +179,7 @@ /* Save and restore all callee-save registers on stack. Keep the stack 16-aligned. */ -#if defined(SYS_mingw64) +#if defined(SYS_mingw64) || defined(SYS_cygwin) /* Win64 API: callee-save regs are rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 */ @@ -242,7 +249,7 @@ #endif -#ifdef SYS_mingw64 +#if defined(SYS_mingw64) || defined (SYS_cygwin) /* Calls from OCaml to C must reserve 32 bytes of extra stack space */ # define PREPARE_FOR_C_CALL subq $32, %rsp; CFI_ADJUST(32) # define CLEANUP_AFTER_C_CALL addq $32, %rsp; CFI_ADJUST(-32) @@ -264,7 +271,7 @@ CFI_STARTPROC RECORD_STACK_FRAME(0) LBL(caml_call_gc): -#ifndef SYS_mingw64 +#if !defined(SYS_mingw64) && !defined(SYS_cygwin) /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ subq $32768, %rsp @@ -441,7 +448,7 @@ STORE_VAR(%r12, caml_last_return_address) STORE_VAR(%rsp, caml_bottom_of_stack) subq $8, %rsp; CFI_ADJUST(8) /* equivalent to pushq %r12 */ -#ifndef SYS_mingw64 +#if !defined(SYS_mingw64) && !defined(SYS_cygwin) /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ subq $32768, %rsp @@ -464,7 +471,7 @@ /* Save callee-save registers */ PUSH_CALLEE_SAVE_REGS /* Initial entry point is G(caml_program) */ - leaq GCALL(caml_program)(%rip), %r12 + LEA_VAR(caml_program, %r12) /* Common code for caml_start_program and caml_callback* */ LBL(caml_start_program): /* Build a callback link */ @@ -510,7 +517,7 @@ /* Registers holding arguments of C functions. */ -#ifdef SYS_mingw64 +#if defined(SYS_mingw64) || defined(SYS_cygwin) #define C_ARG_1 %rcx #define C_ARG_2 %rdx #define C_ARG_3 %r8 @@ -532,6 +539,8 @@ popq %r14 ret LBL(110): + STORE_VAR32($0, caml_backtrace_pos) +LBL(111): movq %rax, %r12 /* Save exception bucket */ movq %rax, C_ARG_1 /* arg 1: exception bucket */ #ifdef WITH_FRAME_POINTERS @@ -553,18 +562,27 @@ ret CFI_ENDPROC +FUNCTION(G(caml_reraise_exn)) +CFI_STARTPROC + TESTL_VAR($1, caml_backtrace_active) + jne LBL(111) + movq %r14, %rsp + popq %r14 + ret +CFI_ENDPROC + /* Raise an exception from C */ FUNCTION(G(caml_raise_exception)) CFI_STARTPROC TESTL_VAR($1, caml_backtrace_active) - jne LBL(111) + jne LBL(112) movq C_ARG_1, %rax LOAD_VAR(caml_exception_pointer, %rsp) /* Cut stack */ popq %r14 /* Recover previous exception handler */ LOAD_VAR(caml_young_ptr, %r15) /* Reload alloc ptr */ ret -LBL(111): +LBL(112): #ifdef WITH_FRAME_POINTERS ENTER_FUNCTION ; #endif @@ -592,7 +610,7 @@ backtrace anyway. */ FUNCTION(G(caml_stack_overflow)) - LEA_VAR(caml_bucket_Stack_overflow, %rax) + LEA_VAR(caml_exn_Stack_overflow, %rax) movq %r14, %rsp /* cut the stack */ popq %r14 /* recover previous exn handler */ ret /* jump to handler's code */ @@ -618,7 +636,7 @@ movq C_ARG_1, %rdi /* closure -- no op with Unix conventions */ movq C_ARG_2, %rax /* first argument */ movq C_ARG_3, %rbx /* second argument */ - leaq GCALL(caml_apply2)(%rip), %r12 /* code pointer */ + LEA_VAR(caml_apply2, %r12) /* code pointer */ jmp LBL(caml_start_program) CFI_ENDPROC @@ -631,13 +649,13 @@ movq C_ARG_3, %rbx /* second argument */ movq C_ARG_1, %rsi /* closure */ movq C_ARG_4, %rdi /* third argument */ - leaq GCALL(caml_apply3)(%rip), %r12 /* code pointer */ + LEA_VAR(caml_apply3, %r12) /* code pointer */ jmp LBL(caml_start_program) CFI_ENDPROC FUNCTION(G(caml_ml_array_bound_error)) CFI_STARTPROC - leaq GCALL(caml_array_bound_error)(%rip), %rax + LEA_VAR(caml_array_bound_error, %rax) jmp LBL(caml_c_call) CFI_ENDPROC @@ -656,7 +674,7 @@ #if defined(SYS_macosx) .literal16 -#elif defined(SYS_mingw64) +#elif defined(SYS_mingw64) || defined(SYS_cygwin) .section .rdata,"dr" #else .section .rodata.cst8,"a",@progbits diff -Nru ocaml-4.01.0/asmrun/arm64.S ocaml-4.02.3/asmrun/arm64.S --- ocaml-4.01.0/asmrun/arm64.S 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/asmrun/arm64.S 2014-08-09 00:10:40.000000000 +0200 @@ -0,0 +1,551 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ +/* */ +/* Copyright 2013 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Asm part of the runtime system, ARM processor, 64-bit mode */ +/* Must be preprocessed by cpp */ + +/* Special registers */ + +#define TRAP_PTR x26 +#define ALLOC_PTR x27 +#define ALLOC_LIMIT x28 +#define ARG x15 +#define TMP x16 +#define TMP2 x17 + +/* Support for CFI directives */ + +#if defined(ASM_CFI_SUPPORTED) +#define CFI_STARTPROC .cfi_startproc +#define CFI_ENDPROC .cfi_endproc +#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n +#else +#define CFI_STARTPROC +#define CFI_ENDPROC +#define CFI_ADJUST(n) +#endif + +/* Support for profiling with gprof */ + +#define PROFILE + +/* Macros to load and store global variables. Destroy TMP2 */ + +#if defined(__PIC__) + +#define ADDRGLOBAL(reg,symb) \ + adrp TMP2, :got:symb; \ + ldr reg, [TMP2, #:got_lo12:symb] + +#define LOADGLOBAL(reg,symb) \ + ADDRGLOBAL(TMP2,symb); \ + ldr reg, [TMP2] + +#define STOREGLOBAL(reg,symb) \ + ADDRGLOBAL(TMP2,symb); \ + str reg, [TMP2] + +#else + +#define ADDRGLOBAL(reg,symb) \ + adrp reg, symb; \ + add reg, reg, #:lo12:symb + +#define LOADGLOBAL(reg,symb) \ + adrp TMP2, symb; \ + ldr reg, [TMP2, #:lo12:symb] + +#define STOREGLOBAL(reg,symb) \ + adrp TMP2, symb; \ + str reg, [TMP2, #:lo12:symb] + +#endif + +/* Allocation functions and GC interface */ + + .globl caml_system__code_begin +caml_system__code_begin: + + .align 2 + .globl caml_call_gc +caml_call_gc: + CFI_STARTPROC + PROFILE + /* Record return address */ + STOREGLOBAL(x30, caml_last_return_address) + /* Record lowest stack address */ + mov TMP, sp + STOREGLOBAL(TMP, caml_bottom_of_stack) +.Lcaml_call_gc: + /* Set up stack space, saving return address and frame pointer */ + /* (2 regs RA/GP, 24 allocatable int regs, 24 caller-save float regs) * 8 */ + stp x29, x30, [sp, -400]! + CFI_ADJUST(400) + add x29, sp, #0 + /* Save allocatable integer registers on the stack, in the order + given in proc.ml */ + stp x0, x1, [sp, 16] + stp x2, x3, [sp, 32] + stp x4, x5, [sp, 48] + stp x6, x7, [sp, 64] + stp x8, x9, [sp, 80] + stp x10, x11, [sp, 96] + stp x12, x13, [sp, 112] + stp x14, x15, [sp, 128] + stp x19, x20, [sp, 144] + stp x21, x22, [sp, 160] + stp x23, x24, [sp, 176] + str x25, [sp, 192] + /* Save caller-save floating-point registers on the stack + (callee-saves are preserved by caml_garbage_collection) */ + stp d0, d1, [sp, 208] + stp d2, d3, [sp, 224] + stp d4, d5, [sp, 240] + stp d6, d7, [sp, 256] + stp d16, d17, [sp, 272] + stp d18, d19, [sp, 288] + stp d20, d21, [sp, 304] + stp d22, d23, [sp, 320] + stp d24, d25, [sp, 336] + stp d26, d27, [sp, 352] + stp d28, d29, [sp, 368] + stp d30, d31, [sp, 384] + /* Store pointer to saved integer registers in caml_gc_regs */ + add TMP, sp, #16 + STOREGLOBAL(TMP, caml_gc_regs) + /* Save current allocation pointer for debugging purposes */ + STOREGLOBAL(ALLOC_PTR, caml_young_ptr) + /* Save trap pointer in case an exception is raised during GC */ + STOREGLOBAL(TRAP_PTR, caml_exception_pointer) + /* Call the garbage collector */ + bl caml_garbage_collection + /* Restore registers */ + ldp x0, x1, [sp, 16] + ldp x2, x3, [sp, 32] + ldp x4, x5, [sp, 48] + ldp x6, x7, [sp, 64] + ldp x8, x9, [sp, 80] + ldp x10, x11, [sp, 96] + ldp x12, x13, [sp, 112] + ldp x14, x15, [sp, 128] + ldp x19, x20, [sp, 144] + ldp x21, x22, [sp, 160] + ldp x23, x24, [sp, 176] + ldr x25, [sp, 192] + ldp d0, d1, [sp, 208] + ldp d2, d3, [sp, 224] + ldp d4, d5, [sp, 240] + ldp d6, d7, [sp, 256] + ldp d16, d17, [sp, 272] + ldp d18, d19, [sp, 288] + ldp d20, d21, [sp, 304] + ldp d22, d23, [sp, 320] + ldp d24, d25, [sp, 336] + ldp d26, d27, [sp, 352] + ldp d28, d29, [sp, 368] + ldp d30, d31, [sp, 384] + /* Reload new allocation pointer and allocation limit */ + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) + /* Free stack space and return to caller */ + ldp x29, x30, [sp], 400 + ret + CFI_ENDPROC + .type caml_call_gc, %function + .size caml_call_gc, .-caml_call_gc + + .align 2 + .globl caml_alloc1 +caml_alloc1: + CFI_STARTPROC + PROFILE +1: sub ALLOC_PTR, ALLOC_PTR, #16 + cmp ALLOC_PTR, ALLOC_LIMIT + b.lo 2f + ret +2: stp x29, x30, [sp, -16]! + CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. This is the address + immediately above the pair of words (x29 and x30) we just pushed. Those must + not be included since otherwise the distance from [caml_bottom_of_stack] to the + highest address in the caller's stack frame won't match the frame size contained + in the relevant frame descriptor. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) + add x29, sp, #0 + /* Record return address */ + STOREGLOBAL(x30, caml_last_return_address) + /* Call GC */ + bl .Lcaml_call_gc + /* Restore return address */ + ldp x29, x30, [sp], 16 + CFI_ADJUST(-16) + /* Try again */ + b 1b + CFI_ENDPROC + .type caml_alloc1, %function + .size caml_alloc1, .-caml_alloc1 + + .align 2 + .globl caml_alloc2 +caml_alloc2: + CFI_STARTPROC + PROFILE +1: sub ALLOC_PTR, ALLOC_PTR, #24 + cmp ALLOC_PTR, ALLOC_LIMIT + b.lo 2f + ret +2: stp x29, x30, [sp, -16]! + CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. See comment above. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) + add x29, sp, #0 + /* Record return address */ + STOREGLOBAL(x30, caml_last_return_address) + /* Call GC */ + bl .Lcaml_call_gc + /* Restore return address */ + ldp x29, x30, [sp], 16 + CFI_ADJUST(-16) + /* Try again */ + b 1b + CFI_ENDPROC + .type caml_alloc2, %function + .size caml_alloc2, .-caml_alloc2 + + .align 2 + .globl caml_alloc3 +caml_alloc3: + CFI_STARTPROC + PROFILE +1: sub ALLOC_PTR, ALLOC_PTR, #32 + cmp ALLOC_PTR, ALLOC_LIMIT + b.lo 2f + ret +2: stp x29, x30, [sp, -16]! + CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. See comment above. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) + add x29, sp, #0 + /* Record return address */ + STOREGLOBAL(x30, caml_last_return_address) + /* Call GC */ + bl .Lcaml_call_gc + /* Restore return address */ + ldp x29, x30, [sp], 16 + CFI_ADJUST(-16) + /* Try again */ + b 1b + CFI_ENDPROC + .type caml_alloc2, %function + .size caml_alloc2, .-caml_alloc2 + + .align 2 + .globl caml_allocN +caml_allocN: + CFI_STARTPROC + PROFILE +1: sub ALLOC_PTR, ALLOC_PTR, ARG + cmp ALLOC_PTR, ALLOC_LIMIT + b.lo 2f + ret +2: stp x29, x30, [sp, -16]! + CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. See comment above. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) + add x29, sp, #0 + /* Record return address */ + STOREGLOBAL(x30, caml_last_return_address) + /* Call GC. This preserves ARG */ + bl .Lcaml_call_gc + /* Restore return address */ + ldp x29, x30, [sp], 16 + CFI_ADJUST(-16) + /* Try again */ + b 1b + CFI_ENDPROC + .type caml_allocN, %function + .size caml_allocN, .-caml_allocN + +/* Call a C function from OCaml */ +/* Function to call is in ARG */ + + .align 2 + .globl caml_c_call +caml_c_call: + CFI_STARTPROC + PROFILE + /* Preserve return address in callee-save register x19 */ + mov x19, x30 + /* Record lowest stack address and return address */ + STOREGLOBAL(x30, caml_last_return_address) + add TMP, sp, #0 + STOREGLOBAL(TMP, caml_bottom_of_stack) + /* Make the exception handler alloc ptr available to the C code */ + STOREGLOBAL(ALLOC_PTR, caml_young_ptr) + STOREGLOBAL(TRAP_PTR, caml_exception_pointer) + /* Call the function */ + blr ARG + /* Reload alloc ptr and alloc limit */ + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) + /* Return */ + ret x19 + CFI_ENDPROC + .type caml_c_call, %function + .size caml_c_call, .-caml_c_call + +/* Start the OCaml program */ + + .align 2 + .globl caml_start_program +caml_start_program: + CFI_STARTPROC + PROFILE + ADDRGLOBAL(ARG, caml_program) + +/* Code shared with caml_callback* */ +/* Address of OCaml code to call is in ARG */ +/* Arguments to the OCaml code are in x0...x7 */ + +.Ljump_to_caml: + /* Set up stack frame and save callee-save registers */ + stp x29, x30, [sp, -160]! + CFI_ADJUST(160) + add x29, sp, #0 + stp x19, x20, [sp, 16] + stp x21, x22, [sp, 32] + stp x23, x24, [sp, 48] + stp x25, x26, [sp, 64] + stp x27, x28, [sp, 80] + stp d8, d9, [sp, 96] + stp d10, d11, [sp, 112] + stp d12, d13, [sp, 128] + stp d14, d15, [sp, 144] + /* Setup a callback link on the stack */ + LOADGLOBAL(x8, caml_bottom_of_stack) + LOADGLOBAL(x9, caml_last_return_address) + LOADGLOBAL(x10, caml_gc_regs) + stp x8, x9, [sp, -32]! /* 16-byte alignment */ + CFI_ADJUST(32) + str x10, [sp, 16] + /* Setup a trap frame to catch exceptions escaping the OCaml code */ + LOADGLOBAL(x8, caml_exception_pointer) + adr x9, .Ltrap_handler + stp x8, x9, [sp, -16]! + CFI_ADJUST(16) + add TRAP_PTR, sp, #0 + /* Reload allocation pointers */ + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) + /* Call the OCaml code */ + blr ARG +.Lcaml_retaddr: + /* Pop the trap frame, restoring caml_exception_pointer */ + ldr x8, [sp], 16 + CFI_ADJUST(-16) + STOREGLOBAL(x8, caml_exception_pointer) + /* Pop the callback link, restoring the global variables */ +.Lreturn_result: + ldr x10, [sp, 16] + ldp x8, x9, [sp], 32 + CFI_ADJUST(-32) + STOREGLOBAL(x8, caml_bottom_of_stack) + STOREGLOBAL(x9, caml_last_return_address) + STOREGLOBAL(x10, caml_gc_regs) + /* Update allocation pointer */ + STOREGLOBAL(ALLOC_PTR, caml_young_ptr) + /* Reload callee-save registers and return address */ + ldp x19, x20, [sp, 16] + ldp x21, x22, [sp, 32] + ldp x23, x24, [sp, 48] + ldp x25, x26, [sp, 64] + ldp x27, x28, [sp, 80] + ldp d8, d9, [sp, 96] + ldp d10, d11, [sp, 112] + ldp d12, d13, [sp, 128] + ldp d14, d15, [sp, 144] + ldp x29, x30, [sp], 160 + CFI_ADJUST(-160) + /* Return to C caller */ + ret + CFI_ENDPROC + .type .Lcaml_retaddr, %function + .size .Lcaml_retaddr, .-.Lcaml_retaddr + .type caml_start_program, %function + .size caml_start_program, .-caml_start_program + +/* The trap handler */ + + .align 2 +.Ltrap_handler: + CFI_STARTPROC + /* Save exception pointer */ + STOREGLOBAL(TRAP_PTR, caml_exception_pointer) + /* Encode exception bucket as an exception result */ + orr x0, x0, #2 + /* Return it */ + b .Lreturn_result + CFI_ENDPROC + .type .Ltrap_handler, %function + .size .Ltrap_handler, .-.Ltrap_handler + +/* Raise an exception from OCaml */ + + .align 2 + .globl caml_raise_exn +caml_raise_exn: + CFI_STARTPROC + PROFILE + /* Test if backtrace is active */ + LOADGLOBAL(TMP, caml_backtrace_active) + cbnz TMP, 2f +1: /* Cut stack at current trap handler */ + mov sp, TRAP_PTR + /* Pop previous handler and jump to it */ + ldr TMP, [sp, 8] + ldr TRAP_PTR, [sp], 16 + br TMP +2: /* Preserve exception bucket in callee-save register x19 */ + mov x19, x0 + /* Stash the backtrace */ + /* arg1: exn bucket, already in x0 */ + mov x1, x30 /* arg2: pc of raise */ + add x2, sp, #0 /* arg3: sp of raise */ + mov x3, TRAP_PTR /* arg4: sp of handler */ + bl caml_stash_backtrace + /* Restore exception bucket and raise */ + mov x0, x19 + b 1b + CFI_ENDPROC + .type caml_raise_exn, %function + .size caml_raise_exn, .-caml_raise_exn + +/* Raise an exception from C */ + + .align 2 + .globl caml_raise_exception +caml_raise_exception: + CFI_STARTPROC + PROFILE + /* Reload trap ptr, alloc ptr and alloc limit */ + LOADGLOBAL(TRAP_PTR, caml_exception_pointer) + LOADGLOBAL(ALLOC_PTR, caml_young_ptr) + LOADGLOBAL(ALLOC_LIMIT, caml_young_limit) + /* Test if backtrace is active */ + LOADGLOBAL(TMP, caml_backtrace_active) + cbnz TMP, 2f +1: /* Cut stack at current trap handler */ + mov sp, TRAP_PTR + /* Pop previous handler and jump to it */ + ldr TMP, [sp, 8] + ldr TRAP_PTR, [sp], 16 + br TMP +2: /* Preserve exception bucket in callee-save register x19 */ + mov x19, x0 + /* Stash the backtrace */ + /* arg1: exn bucket, already in x0 */ + LOADGLOBAL(x1, caml_last_return_address) /* arg2: pc of raise */ + LOADGLOBAL(x2, caml_bottom_of_stack) /* arg3: sp of raise */ + mov x3, TRAP_PTR /* arg4: sp of handler */ + bl caml_stash_backtrace + /* Restore exception bucket and raise */ + mov x0, x19 + b 1b + CFI_ENDPROC + .type caml_raise_exception, %function + .size caml_raise_exception, .-caml_raise_exception + +/* Callback from C to OCaml */ + + .align 2 + .globl caml_callback_exn +caml_callback_exn: + CFI_STARTPROC + PROFILE + /* Initial shuffling of arguments (x0 = closure, x1 = first arg) */ + mov TMP, x0 + mov x0, x1 /* x0 = first arg */ + mov x1, TMP /* x1 = closure environment */ + ldr ARG, [TMP] /* code pointer */ + b .Ljump_to_caml + CFI_ENDPROC + .type caml_callback_exn, %function + .size caml_callback_exn, .-caml_callback_exn + + .align 2 + .globl caml_callback2_exn +caml_callback2_exn: + CFI_STARTPROC + PROFILE + /* Initial shuffling of arguments (x0 = closure, x1 = arg1, x2 = arg2) */ + mov TMP, x0 + mov x0, x1 /* x0 = first arg */ + mov x1, x2 /* x1 = second arg */ + mov x2, TMP /* x2 = closure environment */ + ADDRGLOBAL(ARG, caml_apply2) + b .Ljump_to_caml + CFI_ENDPROC + .type caml_callback2_exn, %function + .size caml_callback2_exn, .-caml_callback2_exn + + .align 2 + .globl caml_callback3_exn +caml_callback3_exn: + CFI_STARTPROC + PROFILE + /* Initial shuffling of arguments */ + /* (x0 = closure, x1 = arg1, x2 = arg2, x3 = arg3) */ + mov TMP, x0 + mov x0, x1 /* x0 = first arg */ + mov x1, x2 /* x1 = second arg */ + mov x2, x3 /* x2 = third arg */ + mov x3, TMP /* x3 = closure environment */ + ADDRGLOBAL(ARG, caml_apply3) + b .Ljump_to_caml + CFI_ENDPROC + .type caml_callback3_exn, %function + .size caml_callback3_exn, .-caml_callback3_exn + + .align 2 + .globl caml_ml_array_bound_error +caml_ml_array_bound_error: + CFI_STARTPROC + PROFILE + /* Load address of [caml_array_bound_error] in ARG */ + ADDRGLOBAL(ARG, caml_array_bound_error) + /* Call that function */ + b caml_c_call + CFI_ENDPROC + .type caml_ml_array_bound_error, %function + .size caml_ml_array_bound_error, .-caml_ml_array_bound_error + + .globl caml_system__code_end +caml_system__code_end: + +/* GC roots for callback */ + + .data + .align 3 + .globl caml_system__frametable +caml_system__frametable: + .quad 1 /* one descriptor */ + .quad .Lcaml_retaddr /* return address into callback */ + .short -1 /* negative frame size => use callback link */ + .short 0 /* no roots */ + .align 3 + .type caml_system__frametable, %object + .size caml_system__frametable, .-caml_system__frametable diff -Nru ocaml-4.01.0/asmrun/arm.S ocaml-4.02.3/asmrun/arm.S --- ocaml-4.01.0/asmrun/arm.S 2013-01-13 18:20:36.000000000 +0100 +++ ocaml-4.02.3/asmrun/arm.S 2014-08-21 12:06:19.000000000 +0200 @@ -44,6 +44,15 @@ cmp \reg, #0 beq \lbl .endm +#elif defined(SYS_freebsd) + .arch armv6 + .arm + + /* Compatibility macros */ + .macro cbz reg, lbl + cmp \reg, #0 + beq \lbl + .endm #endif trap_ptr .req r8 diff -Nru ocaml-4.01.0/asmrun/backtrace.c ocaml-4.02.3/asmrun/backtrace.c --- ocaml-4.01.0/asmrun/backtrace.c 2013-07-23 16:48:47.000000000 +0200 +++ ocaml-4.02.3/asmrun/backtrace.c 2015-04-12 11:03:39.000000000 +0200 @@ -17,11 +17,11 @@ #include #include -#include "alloc.h" -#include "backtrace.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/alloc.h" +#include "caml/backtrace.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" #include "stack.h" int caml_backtrace_active = 0; @@ -30,6 +30,17 @@ value caml_backtrace_last_exn = Val_unit; #define BACKTRACE_BUFFER_SIZE 1024 +/* In order to prevent the GC from walking through the debug information + (which have no headers), we transform frame_descr pointers into + 31/63 bits ocaml integers by shifting them by 1 to the right. We do + not lose information as descr pointers are aligned. + + In particular, we do not need to use [caml_initialize] when setting + an array element with such a value. +*/ +#define Val_Descrptr(descr) Val_long((uintnat)descr>>1) +#define Descrptr_Val(v) ((frame_descr *) (Long_val(v)<<1)) + /* Start or stop the backtrace machinery */ CAMLprim value caml_record_backtrace(value vflag) @@ -112,6 +123,7 @@ caml_backtrace_last_exn = exn; } if (caml_backtrace_buffer == NULL) { + Assert(caml_backtrace_pos == 0); caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); if (caml_backtrace_buffer == NULL) return; } @@ -172,7 +184,7 @@ } } - trace = caml_alloc((mlsize_t) trace_size, Abstract_tag); + trace = caml_alloc((mlsize_t) trace_size, 0); /* then collect the trace */ { @@ -183,11 +195,7 @@ for (trace_pos = 0; trace_pos < trace_size; trace_pos++) { frame_descr * descr = caml_next_frame_descriptor(&pc, &sp); Assert(descr != NULL); - /* The assignment below is safe without [caml_initialize], even - if the trace is large and allocated on the old heap, because - we assign values that are outside the OCaml heap. */ - Assert(!(Is_block((value) descr) && Is_in_heap((value) descr))); - Field(trace, trace_pos) = (value) descr; + Field(trace, trace_pos) = Val_Descrptr(descr); } } @@ -196,17 +204,8 @@ /* Extract location information for the given frame descriptor */ -struct loc_info { - int loc_valid; - int loc_is_raise; - char * loc_filename; - int loc_lnum; - int loc_startchr; - int loc_endchr; -}; - -static void extract_location_info(frame_descr * d, - /*out*/ struct loc_info * li) +CAMLexport void extract_location_info(frame_descr * d, + /*out*/ struct caml_loc_info * li) { uintnat infoptr; uint32 info1, info2; @@ -252,7 +251,7 @@ useless. We kept it to keep code identical to the byterun/ implementation. */ -static void print_location(struct loc_info * li, int index) +static void print_location(struct caml_loc_info * li, int index) { char * info; @@ -285,7 +284,7 @@ void caml_print_exception_backtrace(void) { int i; - struct loc_info li; + struct caml_loc_info li; for (i = 0; i < caml_backtrace_pos; i++) { extract_location_info((frame_descr *) (caml_backtrace_buffer[i]), &li); @@ -295,31 +294,27 @@ /* Convert the raw backtrace to a data structure usable from OCaml */ -CAMLprim value caml_convert_raw_backtrace(value backtrace) { - CAMLparam1(backtrace); - CAMLlocal4(res, arr, p, fname); - int i; - struct loc_info li; - - arr = caml_alloc(Wosize_val(backtrace), 0); - for (i = 0; i < Wosize_val(backtrace); i++) { - extract_location_info((frame_descr *) Field(backtrace, i), &li); - if (li.loc_valid) { - fname = caml_copy_string(li.loc_filename); - p = caml_alloc_small(5, 0); - Field(p, 0) = Val_bool(li.loc_is_raise); - Field(p, 1) = fname; - Field(p, 2) = Val_int(li.loc_lnum); - Field(p, 3) = Val_int(li.loc_startchr); - Field(p, 4) = Val_int(li.loc_endchr); - } else { - p = caml_alloc_small(1, 1); - Field(p, 0) = Val_bool(li.loc_is_raise); - } - caml_modify(&Field(arr, i), p); +CAMLprim value caml_convert_raw_backtrace_slot(value backtrace_slot) { + CAMLparam1(backtrace_slot); + CAMLlocal2(p, fname); + struct caml_loc_info li; + + extract_location_info(Descrptr_Val(backtrace_slot), &li); + + if (li.loc_valid) { + fname = caml_copy_string(li.loc_filename); + p = caml_alloc_small(5, 0); + Field(p, 0) = Val_bool(li.loc_is_raise); + Field(p, 1) = fname; + Field(p, 2) = Val_int(li.loc_lnum); + Field(p, 3) = Val_int(li.loc_startchr); + Field(p, 4) = Val_int(li.loc_endchr); + } else { + p = caml_alloc_small(1, 1); + Field(p, 0) = Val_bool(li.loc_is_raise); } - res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ - CAMLreturn(res); + + CAMLreturn(p); } /* Get a copy of the latest backtrace */ @@ -328,10 +323,37 @@ { CAMLparam0(); CAMLlocal1(res); - res = caml_alloc(caml_backtrace_pos, Abstract_tag); - if(caml_backtrace_buffer != NULL) - memcpy(&Field(res, 0), caml_backtrace_buffer, - caml_backtrace_pos * sizeof(code_t)); + const int tag = 0; + + /* Beware: the allocations below may cause finalizers to be run, and another + backtrace---possibly of a different length---to be stashed (for example + if the finalizer raises then catches an exception). We choose to ignore + any such finalizer backtraces and return the original one. */ + + if (caml_backtrace_buffer == NULL || caml_backtrace_pos == 0) { + res = caml_alloc(0, tag); + } + else { + code_t saved_caml_backtrace_buffer[BACKTRACE_BUFFER_SIZE]; + int saved_caml_backtrace_pos; + intnat i; + + saved_caml_backtrace_pos = caml_backtrace_pos; + + if (saved_caml_backtrace_pos > BACKTRACE_BUFFER_SIZE) { + saved_caml_backtrace_pos = BACKTRACE_BUFFER_SIZE; + } + + memcpy(saved_caml_backtrace_buffer, caml_backtrace_buffer, + saved_caml_backtrace_pos * sizeof(code_t)); + + res = caml_alloc(saved_caml_backtrace_pos, tag); + for (i = 0; i < saved_caml_backtrace_pos; i++) { + /* [Val_Descrptr] always returns an immediate. */ + Field(res, i) = Val_Descrptr(saved_caml_backtrace_buffer[i]); + } + } + CAMLreturn(res); } @@ -348,8 +370,16 @@ CAMLprim value caml_get_exception_backtrace(value unit) { CAMLparam0(); - CAMLlocal2(raw,res); - raw = caml_get_exception_raw_backtrace(unit); - res = caml_convert_raw_backtrace(raw); + CAMLlocal3(arr, res, backtrace); + intnat i; + + backtrace = caml_get_exception_raw_backtrace(Val_unit); + + arr = caml_alloc(Wosize_val(backtrace), 0); + for (i = 0; i < Wosize_val(backtrace); i++) { + Store_field(arr, i, caml_convert_raw_backtrace_slot(Field(backtrace, i))); + } + + res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ CAMLreturn(res); } diff -Nru ocaml-4.01.0/asmrun/.depend ocaml-4.02.3/asmrun/.depend --- ocaml-4.01.0/asmrun/.depend 2013-08-15 18:13:16.000000000 +0200 +++ ocaml-4.02.3/asmrun/.depend 2015-07-23 17:14:03.000000000 +0200 @@ -1,753 +1,1089 @@ -alloc.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h -array.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h -backtrace.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h -callback.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h -compact.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h -compare.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h -custom.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h -debugger.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ - ../byterun/misc.h -dynlink.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/osdeps.h \ - ../byterun/prims.h -extern.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h -fail.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ - ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h -finalise.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/signals.h -floats.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h -freelist.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h -gc_ctrl.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h stack.h -globroots.o: globroots.c ../byterun/memory.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/globroots.h ../byterun/roots.h -hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h -intern.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h -ints.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h -io.o: io.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ - ../byterun/sys.h -lexing.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h -main.o: main.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/sys.h -major_gc.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h -md5.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ - ../byterun/reverse.h -memory.o: memory.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/signals.h -meta.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ - ../byterun/interp.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h ../byterun/stacks.h ../byterun/memory.h -minor_gc.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ - ../byterun/weak.h -misc.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -natdynlink.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \ - ../byterun/fail.h -obj.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h -parsing.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h -printexc.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/printexc.h -roots.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h stack.h ../byterun/roots.h -signals.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ - ../byterun/sys.h -signals_asm.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ +alloc.o: alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +array.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +backtrace.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/backtrace.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h stack.h +callback.o: callback.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/mlvalues.h +compact.o: compact.c ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/memory.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/weak.h +compare.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +custom.o: custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h +debugger.o: debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/debugger.h \ + ../byterun/caml/misc.h +dynlink.o: dynlink.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.h \ + ../byterun/caml/fail.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/osdeps.h ../byterun/caml/prims.h \ + ../byterun/caml/signals.h +extern.o: extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/io.h \ + ../byterun/caml/md5.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/reverse.h +fail.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/gc.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/printexc.h \ + ../byterun/caml/signals.h stack.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/callback.h +finalise.o: finalise.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/signals.h +floats.o: floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/reverse.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +freelist.o: freelist.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/freelist.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/gc.h ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/major_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +gc_ctrl.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/compact.h ../byterun/caml/custom.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h stack.h +globroots.o: globroots.c ../byterun/caml/memory.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h \ + ../byterun/caml/globroots.h ../byterun/caml/roots.h +hash.o: hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/custom.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/hash.h +intern.o: intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/io.h ../byterun/caml/md5.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/reverse.h +ints.o: ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h +io.o: io.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/signals.h \ + ../byterun/caml/sys.h +lexing.o: lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +main.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h ../byterun/caml/sys.h +major_gc.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/custom.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/weak.h +md5.o: md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/md5.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/io.h \ + ../byterun/caml/reverse.h +memory.o: memory.c ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/signals.h +meta.o: meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/fail.h \ + ../byterun/caml/fix_code.h ../byterun/caml/interp.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/prims.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +minor_gc.o: minor_gc.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/fail.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc.h ../byterun/caml/gc_ctrl.h \ + ../byterun/caml/major_gc.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/weak.h +misc.o: misc.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +natdynlink.o: natdynlink.c ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/misc.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h stack.h ../byterun/caml/callback.h \ + ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/osdeps.h ../byterun/caml/fail.h \ + ../byterun/caml/signals.h +obj.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/prims.h +parsing.o: parsing.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/misc.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/alloc.h +printexc.o: printexc.c ../byterun/caml/backtrace.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/callback.h \ + ../byterun/caml/debugger.h ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/printexc.h +roots.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/globroots.h \ + ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h stack.h ../byterun/caml/roots.h +signals.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/config.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h \ + ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \ + ../byterun/caml/sys.h +signals_asm.o: signals_asm.c ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \ signals_osdep.h stack.h -startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ - ../byterun/printexc.h stack.h ../byterun/sys.h -str.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/int64_native.h -sys.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h -terminfo.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/mlvalues.h -unix.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/osdeps.h -weak.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h -alloc.d.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h -array.d.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h -backtrace.d.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h -callback.d.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h -compact.d.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h -compare.d.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h -custom.d.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h -debugger.d.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ - ../byterun/misc.h -dynlink.d.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/osdeps.h \ - ../byterun/prims.h -extern.d.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h -fail.d.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ - ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h -finalise.d.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/signals.h -floats.d.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h -freelist.d.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h -gc_ctrl.d.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h stack.h -globroots.d.o: globroots.c ../byterun/memory.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/globroots.h ../byterun/roots.h -hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h -intern.d.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h -ints.d.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h -io.d.o: io.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ - ../byterun/sys.h -lexing.d.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h -main.d.o: main.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/sys.h -major_gc.d.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h -md5.d.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ - ../byterun/reverse.h -memory.d.o: memory.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/signals.h -meta.d.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ - ../byterun/interp.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h ../byterun/stacks.h ../byterun/memory.h -minor_gc.d.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ - ../byterun/weak.h -misc.d.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -natdynlink.d.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \ - ../byterun/fail.h -obj.d.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h -parsing.d.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h -printexc.d.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/printexc.h -roots.d.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h stack.h ../byterun/roots.h -signals.d.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ - ../byterun/sys.h -signals_asm.d.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ +startup.o: startup.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/backtrace.h \ + ../byterun/caml/custom.h ../byterun/caml/debugger.h \ + ../byterun/caml/fail.h ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/osdeps.h ../byterun/caml/printexc.h stack.h \ + ../byterun/caml/sys.h +str.o: str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/misc.h +sys.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/debugger.h \ + ../byterun/caml/fail.h ../byterun/caml/instruct.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/sys.h +terminfo.o: terminfo.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h \ + ../byterun/caml/mlvalues.h +unix.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/memory.h \ + ../byterun/caml/config.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/osdeps.h +weak.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h +alloc.d.o: alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +array.d.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +backtrace.d.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/backtrace.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h stack.h +callback.d.o: callback.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/mlvalues.h +compact.d.o: compact.c ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/memory.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/weak.h +compare.d.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +custom.d.o: custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h +debugger.d.o: debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/debugger.h \ + ../byterun/caml/misc.h +dynlink.d.o: dynlink.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.h \ + ../byterun/caml/fail.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/osdeps.h ../byterun/caml/prims.h \ + ../byterun/caml/signals.h +extern.d.o: extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/io.h \ + ../byterun/caml/md5.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/reverse.h +fail.d.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/gc.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/printexc.h \ + ../byterun/caml/signals.h stack.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/callback.h +finalise.d.o: finalise.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/signals.h +floats.d.o: floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/reverse.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +freelist.d.o: freelist.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/freelist.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/gc.h ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/major_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +gc_ctrl.d.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/compact.h ../byterun/caml/custom.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h stack.h +globroots.d.o: globroots.c ../byterun/caml/memory.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h \ + ../byterun/caml/globroots.h ../byterun/caml/roots.h +hash.d.o: hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/custom.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/hash.h +intern.d.o: intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/io.h ../byterun/caml/md5.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/reverse.h +ints.d.o: ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h +io.d.o: io.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/signals.h \ + ../byterun/caml/sys.h +lexing.d.o: lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +main.d.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h ../byterun/caml/sys.h +major_gc.d.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/custom.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/weak.h +md5.d.o: md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/md5.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/io.h \ + ../byterun/caml/reverse.h +memory.d.o: memory.c ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/signals.h +meta.d.o: meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/fail.h \ + ../byterun/caml/fix_code.h ../byterun/caml/interp.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/prims.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +minor_gc.d.o: minor_gc.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/fail.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc.h ../byterun/caml/gc_ctrl.h \ + ../byterun/caml/major_gc.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/weak.h +misc.d.o: misc.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +natdynlink.d.o: natdynlink.c ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/misc.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h stack.h ../byterun/caml/callback.h \ + ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/osdeps.h ../byterun/caml/fail.h \ + ../byterun/caml/signals.h +obj.d.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/prims.h +parsing.d.o: parsing.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/misc.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/alloc.h +printexc.d.o: printexc.c ../byterun/caml/backtrace.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/callback.h \ + ../byterun/caml/debugger.h ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/printexc.h +roots.d.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/globroots.h \ + ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h stack.h ../byterun/caml/roots.h +signals.d.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/config.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h \ + ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \ + ../byterun/caml/sys.h +signals_asm.d.o: signals_asm.c ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \ signals_osdep.h stack.h -startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ - ../byterun/printexc.h stack.h ../byterun/sys.h -str.d.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/int64_native.h -sys.d.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h -terminfo.d.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/mlvalues.h -unix.d.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/osdeps.h -weak.d.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h -alloc.p.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h -array.p.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h -backtrace.p.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/backtrace.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h -callback.p.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h -compact.p.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h -compare.p.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h -custom.p.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h -debugger.p.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ - ../byterun/misc.h -dynlink.p.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/osdeps.h \ - ../byterun/prims.h -extern.p.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h -fail.p.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/printexc.h \ - ../byterun/signals.h stack.h ../byterun/roots.h ../byterun/memory.h -finalise.p.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/fail.h ../byterun/mlvalues.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/signals.h -floats.p.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/reverse.h ../byterun/stacks.h ../byterun/memory.h -freelist.p.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/major_gc.h ../byterun/misc.h ../byterun/mlvalues.h -gc_ctrl.p.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/compact.h ../byterun/custom.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h stack.h -globroots.p.o: globroots.c ../byterun/memory.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/globroots.h ../byterun/roots.h -hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h -intern.p.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h -ints.p.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h -io.p.o: io.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ - ../byterun/sys.h -lexing.p.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/mlvalues.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h -main.p.o: main.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/sys.h -major_gc.p.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/weak.h -md5.p.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/md5.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h ../byterun/io.h \ - ../byterun/reverse.h -memory.p.o: memory.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/signals.h -meta.p.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/fail.h ../byterun/fix_code.h \ - ../byterun/interp.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h ../byterun/stacks.h ../byterun/memory.h -minor_gc.p.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h \ - ../byterun/memory.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/roots.h ../byterun/signals.h \ - ../byterun/weak.h -misc.p.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -natdynlink.p.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/osdeps.h \ - ../byterun/fail.h -obj.p.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/prims.h -parsing.p.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h -printexc.p.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/callback.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/printexc.h -roots.p.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h stack.h ../byterun/roots.h -signals.p.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/callback.h ../byterun/config.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ - ../byterun/memory.h ../byterun/signals.h ../byterun/signals_machdep.h \ - ../byterun/sys.h -signals_asm.p.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/signals_machdep.h \ +startup.d.o: startup.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/backtrace.h \ + ../byterun/caml/custom.h ../byterun/caml/debugger.h \ + ../byterun/caml/fail.h ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/osdeps.h ../byterun/caml/printexc.h stack.h \ + ../byterun/caml/sys.h +str.d.o: str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/misc.h +sys.d.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/debugger.h \ + ../byterun/caml/fail.h ../byterun/caml/instruct.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/sys.h +terminfo.d.o: terminfo.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h \ + ../byterun/caml/mlvalues.h +unix.d.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/memory.h \ + ../byterun/caml/config.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/osdeps.h +weak.d.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h +alloc.p.o: alloc.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +array.p.o: array.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +backtrace.p.o: backtrace.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/backtrace.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h stack.h +callback.p.o: callback.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/mlvalues.h +compact.p.o: compact.c ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/memory.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/weak.h +compare.p.o: compare.c ../byterun/caml/custom.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +custom.p.o: custom.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h +debugger.p.o: debugger.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/debugger.h \ + ../byterun/caml/misc.h +dynlink.p.o: dynlink.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/dynlink.h \ + ../byterun/caml/fail.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/osdeps.h ../byterun/caml/prims.h \ + ../byterun/caml/signals.h +extern.p.o: extern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h ../byterun/caml/gc.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/io.h \ + ../byterun/caml/md5.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/reverse.h +fail.p.o: fail.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/gc.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/printexc.h \ + ../byterun/caml/signals.h stack.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/callback.h +finalise.p.o: finalise.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/fail.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/signals.h +floats.p.o: floats.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/reverse.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +freelist.p.o: freelist.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/freelist.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/gc.h ../byterun/caml/gc_ctrl.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/major_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h +gc_ctrl.p.o: gc_ctrl.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/compact.h ../byterun/caml/custom.h \ + ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h stack.h +globroots.p.o: globroots.c ../byterun/caml/memory.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h \ + ../byterun/caml/globroots.h ../byterun/caml/roots.h +hash.p.o: hash.c ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/custom.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/hash.h +intern.p.o: intern.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/intext.h \ + ../byterun/caml/io.h ../byterun/caml/io.h ../byterun/caml/md5.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/reverse.h +ints.p.o: ints.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/custom.h ../byterun/caml/fail.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h +io.p.o: io.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/custom.h \ + ../byterun/caml/fail.h ../byterun/caml/io.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/signals.h \ + ../byterun/caml/sys.h +lexing.p.o: lexing.c ../byterun/caml/fail.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +main.p.o: main.c ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h ../byterun/caml/sys.h +major_gc.p.o: major_gc.c ../byterun/caml/compact.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/custom.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/fail.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/weak.h +md5.p.o: md5.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/md5.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/io.h \ + ../byterun/caml/reverse.h +memory.p.o: memory.c ../byterun/caml/address_class.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/signals.h +meta.p.o: meta.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/config.h ../byterun/caml/fail.h \ + ../byterun/caml/fix_code.h ../byterun/caml/interp.h \ + ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/prims.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h +minor_gc.p.o: minor_gc.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/fail.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/finalise.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/gc.h ../byterun/caml/gc_ctrl.h \ + ../byterun/caml/major_gc.h ../byterun/caml/memory.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/roots.h \ + ../byterun/caml/signals.h ../byterun/caml/weak.h +misc.p.o: misc.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h +natdynlink.p.o: natdynlink.c ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/misc.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h stack.h ../byterun/caml/callback.h \ + ../byterun/caml/alloc.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/osdeps.h ../byterun/caml/fail.h \ + ../byterun/caml/signals.h +obj.p.o: obj.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/gc.h ../byterun/caml/interp.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/prims.h +parsing.p.o: parsing.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/misc.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/alloc.h +printexc.p.o: printexc.c ../byterun/caml/backtrace.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/callback.h \ + ../byterun/caml/debugger.h ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/printexc.h +roots.p.o: roots.c ../byterun/caml/finalise.h ../byterun/caml/roots.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/globroots.h \ + ../byterun/caml/memory.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/misc.h \ + ../byterun/caml/mlvalues.h stack.h ../byterun/caml/roots.h +signals.p.o: signals.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/callback.h ../byterun/caml/config.h \ + ../byterun/caml/fail.h ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/roots.h ../byterun/caml/memory.h \ + ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \ + ../byterun/caml/sys.h +signals_asm.p.o: signals_asm.c ../byterun/caml/fail.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/minor_gc.h \ + ../byterun/caml/address_class.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/signals_machdep.h \ signals_osdep.h stack.h -startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ - ../byterun/printexc.h stack.h ../byterun/sys.h -str.p.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/int64_native.h -sys.p.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ - ../byterun/fail.h ../byterun/instruct.h ../byterun/mlvalues.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h -terminfo.p.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/mlvalues.h -unix.p.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ - ../byterun/gc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/osdeps.h -weak.p.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/minor_gc.h ../byterun/mlvalues.h +startup.p.o: startup.c ../byterun/caml/callback.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/misc.h ../byterun/caml/backtrace.h \ + ../byterun/caml/custom.h ../byterun/caml/debugger.h \ + ../byterun/caml/fail.h ../byterun/caml/freelist.h ../byterun/caml/gc.h \ + ../byterun/caml/gc_ctrl.h ../byterun/caml/intext.h ../byterun/caml/io.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/osdeps.h ../byterun/caml/printexc.h stack.h \ + ../byterun/caml/sys.h +str.p.o: str.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/misc.h +sys.p.o: sys.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/alloc.h \ + ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/debugger.h \ + ../byterun/caml/fail.h ../byterun/caml/instruct.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/osdeps.h \ + ../byterun/caml/signals.h ../byterun/caml/stacks.h \ + ../byterun/caml/memory.h ../byterun/caml/gc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/sys.h +terminfo.p.o: terminfo.c ../byterun/caml/config.h \ + ../byterun/caml/../../config/m.h ../byterun/caml/../../config/s.h \ + ../byterun/caml/alloc.h ../byterun/caml/misc.h ../byterun/caml/config.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/fail.h ../byterun/caml/io.h \ + ../byterun/caml/mlvalues.h +unix.p.o: unix.c ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/memory.h \ + ../byterun/caml/config.h ../byterun/caml/gc.h \ + ../byterun/caml/mlvalues.h ../byterun/caml/misc.h \ + ../byterun/caml/major_gc.h ../byterun/caml/freelist.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/misc.h ../byterun/caml/osdeps.h +weak.p.o: weak.c ../byterun/caml/alloc.h ../byterun/caml/misc.h \ + ../byterun/caml/config.h ../byterun/caml/../../config/m.h \ + ../byterun/caml/../../config/s.h ../byterun/caml/mlvalues.h \ + ../byterun/caml/fail.h ../byterun/caml/major_gc.h \ + ../byterun/caml/freelist.h ../byterun/caml/memory.h \ + ../byterun/caml/gc.h ../byterun/caml/major_gc.h \ + ../byterun/caml/minor_gc.h ../byterun/caml/address_class.h \ + ../byterun/caml/mlvalues.h diff -Nru ocaml-4.01.0/asmrun/fail.c ocaml-4.02.3/asmrun/fail.c --- ocaml-4.01.0/asmrun/fail.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmrun/fail.c 2015-04-12 11:03:39.000000000 +0200 @@ -13,17 +13,19 @@ /* Raising exceptions from C. */ +#include #include -#include "alloc.h" -#include "fail.h" -#include "io.h" -#include "gc.h" -#include "memory.h" -#include "mlvalues.h" -#include "printexc.h" -#include "signals.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/io.h" +#include "caml/gc.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/printexc.h" +#include "caml/signals.h" #include "stack.h" -#include "roots.h" +#include "caml/roots.h" +#include "caml/callback.h" /* The globals holding predefined exceptions */ @@ -42,9 +44,6 @@ caml_exn_Stack_overflow, caml_exn_Assert_failure, caml_exn_Undefined_recursive_module; -extern caml_generated_constant - caml_bucket_Out_of_memory, - caml_bucket_Stack_overflow; /* Exception raising */ @@ -73,13 +72,7 @@ void caml_raise_constant(value tag) { - CAMLparam1 (tag); - CAMLlocal1 (bucket); - - bucket = caml_alloc_small (1, 0); - Field(bucket, 0) = tag; - caml_raise(bucket); - CAMLnoreturn; + caml_raise(tag); } void caml_raise_with_arg(value tag, value arg) @@ -111,7 +104,10 @@ void caml_raise_with_string(value tag, char const *msg) { - caml_raise_with_arg(tag, caml_copy_string(msg)); + CAMLparam1(tag); + value v_msg = caml_copy_string(msg); + caml_raise_with_arg(tag, v_msg); + CAMLnoreturn; } void caml_failwith (char const *msg) @@ -124,22 +120,14 @@ caml_raise_with_string((value) caml_exn_Invalid_argument, msg); } -/* To raise [Out_of_memory], we can't use [caml_raise_constant], - because it allocates and we're out of memory... - We therefore use a statically-allocated bucket constructed - by the ocamlopt linker. - This works OK because the exception value for [Out_of_memory] is also - statically allocated out of the heap. - The same applies to Stack_overflow. */ - void caml_raise_out_of_memory(void) { - caml_raise((value) &caml_bucket_Out_of_memory); + caml_raise_constant((value) caml_exn_Out_of_memory); } void caml_raise_stack_overflow(void) { - caml_raise((value) &caml_bucket_Stack_overflow); + caml_raise_constant((value) caml_exn_Stack_overflow); } void caml_raise_sys_error(value msg) @@ -167,43 +155,24 @@ caml_raise_constant((value) caml_exn_Sys_blocked_io); } -/* We allocate statically the bucket for the exception because we can't +/* We use a pre-allocated exception because we can't do a GC before the exception is raised (lack of stack descriptors - for the ccall to [caml_array_bound_error]. */ - -#define BOUND_MSG "index out of bounds" -#define BOUND_MSG_LEN (sizeof(BOUND_MSG) - 1) - -static struct { - header_t hdr; - value exn; - value arg; -} array_bound_error_bucket; - -static struct { - header_t hdr; - char data[BOUND_MSG_LEN + sizeof(value)]; -} array_bound_error_msg = { 0, BOUND_MSG }; + for the ccall to [caml_array_bound_error]). */ -static int array_bound_error_bucket_inited = 0; +static value * caml_array_bound_error_exn = NULL; void caml_array_bound_error(void) { - if (! array_bound_error_bucket_inited) { - mlsize_t wosize = (BOUND_MSG_LEN + sizeof(value)) / sizeof(value); - mlsize_t offset_index = Bsize_wsize(wosize) - 1; - array_bound_error_msg.hdr = Make_header(wosize, String_tag, Caml_white); - array_bound_error_msg.data[offset_index] = offset_index - BOUND_MSG_LEN; - array_bound_error_bucket.hdr = Make_header(2, 0, Caml_white); - array_bound_error_bucket.exn = (value) caml_exn_Invalid_argument; - array_bound_error_bucket.arg = (value) array_bound_error_msg.data; - array_bound_error_bucket_inited = 1; - caml_page_table_add(In_static_data, - &array_bound_error_msg, - &array_bound_error_msg + 1); - array_bound_error_bucket_inited = 1; + if (caml_array_bound_error_exn == NULL) { + caml_array_bound_error_exn = + caml_named_value("Pervasives.array_bound_error"); + if (caml_array_bound_error_exn == NULL) { + fprintf(stderr, "Fatal error: exception " + "Invalid_argument(\"index out of bounds\")\n"); + exit(2); + } } - caml_raise((value) &array_bound_error_bucket.exn); + caml_raise(*caml_array_bound_error_exn); } int caml_is_special_exception(value exn) { diff -Nru ocaml-4.01.0/asmrun/i386nt.asm ocaml-4.02.3/asmrun/i386nt.asm --- ocaml-4.01.0/asmrun/i386nt.asm 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmrun/i386nt.asm 2013-11-13 14:55:13.000000000 +0100 @@ -27,6 +27,7 @@ EXTERN _caml_last_return_address: DWORD EXTERN _caml_gc_regs: DWORD EXTERN _caml_exception_pointer: DWORD + EXTERN _caml_backtrace_pos: DWORD EXTERN _caml_backtrace_active: DWORD EXTERN _caml_stash_backtrace: PROC @@ -205,6 +206,8 @@ pop _caml_exception_pointer ret L110: + mov _caml_backtrace_pos, 0 +L111: mov esi, eax ; Save exception bucket in esi mov edi, _caml_exception_pointer ; SP of handler mov eax, [esp] ; PC of raise @@ -219,18 +222,27 @@ pop _caml_exception_pointer ret -; Raise an exception from C + PUBLIC _caml_reraise_exn + ALIGN 4 +_caml_reraise_exn: + test _caml_backtrace_active, 1 + jne L111 + mov esp, _caml_exception_pointer + pop _caml_exception_pointer + ret + + ; Raise an exception from C PUBLIC _caml_raise_exception ALIGN 4 _caml_raise_exception: test _caml_backtrace_active, 1 - jne L111 + jne L112 mov eax, [esp+4] mov esp, _caml_exception_pointer pop _caml_exception_pointer ret -L111: +L112: mov esi, [esp+4] ; Save exception bucket in esi push _caml_exception_pointer ; arg 4: SP of handler push _caml_bottom_of_stack ; arg 3: SP of raise diff -Nru ocaml-4.01.0/asmrun/i386.S ocaml-4.02.3/asmrun/i386.S --- ocaml-4.01.0/asmrun/i386.S 2013-03-22 19:21:34.000000000 +0100 +++ ocaml-4.02.3/asmrun/i386.S 2015-04-29 18:44:33.000000000 +0200 @@ -19,7 +19,7 @@ /* Linux/BSD with ELF binaries and Solaris do not prefix identifiers with _. Linux/BSD with a.out binaries and NextStep do. */ -#if defined(SYS_solaris) +#if (defined(SYS_solaris) && !defined(__GNUC__)) #define CONCAT(a,b) a/**/b #else #define CONCAT(a,b) a##b @@ -115,13 +115,10 @@ #define PROFILE_C #endif -#ifdef SYS_macosx +/* PR#6038: GCC and Clang seem to require 16-byte alignment nowadays, + even if only MacOS X's ABI formally requires it. */ #define ALIGN_STACK(amount) subl $ amount, %esp ; CFI_ADJUST(amount) #define UNDO_ALIGN_STACK(amount) addl $ amount, %esp ; CFI_ADJUST(-amount) -#else -#define ALIGN_STACK(amount) -#define UNDO_ALIGN_STACK(amount) -#endif /* Allocation */ @@ -304,11 +301,7 @@ LBL(107): /* Pop the exception handler */ popl G(caml_exception_pointer); CFI_ADJUST(-4) -#ifdef SYS_macosx addl $12, %esp ; CFI_ADJUST(-12) -#else - addl $4, %esp ; CFI_ADJUST(-4) -#endif LBL(109): /* Pop the callback link, restoring the global variables */ popl G(caml_bottom_of_stack); CFI_ADJUST(-4) @@ -339,6 +332,8 @@ UNDO_ALIGN_STACK(8) ret LBL(110): + movl $0, G(caml_backtrace_pos) +LBL(111): movl %eax, %esi /* Save exception bucket in esi */ movl G(caml_exception_pointer), %edi /* SP of handler */ movl 0(%esp), %eax /* PC of raise */ @@ -356,19 +351,29 @@ ret CFI_ENDPROC +FUNCTION(caml_reraise_exn) + CFI_STARTPROC + testl $1, G(caml_backtrace_active) + jne LBL(111) + movl G(caml_exception_pointer), %esp + popl G(caml_exception_pointer); CFI_ADJUST(-4) + UNDO_ALIGN_STACK(8) + ret + CFI_ENDPROC + /* Raise an exception from C */ FUNCTION(caml_raise_exception) CFI_STARTPROC PROFILE_C testl $1, G(caml_backtrace_active) - jne LBL(111) + jne LBL(112) movl 4(%esp), %eax movl G(caml_exception_pointer), %esp popl G(caml_exception_pointer); CFI_ADJUST(-4) UNDO_ALIGN_STACK(8) ret -LBL(111): +LBL(112): movl 4(%esp), %esi /* Save exception bucket in esi */ ALIGN_STACK(12) pushl G(caml_exception_pointer); CFI_ADJUST(4) /* 4: sp of handler */ @@ -449,10 +454,8 @@ 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 + /* Re-align the stack */ andl $-16, %esp -#endif /* Branch to [caml_array_bound_error] (never returns) */ call G(caml_array_bound_error) CFI_ENDPROC diff -Nru ocaml-4.01.0/asmrun/Makefile ocaml-4.02.3/asmrun/Makefile --- ocaml-4.01.0/asmrun/Makefile 2013-06-24 10:16:27.000000000 +0200 +++ ocaml-4.02.3/asmrun/Makefile 2015-05-19 11:48:34.000000000 +0200 @@ -16,28 +16,30 @@ CC=$(NATIVECC) FLAGS=-I../byterun -DCAML_NAME_SPACE -DNATIVE_CODE \ -DTARGET_$(ARCH) -DSYS_$(SYSTEM) $(IFLEXDIR) -CFLAGS=$(FLAGS) -O $(NATIVECCCOMPOPTS) +CFLAGS=$(FLAGS) $(NATIVECCCOMPOPTS) DFLAGS=$(FLAGS) -g -DDEBUG $(NATIVECCCOMPOPTS) PFLAGS=$(FLAGS) -pg -O -DPROFILING $(NATIVECCPROFOPTS) +PICFLAGS=$(FLAGS) -O $(SHAREDCCCOMPOPTS) $(NATIVECCCOMPOPTS) COBJS=startup.o main.o fail.o roots.o globroots.o signals.o signals_asm.o \ misc.o freelist.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.o \ floats.o str.o array.o io.o extern.o intern.o hash.o sys.o parsing.o \ gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \ - compact.o finalise.o custom.o unix.o backtrace.o natdynlink.o debugger.o \ - meta.o dynlink.o + compact.o finalise.o custom.o $(UNIX_OR_WIN32).o backtrace.o natdynlink.o\ + debugger.o meta.o dynlink.o ASMOBJS=$(ARCH).o OBJS=$(COBJS) $(ASMOBJS) DOBJS=$(COBJS:.o=.d.o) $(ASMOBJS) POBJS=$(COBJS:.o=.p.o) $(ASMOBJS:.o=.p.o) +PICOBJS=$(COBJS:.o=.pic.o) $(ASMOBJS:.o=.pic.o) -all: libasmrun.a all-$(RUNTIMED) all-$(PROFILING) +all: libasmrun.a all-$(RUNTIMED) all-$(PROFILING) all-$(SHARED) libasmrun.a: $(OBJS) rm -f libasmrun.a - ar rc libasmrun.a $(OBJS) + $(ARCMD) rc libasmrun.a $(OBJS) $(RANLIB) libasmrun.a all-noruntimed: @@ -48,7 +50,7 @@ libasmrund.a: $(DOBJS) rm -f libasmrund.a - ar rc libasmrund.a $(DOBJS) + $(ARCMD) rc libasmrund.a $(DOBJS) $(RANLIB) libasmrund.a all-noprof: @@ -57,29 +59,56 @@ libasmrunp.a: $(POBJS) rm -f libasmrunp.a - ar rc libasmrunp.a $(POBJS) + $(ARCMD) rc libasmrunp.a $(POBJS) $(RANLIB) libasmrunp.a -install: install-default install-$(RUNTIMED) install-$(PROFILING) +all-noshared: + +all-shared: libasmrun_pic.a libasmrun_shared.so + +libasmrun_pic.a: $(PICOBJS) + rm -f libasmrun_pic.a + ar rc libasmrun_pic.a $(PICOBJS) + $(RANLIB) libasmrun_pic.a + +libasmrun_shared.so: $(PICOBJS) + $(MKDLL) -o libasmrun_shared.so $(PICOBJS) $(NATIVECCLIBS) + +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + +install: install-default install-$(RUNTIMED) install-$(PROFILING) install-$(SHARED) install-default: - cp libasmrun.a $(LIBDIR)/libasmrun.a - cd $(LIBDIR); $(RANLIB) libasmrun.a + cp libasmrun.a $(INSTALL_LIBDIR)/libasmrun.a + cd $(INSTALL_LIBDIR); $(RANLIB) libasmrun.a +.PHONY: install-default install-noruntimed: .PHONY: install-noruntimed install-runtimed: - cp libasmrund.a $(LIBDIR)/libasmrund.a - cd $(LIBDIR); $(RANLIB) libasmrund.a + cp libasmrund.a $(INSTALL_LIBDIR)/libasmrund.a + cd $(INSTALL_LIBDIR); $(RANLIB) libasmrund.a .PHONY: install-runtimed install-noprof: - rm -f $(LIBDIR)/libasmrunp.a; ln -s libasmrun.a $(LIBDIR)/libasmrunp.a + rm -f $(INSTALL_LIBDIR)/libasmrunp.a + ln -s libasmrun.a $(INSTALL_LIBDIR)/libasmrunp.a +.PHONY: install-noprof install-prof: - cp libasmrunp.a $(LIBDIR)/libasmrunp.a - cd $(LIBDIR); $(RANLIB) libasmrunp.a + cp libasmrunp.a $(INSTALL_LIBDIR)/libasmrunp.a + cd $(INSTALL_LIBDIR); $(RANLIB) libasmrunp.a +.PHONY: install-prof + +install-noshared: +.PHONY: install-noshared + +install-shared: + cp libasmrun_pic.a $(INSTALL_LIBDIR)/libasmrun_pic.a + cd $(INSTALL_LIBDIR); $(RANLIB) libasmrunp.a + cp libasmrun_shared.so $(INSTALL_LIBDIR)/libasmrun_shared.so +.PHONY: install-prof power-bsd_elf.S: power-elf.S cp power-elf.S power-bsd_elf.S @@ -90,6 +119,9 @@ power.p.o: power-$(SYSTEM).o cp power-$(SYSTEM).o power.p.o +power.pic.o: power-$(SYSTEM).pic.o + cp power-$(SYSTEM).pic.o power.pic.o + main.c: ../byterun/main.c ln -s ../byterun/main.c main.c misc.c: ../byterun/misc.c @@ -152,8 +184,8 @@ ln -s ../byterun/meta.c meta.c globroots.c: ../byterun/globroots.c ln -s ../byterun/globroots.c globroots.c -unix.c: ../byterun/unix.c - ln -s ../byterun/unix.c unix.c +$(UNIX_OR_WIN32).c: ../byterun/$(UNIX_OR_WIN32).c + ln -s ../byterun/$(UNIX_OR_WIN32).c $(UNIX_OR_WIN32).c dynlink.c: ../byterun/dynlink.c ln -s ../byterun/dynlink.c dynlink.c signals.c: ../byterun/signals.c @@ -164,46 +196,49 @@ LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \ parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \ - weak.c compact.c finalise.c meta.c custom.c main.c globroots.c unix.c \ - dynlink.c signals.c debugger.c + weak.c compact.c finalise.c meta.c custom.c main.c globroots.c \ + $(UNIX_OR_WIN32).c dynlink.c signals.c debugger.c clean:: rm -f $(LINKEDFILES) -.SUFFIXES: .S .d.o .p.o - -.S.o: - $(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) -o $*.o $*.S || \ +%.o: %.S + $(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) -o $@ $< || \ { echo "If your assembler produced syntax errors, it is probably";\ echo "unhappy with the preprocessor. Check your assembler, or";\ echo "try producing $*.o by hand.";\ exit 2; } -.S.p.o: - $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.S +%.p.o: %.S + $(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) $(ASPPPROFFLAGS) -o $@ $< + +%.pic.o: %.S + $(ASPP) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) $(SHAREDCCCOMPOPTS) -o $@ $< + +%.d.o: %.c + $(CC) -c $(DFLAGS) -o $@ $< + +%.p.o: %.c + $(CC) -c $(PFLAGS) -o $@ $< + +%.pic.o: %.c + $(CC) -c $(PICFLAGS) -o $@ $< -.c.d.o: - ln -s -f $*.c $*.d.c - $(CC) -c $(DFLAGS) $*.d.c - rm -f $*.d.c - -.c.p.o: - ln -s -f $*.c $*.p.c - $(CC) -c $(PFLAGS) $*.p.c - rm -f $*.p.c +%.o: %.s + $(ASPP) -DSYS_$(SYSTEM) -o $@ $< -.s.o: - $(ASPP) -DSYS_$(SYSTEM) -o $*.o $*.s +%.p.o: %.s + $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $@ $< -.s.p.o: - $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.s +%.pic.o: %.s + $(ASPP) -DSYS_$(SYSTEM) $(SHAREDCCCOMPOPTS) -o $@ $< clean:: rm -f *.o *.a *~ depend: $(COBJS:.o=.c) ${LINKEDFILES} - -gcc -MM $(FLAGS) *.c > .depend - gcc -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend - gcc -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.p.o/' >> .depend + $(CC) -MM $(FLAGS) *.c > .depend + $(CC) -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend + $(CC) -MM $(FLAGS) -DPROFILING *.c | sed -e 's/\.o/.p.o/' >> .depend include .depend diff -Nru ocaml-4.01.0/asmrun/Makefile.nt ocaml-4.02.3/asmrun/Makefile.nt --- ocaml-4.01.0/asmrun/Makefile.nt 2013-04-30 11:25:14.000000000 +0200 +++ ocaml-4.02.3/asmrun/Makefile.nt 2015-03-25 05:14:32.000000000 +0100 @@ -56,8 +56,10 @@ amd64.o: amd64.S $(ASPP) -DSYS_$(SYSTEM) amd64.S +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + install: - cp libasmrun.$(A) $(LIBDIR) + cp libasmrun.$(A) $(INSTALL_LIBDIR) $(LINKEDFILES): %.c: ../byterun/%.c cp ../byterun/$*.c $*.c @@ -66,9 +68,7 @@ win32.$(O): ../byterun/win32.c $(CC) -c $(NATIVECCCOMPOPTS) -DNATIVE_CODE $(IFLEXDIR) ../byterun/win32.c -.SUFFIXES: .c .$(O) - -.c.$(O): +%.$(O): %.c $(CC) $(CFLAGS) -c $< clean:: diff -Nru ocaml-4.01.0/asmrun/natdynlink.c ocaml-4.02.3/asmrun/natdynlink.c --- ocaml-4.01.0/asmrun/natdynlink.c 2012-08-01 17:37:29.000000000 +0200 +++ ocaml-4.02.3/asmrun/natdynlink.c 2015-04-12 11:03:39.000000000 +0200 @@ -11,26 +11,26 @@ /* */ /***********************************************************************/ -#include "misc.h" -#include "mlvalues.h" -#include "memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/memory.h" #include "stack.h" -#include "callback.h" -#include "alloc.h" -#include "intext.h" -#include "osdeps.h" -#include "fail.h" +#include "caml/callback.h" +#include "caml/alloc.h" +#include "caml/intext.h" +#include "caml/osdeps.h" +#include "caml/fail.h" +#include "caml/signals.h" #include #include static void *getsym(void *handle, char *module, char *name){ - char *fullname = malloc(strlen(module) + strlen(name) + 5); + char *fullname = caml_strconcat(3, "caml", module, name); void *sym; - sprintf(fullname, "caml%s%s", module, name); sym = caml_dlsym (handle, fullname); /* printf("%s => %lx\n", fullname, (uintnat) sym); */ - free(fullname); + caml_stat_free(fullname); return sym; } @@ -52,10 +52,15 @@ CAMLlocal1 (res); void *sym; void *handle; + char *p; /* TODO: dlclose in case of error... */ - handle = caml_dlopen(String_val(filename), 1, Int_val(global)); + p = caml_strdup(String_val(filename)); + caml_enter_blocking_section(); + handle = caml_dlopen(p, 1, Int_val(global)); + caml_leave_blocking_section(); + caml_stat_free(p); if (NULL == handle) CAMLreturn(caml_copy_string(caml_dlerror())); @@ -118,10 +123,15 @@ CAMLparam2 (filename, symbol); CAMLlocal2 (res, v); void *handle; + char *p; /* TODO: dlclose in case of error... */ - handle = caml_dlopen(String_val(filename), 1, 1); + p = caml_strdup(String_val(filename)); + caml_enter_blocking_section(); + handle = caml_dlopen(p, 1, 1); + caml_leave_blocking_section(); + caml_stat_free(p); if (NULL == handle) { res = caml_alloc(1,1); diff -Nru ocaml-4.01.0/asmrun/power-elf.S ocaml-4.02.3/asmrun/power-elf.S --- ocaml-4.01.0/asmrun/power-elf.S 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmrun/power-elf.S 2014-04-12 12:17:02.000000000 +0200 @@ -200,31 +200,87 @@ /* Reload allocation pointer and allocation limit*/ Loadglobal(31, caml_young_ptr, 11) Loadglobal(30, caml_young_limit, 11) - /* Say we are back into OCaml code */ - li 12, 0 - Storeglobal(12, caml_last_return_address, 11) /* Return to caller */ blr +/* Raise an exception from OCaml */ + .globl caml_raise_exn + .type caml_raise_exn, @function +caml_raise_exn: + Loadglobal(0, caml_backtrace_active, 11) + cmpwi 0, 0 + bne .L111 +.L110: + /* Pop trap frame */ + lwz 0, 0(29) + mr 1, 29 + mtctr 0 + lwz 29, 4(29) + addi 1, 1, 16 + /* Branch to handler */ + bctr +.L111: + li 0, 0 + Storeglobal(0, caml_backtrace_pos, 11) +.L112: + mr 28, 3 /* preserve exn bucket in callee-save reg */ + /* arg1: exception bucket, already in r3 */ + mflr 4 /* arg2: PC of raise */ + mr 5, 1 /* arg3: SP of raise */ + mr 6, 29 /* arg4: SP of handler */ + addi 1, 1, -16 /* reserve stack space for C call */ + bl caml_stash_backtrace + mr 3, 28 /* restore exn bucket */ + b .L110 /* raise the exn */ + + .globl caml_reraise_exn + .type caml_reraise_exn, @function +caml_reraise_exn: + Loadglobal(0, caml_backtrace_active, 11) + cmpwi 0, 0 + bne- .L112 + /* Pop trap frame */ + lwz 0, 0(29) + mr 1, 29 + mtctr 0 + lwz 29, 4(29) + addi 1, 1, 16 + /* Branch to handler */ + bctr + /* Raise an exception from C */ .globl caml_raise_exception .type caml_raise_exception, @function caml_raise_exception: + Loadglobal(0, caml_backtrace_active, 11) + cmpwi 0, 0 + bne .L121 +.L120: /* Reload OCaml global registers */ Loadglobal(1, caml_exception_pointer, 11) Loadglobal(31, caml_young_ptr, 11) Loadglobal(30, caml_young_limit, 11) - /* Say we are back into OCaml code */ - li 0, 0 - Storeglobal(0, caml_last_return_address, 11) /* Pop trap frame */ lwz 0, 0(1) lwz 29, 4(1) - mtlr 0 + mtctr 0 addi 1, 1, 16 /* Branch to handler */ - blr + bctr +.L121: + li 0, 0 + Storeglobal(0, caml_backtrace_pos, 11) + mr 28, 3 /* preserve exn bucket in callee-save reg */ + /* arg1: exception bucket, already in r3 */ + Loadglobal(4, caml_last_return_address, 11) /* arg2: PC of raise */ + Loadglobal(5, caml_bottom_of_stack, 11) /* arg3: SP of raise */ + Loadglobal(6, caml_exception_pointer, 11) /* arg4: SP of handler */ + addi 1, 1, -16 /* reserve stack space for C call */ + bl caml_stash_backtrace + mr 3, 28 /* restore exn bucket */ + b .L120 /* raise the exn */ + /* Start the OCaml program */ diff -Nru ocaml-4.01.0/asmrun/power-rhapsody.S ocaml-4.02.3/asmrun/power-rhapsody.S --- ocaml-4.01.0/asmrun/power-rhapsody.S 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmrun/power-rhapsody.S 2014-04-12 12:17:02.000000000 +0200 @@ -36,6 +36,14 @@ addis $2, 0, ha16($1) stg $0, lo16($1)($2) .endmacro +.macro Loadglobal32 /* reg,glob,tmp */ + addis $2, 0, ha16($1) + lwz $0, lo16($1)($2) +.endmacro +.macro Storeglobal32 /* reg,glob,tmp */ + addis $2, 0, ha16($1) + stw $0, lo16($1)($2) +.endmacro .text @@ -234,21 +242,22 @@ /* Raise an exception from OCaml */ .globl _caml_raise_exn _caml_raise_exn: - addis r11, 0, ha16(_caml_backtrace_active) - lwz r11, lo16(_caml_backtrace_active)(r11) + Loadglobal32 r11, _caml_backtrace_active, r11 cmpwi r11, 0 bne L110 L111: /* Pop trap frame */ lg r0, 0(r29) mr r1, r29 - mtlr r0 + mtctr r0 lg r29, WORD(r1) addi r1, r1, 16 /* Branch to handler */ - blr - + bctr L110: + li r0, 0 + Storeglobal32 r0, _caml_backtrace_pos, r11 +L114: mr r28, r3 /* preserve exn bucket in callee-save */ /* arg 1: exception bucket (already in r3) */ mflr r4 /* arg 2: PC of raise */ @@ -259,12 +268,25 @@ mr r3, r28 b L111 -/* Raise an exception from C */ + .globl _caml_reraise_exn +_caml_reraise_exn: + Loadglobal32 r11, _caml_backtrace_active, r11 + cmpwi r11, 0 + bne- L114 + /* Pop trap frame */ + lg r0, 0(r29) + mr r1, r29 + mtctr r0 + lg r29, WORD(r1) + addi r1, r1, 16 + /* Branch to handler */ + bctr + + /* Raise an exception from C */ .globl _caml_raise_exception _caml_raise_exception: - addis r11, 0, ha16(_caml_backtrace_active) - lwz r11, lo16(_caml_backtrace_active)(r11) + Loadglobal32 r11, _caml_backtrace_active, r11 cmpwi r11, 0 bne L112 L113: @@ -278,10 +300,10 @@ /* Pop trap frame */ lg r0, 0(r1) lg r29, WORD(r1) - mtlr r0 + mtctr r0 addi r1, r1, 16 /* Branch to handler */ - blr + bctr L112: mr r28, r3 /* preserve exn bucket in callee-save */ /* arg 1: exception bucket (already in r3) */ diff -Nru ocaml-4.01.0/asmrun/roots.c ocaml-4.02.3/asmrun/roots.c --- ocaml-4.01.0/asmrun/roots.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/asmrun/roots.c 2015-04-12 11:03:39.000000000 +0200 @@ -13,15 +13,15 @@ /* To walk the memory roots for garbage collection */ -#include "finalise.h" -#include "globroots.h" -#include "memory.h" -#include "major_gc.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/finalise.h" +#include "caml/globroots.h" +#include "caml/memory.h" +#include "caml/major_gc.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" #include "stack.h" -#include "roots.h" +#include "caml/roots.h" #include #include diff -Nru ocaml-4.01.0/asmrun/signals_asm.c ocaml-4.02.3/asmrun/signals_asm.c --- ocaml-4.01.0/asmrun/signals_asm.c 2013-07-23 16:48:47.000000000 +0200 +++ ocaml-4.02.3/asmrun/signals_asm.c 2015-06-05 18:09:17.000000000 +0200 @@ -19,11 +19,11 @@ #include #include #include -#include "fail.h" -#include "memory.h" -#include "osdeps.h" -#include "signals.h" -#include "signals_machdep.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/osdeps.h" +#include "caml/signals.h" +#include "caml/signals_machdep.h" #include "signals_osdep.h" #include "stack.h" @@ -47,6 +47,8 @@ extern char * caml_code_area_start, * caml_code_area_end; extern char caml_system__code_begin, caml_system__code_end; +/* Do not use the macro from address_class.h here. */ +#undef Is_in_code_area #define Is_in_code_area(pc) \ ( ((char *)(pc) >= caml_code_area_start && \ (char *)(pc) <= caml_code_area_end) \ @@ -166,10 +168,8 @@ #endif caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER; caml_young_ptr = (char *) CONTEXT_YOUNG_PTR; -#if defined(SYS_rhapsody) caml_bottom_of_stack = (char *) CONTEXT_SP; caml_last_return_address = (uintnat) CONTEXT_PC; -#endif caml_array_bound_error(); } #endif diff -Nru ocaml-4.01.0/asmrun/signals_osdep.h ocaml-4.02.3/asmrun/signals_osdep.h --- ocaml-4.01.0/asmrun/signals_osdep.h 2013-06-24 10:16:27.000000000 +0200 +++ ocaml-4.02.3/asmrun/signals_osdep.h 2015-05-06 17:18:50.000000000 +0200 @@ -66,18 +66,7 @@ #elif defined(TARGET_arm) && (defined(SYS_linux_eabi) \ || defined(SYS_linux_eabihf)) - #if defined(__ANDROID__) - // The Android NDK does not have sys/ucontext.h yet. - typedef struct ucontext { - uint32_t uc_flags; - struct ucontext *uc_link; - stack_t uc_stack; - struct sigcontext uc_mcontext; - // Other fields omitted... - } ucontext_t; - #else - #include - #endif + #include #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, siginfo_t * info, ucontext_t * context) @@ -92,6 +81,25 @@ #define CONTEXT_YOUNG_PTR (context->uc_mcontext.arm_r8) #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.fault_address) +/****************** ARM64, Linux */ + +#elif defined(TARGET_arm64) && defined(SYS_linux) + + #include + + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, ucontext_t * context) + + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ + sigact.sa_flags = SA_SIGINFO + + typedef unsigned long context_reg; + #define CONTEXT_PC (context->uc_mcontext.pc) + #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.regs[26]) + #define CONTEXT_YOUNG_PTR (context->uc_mcontext.regs[27]) + #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.fault_address) + /****************** AMD64, Solaris x86 */ #elif defined(TARGET_amd64) && defined (SYS_solaris) @@ -111,6 +119,22 @@ #define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15]) #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) +/****************** AMD64, OpenBSD */ + +#elif defined(TARGET_amd64) && defined (SYS_openbsd) + + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, struct sigcontext * context) + + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ + sigact.sa_flags = SA_SIGINFO + + #define CONTEXT_PC (context->sc_rip) + #define CONTEXT_EXCEPTION_POINTER (context->sc_r14) + #define CONTEXT_YOUNG_PTR (context->sc_r15) + #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) + /****************** I386, Linux */ #elif defined(TARGET_i386) && defined(SYS_linux_elf) @@ -124,6 +148,30 @@ #define CONTEXT_FAULTING_ADDRESS ((char *) context.cr2) +/****************** I386, BSD_ELF */ + +#elif defined(TARGET_i386) && defined(SYS_bsd_elf) + + #if defined (__NetBSD__) + #include + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, ucontext_t * context) + #else + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, struct sigcontext * context) + #endif + + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ + sigact.sa_flags = SA_SIGINFO + + #if defined (__NetBSD__) + #define CONTEXT_PC (_UC_MACHINE_PC(context)) + #else + #define CONTEXT_PC (context->sc_eip) + #endif + #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) + /****************** I386, BSD */ #elif defined(TARGET_i386) && defined(SYS_bsd) @@ -234,6 +282,7 @@ #define CONTEXT_EXCEPTION_POINTER (context->regs->gpr[29]) #define CONTEXT_YOUNG_LIMIT (context->regs->gpr[30]) #define CONTEXT_YOUNG_PTR (context->regs->gpr[31]) + #define CONTEXT_SP (context->regs->gpr[1]) /****************** PowerPC, BSD */ @@ -247,9 +296,11 @@ sigact.sa_flags = 0 typedef unsigned long context_reg; + #define CONTEXT_PC (context->sc_frame.srr0) #define CONTEXT_EXCEPTION_POINTER (context->sc_frame.fixreg[29]) #define CONTEXT_YOUNG_LIMIT (context->sc_frame.fixreg[30]) #define CONTEXT_YOUNG_PTR (context->sc_frame.fixreg[31]) + #define CONTEXT_SP (context->sc_frame.fixreg[1]) /****************** SPARC, Solaris */ @@ -268,6 +319,7 @@ #define CONTEXT_PC (context->uc_mcontext.gregs[REG_PC]) /* Local register number N is saved on the stack N words after the stack pointer */ + #define CONTEXT_SP (context->uc_mcontext.gregs[REG_SP]) #define SPARC_L_REG(n) ((long *)(context->uc_mcontext.gregs[REG_SP]))[n] #define CONTEXT_EXCEPTION_POINTER (SPARC_L_REG(5)) #define CONTEXT_YOUNG_LIMIT (SPARC_L_REG(7)) diff -Nru ocaml-4.01.0/asmrun/stack.h ocaml-4.02.3/asmrun/stack.h --- ocaml-4.01.0/asmrun/stack.h 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/asmrun/stack.h 2015-04-03 18:59:28.000000000 +0200 @@ -25,7 +25,7 @@ #ifdef TARGET_i386 #define Saved_return_address(sp) *((intnat *)((sp) - 4)) -#ifdef SYS_macosx +#ifndef SYS_win32 #define Callback_link(sp) ((struct caml_context *)((sp) + 16)) #else #define Callback_link(sp) ((struct caml_context *)((sp) + 8)) @@ -56,6 +56,11 @@ #define Callback_link(sp) ((struct caml_context *)((sp) + 16)) #endif +#ifdef TARGET_arm64 +#define Saved_return_address(sp) *((intnat *)((sp) - 8)) +#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) +#endif + /* Structure of OCaml callback contexts */ struct caml_context { @@ -73,6 +78,15 @@ unsigned short live_ofs[1]; } frame_descr; +struct caml_loc_info { + int loc_valid; + int loc_is_raise; + char * loc_filename; + int loc_lnum; + int loc_startchr; + int loc_endchr; +}; + /* Hash table of frame descriptors */ extern frame_descr ** caml_frame_descriptors; @@ -85,6 +99,10 @@ extern void caml_register_frametable(intnat *); extern void caml_register_dyn_global(void *); +CAMLextern void extract_location_info(frame_descr * d, + /*out*/ struct caml_loc_info * li); + + extern uintnat caml_stack_usage (void); extern uintnat (*caml_stack_usage_hook)(void); diff -Nru ocaml-4.01.0/asmrun/startup.c ocaml-4.02.3/asmrun/startup.c --- ocaml-4.01.0/asmrun/startup.c 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/asmrun/startup.c 2015-04-12 11:03:39.000000000 +0200 @@ -15,24 +15,24 @@ #include #include -#include "callback.h" -#include "backtrace.h" -#include "custom.h" -#include "debugger.h" -#include "fail.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "intext.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "osdeps.h" -#include "printexc.h" +#include "caml/callback.h" +#include "caml/backtrace.h" +#include "caml/custom.h" +#include "caml/debugger.h" +#include "caml/fail.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/intext.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/osdeps.h" +#include "caml/printexc.h" #include "stack.h" -#include "sys.h" +#include "caml/sys.h" #ifdef HAS_UI -#include "ui.h" +#include "caml/ui.h" #endif extern int caml_parser_trace; @@ -158,9 +158,7 @@ void caml_main(char **argv) { char * exe_name; -#ifdef __linux__ static char proc_self_exe[256]; -#endif value res; char tos; @@ -181,14 +179,10 @@ caml_debugger_init (); /* force debugger.o stub to be linked */ exe_name = argv[0]; if (exe_name == NULL) exe_name = ""; -#ifdef __linux__ if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) exe_name = proc_self_exe; else exe_name = caml_search_exe_in_path(exe_name); -#else - exe_name = caml_search_exe_in_path(exe_name); -#endif caml_sys_init(exe_name, argv); if (sigsetjmp(caml_termination_jmpbuf.buf, 0)) { if (caml_termination_hook != NULL) caml_termination_hook(NULL); diff -Nru ocaml-4.01.0/boot/.ignore ocaml-4.02.3/boot/.ignore --- ocaml-4.01.0/boot/.ignore 2012-07-26 21:21:54.000000000 +0200 +++ ocaml-4.02.3/boot/.ignore 2013-12-17 10:58:47.000000000 +0100 @@ -4,5 +4,3 @@ ocamlyacc ocamlyacc.exe camlheader -myocamlbuild -myocamlbuild.native Binarne pliki /tmp/4fJP7uIid7/ocaml-4.01.0/boot/myocamlbuild.boot i /tmp/mpHfdiXLNF/ocaml-4.02.3/boot/myocamlbuild.boot różnią się Binarne pliki /tmp/4fJP7uIid7/ocaml-4.01.0/boot/ocamlc i /tmp/mpHfdiXLNF/ocaml-4.02.3/boot/ocamlc różnią się Binarne pliki /tmp/4fJP7uIid7/ocaml-4.01.0/boot/ocamldep i /tmp/mpHfdiXLNF/ocaml-4.02.3/boot/ocamldep różnią się Binarne pliki /tmp/4fJP7uIid7/ocaml-4.01.0/boot/ocamllex i /tmp/mpHfdiXLNF/ocaml-4.02.3/boot/ocamllex różnią się diff -Nru ocaml-4.01.0/build/boot-c-parts.sh ocaml-4.02.3/build/boot-c-parts.sh --- ocaml-4.01.0/build/boot-c-parts.sh 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/build/boot-c-parts.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,50 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. -set -ex - -. config/config.sh - -if "$WINDOWS"; then - MAKEOPTS='-f Makefile.nt' - LINK='cp -f' -else - MAKEOPTS='' - LINK='ln -s -f' -fi - -(cd byterun && make $MAKEOPTS) -(cd asmrun && make $MAKEOPTS all meta."$O" dynlink."$O") -(cd yacc && make $MAKEOPTS) - -if "$WINDOWS"; then - (cd win32caml && make) -fi - -mkdir -p _build/boot - -# Create a bunch of symlinks (or copies) to _build/boot -(cd _build/boot && -$LINK ../../byterun/ocamlrun$EXE \ - ../../byterun/libcamlrun.$A \ - ../../asmrun/libasmrun.$A \ - ../../yacc/ocamlyacc$EXE \ - ../../boot/ocamlc \ - ../../boot/ocamllex \ - ../../boot/ocamldep \ - . ) - -(cd boot && -[ -f boot/ocamlrun$EXE ] || $LINK ../byterun/ocamlrun$EXE . ) diff -Nru ocaml-4.01.0/build/boot.sh ocaml-4.02.3/build/boot.sh --- ocaml-4.01.0/build/boot.sh 2013-02-18 13:09:06.000000000 +0100 +++ ocaml-4.02.3/build/boot.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,39 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. -set -ex -TAG_LINE='true: -use_stdlib' - -# If you modify this list, modify it also in camlp4-native-only.sh -STDLIB_MODULES='Pervasives,Arg,Array,Buffer,Char,Digest,Filename,Format,Hashtbl,Lazy,Lexing,List,Map,Printexc,Printf,Scanf,Set,String,Sys,Parsing,Int32,Int64,Nativeint,Obj,Queue,Sort,Stream,Stack' - -./boot/ocamlrun boot/myocamlbuild.boot -ignore "$STDLIB_MODULES" \ - -tag-line "$TAG_LINE" \ - boot/stdlib.cma boot/std_exit.cmo - -boot/ocamlrun boot/myocamlbuild.boot \ - -tag-line "$TAG_LINE" -log _boot_log1 \ - ocamlbuild/ocamlbuildlightlib.cma ocamlbuild/ocamlbuildlight.byte - -rm -f _build/myocamlbuild - -boot/ocamlrun boot/myocamlbuild.boot \ - -just-plugin -install-lib-dir _build/ocamlbuild -byte-plugin - -cp _build/myocamlbuild boot/myocamlbuild - -./boot/ocamlrun boot/myocamlbuild \ - -tag-line "$TAG_LINE" \ - $@ -log _boot_log2 boot/camlheader ocamlc diff -Nru ocaml-4.01.0/build/buildbot ocaml-4.02.3/build/buildbot --- ocaml-4.01.0/build/buildbot 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/build/buildbot 1970-01-01 01:00:00.000000000 +0100 @@ -1,125 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# 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 -} - -logfile="buildbot.log" - -finish() { - curl -s -0 -F "log=@$logfile" \ - -F "host=`hostname`" \ - -F "mode=$mode-$opt_win-$opt_win2" \ - http://buildbot.feydakins.org/dropbox || : -} - -rm -f buildbot.failed -rm -f $logfile - -bad() { - touch buildbot.failed -} - -finish_if_bad() { - if [ -f buildbot.failed ]; then - finish - exit 2 - fi -} - -if figlet "test" > /dev/null 2> /dev/null; then - draw="figlet" -else - draw="echo ----------- " -fi - -if echo | tee -a tee.log > /dev/null 2> /dev/null; then - tee="tee -a $logfile" -else - tee=: -fi - -rm -f tee.log - -log() { - $draw $@ - $tee -} - -mode=$1 -shift 1 - -case "$mode" in - make|ocb|ocamlbuild) : ;; - *) usage;; -esac - -case "$1" in - win) - opt_win=win - opt_win2=$2 - shift 2 - Makefile=Makefile.nt;; - *) Makefile=Makefile;; -esac - -( [ -f config/Makefile ] && make -f $Makefile clean || : ) 2>&1 | log clean - -( ./build/distclean.sh || : ) 2>&1 | log distclean - -(cvs -q up -dP -r release311 || bad) 2>&1 | log cvs up -finish_if_bad - -case "$opt_win" in -win) - - # FIXME - sed -e 's/\(OTHERLIBRARIES=.*\) labltk/\1/' \ - < "config/Makefile.$opt_win2" > config/Makefile || bad - finish_if_bad - - cp config/m-nt.h config/m.h || bad - finish_if_bad - cp config/s-nt.h config/s.h || bad - finish_if_bad - ;; - -*) - (./configure --prefix `pwd`/_install $@ || bad) 2>&1 | log configure - finish_if_bad - ;; -esac - -case "$mode" in - make) - (make -f $Makefile world opt opt.opt install || bad) 2>&1 | log build install - finish_if_bad - ;; - ocb|ocamlbuild) - (./build/fastworld.sh || bad) 2>&1 | log build - finish_if_bad - (./build/install.sh || bad) 2>&1 | log install - finish_if_bad - ;; -esac - -(cat _build/not_installed || bad) 2>&1 | log not_installed - -finish diff -Nru ocaml-4.01.0/build/camlp4-bootstrap-recipe.txt ocaml-4.02.3/build/camlp4-bootstrap-recipe.txt --- ocaml-4.01.0/build/camlp4-bootstrap-recipe.txt 2012-08-02 10:17:59.000000000 +0200 +++ ocaml-4.02.3/build/camlp4-bootstrap-recipe.txt 1970-01-01 01:00:00.000000000 +0100 @@ -1,181 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2010 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -=== Initial setup === - make clean - ./build/distclean.sh - ./configure -prefix `pwd`/_install - (cd otherlibs/labltk/browser; make help.ml) - ./build/fastworld.sh - # Go to "Bootstrap camlp4" - -=== Install the bootstrapping camlp4 processor === - ./build/install.sh - -=== Build camlp4 === - # This step is not needed right after a "./build/world.sh byte" - ./build/camlp4-byte-only.sh - -=== Bootstrap camlp4 === - # First "Build camlp4" - # Then "Install the bootstrapping camlp4 processor" - # Indeed the following bootstrapping script - # does use the installed version! - ./build/camlp4-bootstrap.sh - # If the fixpoint not is reached yet - # Go to "Bootstrap camlp4" - # Otherwise - # Have a look at the changes in - # camlp4/boot it may be a good idea to commit them - -=== Generate Camlp4Ast.ml === - # First "Install the bootstrapping camlp4 processor" - # Indeed the following bootstrapping script - # does use the installed version! - ./build/camlp4-mkCamlp4Ast.sh - -=== Case study "let open M in e" === - - Open the revised parser - Camlp4Parsers/Camlp4OCamlRevisedParser.ml - - Look for similar constructs, indeed rules - that start by the same prefix should in - the same entry. It is simpler to stick - them close to each other. - - [ "let"; r = opt_rec; ... - | "let"; "module"; m = a_UIDENT; ... - - So we naturally add something like - - | "let"; "open"; ... - - Then have a look to the "open" construct: - - | "open"; i = module_longident -> - - So we need a module_longident, it becomes: - - | "let"; "open"; i = module_longident; "in"; e = SELF -> - - Then we leave a dummy action but very close to what we want - in the end: - - | "let"; "open"; i = module_longident; "in"; e = SELF -> - <:expr< open_in $id:i$ $e$ >> - - Here it is just calling a (non-existing) function called open_in. - - Check that there is no other place where we have to duplicate this - rule (yuk!). In our case it is! The sequence entry have the "let" - rules again. - - Then go into Camlp4Parsers/Camlp4OCamlParser.ml and look for other - occurences. - - When copy/pasting the rule take care of SELF occurences, you may - have to replace it by expr and expr LEVEL ";" in our case. - - The return type of the production might be different from expr in - our case an action become <:str_item<...>> instead of <:expr<...> - - Watch the DELETE_RULE as well, in our case I'm searching for the - literal string "let" in the source: - - DELETE_RULE Gram expr: "let"; "open"; module_longident; "in"; SELF END; - - Then build and bootstrap. - - Then you can at last extend the AST, go in: - - Camlp4/Camlp4Ast.partial.ml - - And add the "open in" constructor (at the end). - - (* let open i in e *) - | ExOpI of loc and ident and expr - - Then "Generate Camlp4Ast.ml" and build. - - We get a single warning in Camlp4/Struct/Camlp4Ast2OCamlAst.ml but - don't fix it now. Notice that you may need to disable '-warn-error' - in order to be able to successfully compile, despite of the warning. - - Then I hacked the camlp4/boot/camlp4boot.ml to generate: - Ast.ExOpI(_loc, i, e) - instead of - Ast.ExApp(_loc .... "open_in" ... i ... e ...) - - Build. Bootstrap once and build again. - - Then change the parsers again and replace the - open_in $id:i$ $e$ - by - let open $i$ in $e$ - - Then change the Parsetree generation in - Camlp4/Struct/Camlp4Ast2OCamlAst.ml - - | <:expr@loc< let open $i$ in $e$ >> -> - mkexp loc (Pexp_open (long_uident i) (expr e)) - - Change the pretty-printers as well (drawing inspiration in - "let module" in this case): - - In Camlp4/Printers/OCaml.ml: - | <:expr< let open $i$ in $e$ >> -> - pp f "@[<2>let open %a@]@ @[<2>in@ %a@]" - o#ident i o#reset_semi#expr e - And at the end of #simple_expr: - <:expr< let open $_$ in $_$ >> - - Have a look in Camlp4/Printers/OCamlr.ml as well. - -=== Second case study "with t := ..." === - -1/ Change the revised parser first. -Add new parsing rules for := but keep the old actions for now. - -2/ Change Camlp4Ast.partial.ml, add: - (* type t := t *) - | WcTyS of loc and ctyp and ctyp - (* module i := i *) - | WcMoS of loc and ident and ident - -3/ "Generate Camlp4Ast.ml" and build. - -4/ Change the generated camlp4/boot/camlp4boot.ml: - Look for ":=" and change occurences of - WcMod by WcMoS and WcTyp by WcTyS - -5/ Build (DO NOT bootstrap) - "Install the bootstrapping camlp4 processor" - -6/ Change the required files: - Camlp4/Printers/OCaml.ml: - just copy/paste&adapt what is done for - "... with type t = u" and - "... with module M = N" - Camlp4/Struct/Camlp4Ast2OCamlAst.ml: - I've factored out a common part under - another function and then copy/pasted. - Camlp4Parsers/Camlp4OCamlRevisedParser.ml: - Change the <:with_constr< type $...$ = $...$ >> - we've introduced earlier by replacing the '=' - by ':='. - Camlp4Parsers/Camlp4OCamlParser.ml: - Copy paste what we have done in Camlp4OCamlRevisedParser - and but we need to call opt_private_ctyp instead of - ctyp (just like the "type =" construct). - -7/ Build & Bootstrap diff -Nru ocaml-4.01.0/build/camlp4-bootstrap.sh ocaml-4.02.3/build/camlp4-bootstrap.sh --- ocaml-4.01.0/build/camlp4-bootstrap.sh 2013-08-30 13:39:33.000000000 +0200 +++ ocaml-4.02.3/build/camlp4-bootstrap.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,51 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# README: to bootstrap camlp4 have a look at build/camlp4-bootstrap-recipe.txt - -set -e -cd `dirname $0`/.. - -. config/config.sh -export PATH=$BINDIR:$PATH - -TMPTARGETS="\ - camlp4/boot/Lexer.ml" - -TARGETS="\ - camlp4/Camlp4/Struct/Camlp4Ast.ml \ - camlp4/boot/Camlp4.ml \ - camlp4/boot/camlp4boot.ml" - -for target in $TARGETS camlp4/boot/Camlp4Ast.ml; do - [ -f "$target" ] && mv "$target" "$target.old" - rm -f "_build/$target" -done - -if [ -x ./boot/myocamlbuild.native ]; then - OCAMLBUILD=./boot/myocamlbuild.native -else - OCAMLBUILD="./boot/ocamlrun boot/myocamlbuild" -fi -$OCAMLBUILD $TMPTARGETS $TARGETS - -for t in $TARGETS; do - echo promote $t - cp _build/$t camlp4/boot/`basename $t` - if cmp _build/$t camlp4/boot/`basename $t`.old; then - echo fixpoint for $t - else - echo $t is different, you should rebootstrap it by cleaning, building and call this script - fi -done diff -Nru ocaml-4.01.0/build/camlp4-byte-only.sh ocaml-4.02.3/build/camlp4-byte-only.sh --- ocaml-4.01.0/build/camlp4-byte-only.sh 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/build/camlp4-byte-only.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,19 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ byte_stdlib_mixed_mode $OCAMLC_BYTE $OCAMLLEX_BYTE $CAMLP4_BYTE diff -Nru ocaml-4.01.0/build/camlp4-mkCamlp4Ast.sh ocaml-4.02.3/build/camlp4-mkCamlp4Ast.sh --- ocaml-4.01.0/build/camlp4-mkCamlp4Ast.sh 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/build/camlp4-mkCamlp4Ast.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,36 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2010 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. - -. config/config.sh -export PATH=$BINDIR:$PATH - -CAMLP4AST=camlp4/Camlp4/Struct/Camlp4Ast.ml -BOOTP4AST=camlp4/boot/Camlp4Ast.ml - -[ -f "$BOOTP4AST" ] && mv "$BOOTP4AST" "$BOOTP4AST.old" -rm -f "_build/$BOOTP4AST" -rm -f "_build/$CAMLP4AST" - -if [ -x ./boot/myocamlbuild.native ]; then - OCAMLBUILD=./boot/myocamlbuild.native -else - OCAMLBUILD="./boot/ocamlrun boot/myocamlbuild" -fi -$OCAMLBUILD $CAMLP4AST - -echo promote $CAMLP4AST -cp _build/$CAMLP4AST camlp4/boot/`basename $CAMLP4AST` diff -Nru ocaml-4.01.0/build/camlp4-native-only.sh ocaml-4.02.3/build/camlp4-native-only.sh --- ocaml-4.01.0/build/camlp4-native-only.sh 2013-02-18 13:09:06.000000000 +0100 +++ ocaml-4.02.3/build/camlp4-native-only.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,23 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x - -# If you modify this list, modify it also in boot.sh -STDLIB_MODULES='Pervasives,Arg,Array,Buffer,Char,Digest,Filename,Format,Hashtbl,Lazy,Lexing,List,Map,Printexc,Printf,Scanf,Set,String,Sys,Parsing,Int32,Int64,Nativeint,Obj,Queue,Sort,Stream,Stack' - -$OCAMLBUILD -ignore "$STDLIB_MODULES" $@ native_stdlib_mixed_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $CAMLP4_NATIVE diff -Nru ocaml-4.01.0/build/camlp4-targets.sh ocaml-4.02.3/build/camlp4-targets.sh --- ocaml-4.01.0/build/camlp4-targets.sh 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/build/camlp4-targets.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,46 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -CAMLP4_COMMON="\ - camlp4/Camlp4/Camlp4Ast.partial.ml \ - camlp4/boot/camlp4boot.byte" -CAMLP4_BYTE="$CAMLP4_COMMON \ - camlp4/Camlp4.cmo \ - camlp4/Camlp4Top.cmo \ - camlp4/camlp4prof.byte$EXE \ - camlp4/mkcamlp4.byte$EXE \ - camlp4/camlp4.byte$EXE \ - camlp4/camlp4fulllib.cma" -CAMLP4_NATIVE="$CAMLP4_COMMON \ - camlp4/Camlp4.cmx \ - camlp4/Camlp4Top.cmx \ - camlp4/camlp4prof.native$EXE \ - camlp4/mkcamlp4.native$EXE \ - camlp4/camlp4.native$EXE \ - camlp4/camlp4fulllib.cmxa" - -for i in camlp4boot camlp4r camlp4rf camlp4o camlp4of camlp4oof camlp4orf; do - CAMLP4_BYTE="$CAMLP4_BYTE camlp4/$i.byte$EXE camlp4/$i.cma" - CAMLP4_NATIVE="$CAMLP4_NATIVE camlp4/$i.native$EXE" -done - -cd camlp4 -for dir in Camlp4Parsers Camlp4Printers Camlp4Filters; do - for file in $dir/*.ml; do - base=camlp4/$dir/`basename $file .ml` - CAMLP4_BYTE="$CAMLP4_BYTE $base.cmo" - CAMLP4_NATIVE="$CAMLP4_NATIVE $base.cmx $base.$O" - done -done -cd .. diff -Nru ocaml-4.01.0/build/distclean.sh ocaml-4.02.3/build/distclean.sh --- ocaml-4.01.0/build/distclean.sh 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/build/distclean.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,43 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. -set -ex -(cd byterun && make clean) || : -(cd asmrun && make clean) || : -(cd yacc && make clean) || : -rm -f build/ocamlbuild_mixed_mode -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 -rm -f driver/main.byte driver/optmain.byte lex/main.byte \ - tools/ocamlmklib.byte camlp4/build/location.ml \ - camlp4/build/location.mli \ - tools/myocamlbuild_config.ml camlp4/build/linenum.mli \ - camlp4/build/linenum.mll \ - camlp4/build/terminfo.mli camlp4/build/terminfo.ml - -# from ocamlbuild bootstrap -rm -f ocamlbuild/_log ocamlbuild/,ocamlbuild.byte.start \ - ocamlbuild/boot/ocamlbuild ocamlbuild/myocamlbuild_config.ml \ - ocamlbuild/myocamlbuild_config.mli -rm -rf ocamlbuild/_build ocamlbuild/_start - -# from the old build system -rm -f camlp4/build/camlp4_config.ml camlp4/**/*.cm* diff -Nru ocaml-4.01.0/build/fastworld.sh ocaml-4.02.3/build/fastworld.sh --- ocaml-4.01.0/build/fastworld.sh 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/build/fastworld.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,48 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0` -set -e -if [ -e ocamlbuild_mixed_mode ]; then - echo ocamlbuild mixed mode detected - echo 'please cleanup and re-launch (make clean ; ./build/distclean.sh)' - exit 1 -fi -./mkconfig.sh -./mkmyocamlbuild_config.sh -./boot-c-parts.sh -./boot.sh $@ - -cd .. -. build/targets.sh -OCAMLMKLIB_BYTE="tools/ocamlmklib.byte" -set -x -$OCAMLBUILD $@ -log _boot_fast_log \ - $STDLIB_BYTE $OCAMLOPT_BYTE $STDLIB_NATIVE \ - $OCAMLOPT_NATIVE $OCAMLMKLIB_BYTE $OTHERLIBS_UNIX_NATIVE $OCAMLBUILD_NATIVE - -rm -f _build/myocamlbuild -boot/ocamlrun boot/myocamlbuild \ - -just-plugin -install-lib-dir _build/ocamlbuild \ - -ocamlopt "../_build/ocamlopt.opt -nostdlib -I boot -I stdlib -I $UNIXDIR" -cp _build/myocamlbuild boot/myocamlbuild.native - -./boot/myocamlbuild.native $@ \ - $OCAMLC_NATIVE $TOPLEVEL $OTHERLIBS_BYTE $OTHERLIBS_NATIVE $OCAMLLEX_BYTE \ - $OCAMLLEX_NATIVE $TOOLS_BYTE $TOOLS_NATIVE $DEBUGGER \ - $OCAMLDOC_BYTE $OCAMLDOC_NATIVE $OCAMLBUILD_BYTE $CAMLP4_BYTE $CAMLP4_NATIVE - -cd tools -make objinfo_helper -cd .. diff -Nru ocaml-4.01.0/build/.ignore ocaml-4.02.3/build/.ignore --- ocaml-4.01.0/build/.ignore 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/build/.ignore 1970-01-01 01:00:00.000000000 +0100 @@ -1 +0,0 @@ -ocamlbuild_mixed_mode diff -Nru ocaml-4.01.0/build/install.sh ocaml-4.02.3/build/install.sh --- ocaml-4.01.0/build/install.sh 2013-01-01 05:53:49.000000000 +0100 +++ ocaml-4.02.3/build/install.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,573 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e - -cd `dirname $0`/.. - -. config/config.sh - -not_installed=$PWD/_build/not_installed - -rm -f "$not_installed" -touch "$not_installed" - -wontinstall() { - echo "$1" >> "$not_installed" - echo " don't install $1" -} - -installbin() { - if [ -f "$1" ]; then - echo " install binary $2" - cp -f "$1" "$2" - [ -x "$2" ] || chmod +x "$2" - else - wontinstall "$1" - fi -} - -installbestbin() { - if [ -f "$1" ]; then - echo " install binary $3 (with `basename $1`)" - cp -f "$1" "$3" - else - if [ -f "$2" ]; then - echo " install binary $3 (with `basename $2`)" - cp -f "$2" "$3" - else - echo "None of $1, $2 exists" - exit 3 - fi - fi - [ -x "$3" ] || chmod +x "$3" -} - -installlib() { - if [ -f "$1" ]; then - dest="$2/`basename $1`" - echo " install library $dest" - cp -f "$1" "$2" - if [ "$RANLIB" != "" ]; then - "$RANLIB" "$dest" - fi - else - wontinstall "$1" - fi -} - -installdir() { - args="" - while [ $# -gt 1 ]; do - if [ -f "$1" ]; then - args="$args $1" - else - wontinstall "$1" - fi - shift - done - last="$1" - for file in $args; do - echo " install $last/`basename $file`" - cp -f "$file" "$last" - done -} - -installlibdir() { - args="" - while [ $# -gt 1 ]; do - args="$args $1" - shift - done - last="$1" - for file in $args; do - installlib "$file" "$last" - done -} - -mkdir -p $BINDIR -mkdir -p $LIBDIR -mkdir -p $LIBDIR/caml -mkdir -p $LIBDIR/camlp4 -mkdir -p $LIBDIR/vmthreads -mkdir -p $LIBDIR/threads -mkdir -p $LIBDIR/labltk -mkdir -p $LIBDIR/ocamlbuild -mkdir -p $LIBDIR/ocamldoc -mkdir -p $LIBDIR/ocamldoc/custom -mkdir -p $STUBLIBDIR -mkdir -p $MANDIR/man1 -mkdir -p $MANDIR/man3 -mkdir -p $MANDIR/man$MANEXT - -echo "Installing core libraries..." -installlibdir byterun/libcamlrun.$A asmrun/libasmrun.$A asmrun/libasmrunp.$A \ - $LIBDIR -installdir byterun/libcamlrun_shared$EXT_DLL $LIBDIR - -PUBLIC_INCLUDES="\ - alloc.h callback.h config.h custom.h fail.h intext.h \ - memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h" - -cd byterun -for i in $PUBLIC_INCLUDES; do - echo " install caml/$i" - sed -f ../tools/cleanup-header $i > $LIBDIR/caml/$i -done -cd .. - -WIN32="" -if [ "x$EXE" = "x.exe" ]; then - installbin win32caml/ocamlwin.exe $PREFIX/OCamlWin.exe - WIN32=win32 -fi - -installdir otherlibs/"$WIN32"unix/unixsupport.h \ - otherlibs/bigarray/bigarray.h \ - $LIBDIR/caml - -installdir yacc/ocamlyacc$EXE byterun/ocamlrun$EXE $BINDIR - -installdir config/Makefile $LIBDIR/Makefile.config -installdir byterun/ld.conf $LIBDIR - -cd _build - -echo "Installing the toplevel and compilers..." -installbin ocaml$EXE $BINDIR/ocaml$EXE -installbin ocamlc$EXE $BINDIR/ocamlc$EXE -installbin ocamlopt$EXE $BINDIR/ocamlopt$EXE -installbin ocamlc.opt$EXE $BINDIR/ocamlc.opt$EXE -installbin ocamlopt.opt$EXE $BINDIR/ocamlopt.opt$EXE - -set=set # coloration workaround - -echo "Installing the standard library..." -installdir \ - stdlib/stdlib.cma \ - stdlib/stdlib.cmxa stdlib/stdlib.p.cmxa \ - stdlib/camlheader \ - stdlib/camlheader_ur \ - stdlib/std_exit.cm[io] stdlib/std_exit.ml \ - stdlib/arg.cmi stdlib/arg.ml stdlib/arg.mli \ - stdlib/array.cmi stdlib/array.ml stdlib/array.mli \ - stdlib/arrayLabels.cmi stdlib/arrayLabels.ml stdlib/arrayLabels.mli \ - stdlib/buffer.cmi stdlib/buffer.ml stdlib/buffer.mli \ - stdlib/callback.cmi stdlib/callback.ml stdlib/callback.mli \ - stdlib/camlinternalLazy.cmi stdlib/camlinternalLazy.ml stdlib/camlinternalLazy.mli \ - stdlib/camlinternalMod.cmi stdlib/camlinternalMod.ml stdlib/camlinternalMod.mli \ - stdlib/camlinternalOO.cmi stdlib/camlinternalOO.ml stdlib/camlinternalOO.mli \ - stdlib/char.cmi stdlib/char.ml stdlib/char.mli \ - stdlib/complex.cmi stdlib/complex.ml stdlib/complex.mli \ - stdlib/digest.cmi stdlib/digest.ml stdlib/digest.mli \ - stdlib/filename.cmi stdlib/filename.ml stdlib/filename.mli \ - stdlib/format.cmi stdlib/format.ml stdlib/format.mli \ - stdlib/gc.cmi stdlib/gc.ml stdlib/gc.mli \ - stdlib/genlex.cmi stdlib/genlex.ml stdlib/genlex.mli \ - stdlib/hashtbl.cmi stdlib/hashtbl.ml stdlib/hashtbl.mli \ - stdlib/int32.cmi stdlib/int32.ml stdlib/int32.mli \ - stdlib/int64.cmi stdlib/int64.ml stdlib/int64.mli \ - stdlib/lazy.cmi stdlib/lazy.ml stdlib/lazy.mli \ - stdlib/lexing.cmi stdlib/lexing.ml stdlib/lexing.mli \ - stdlib/list.cmi stdlib/list.ml stdlib/list.mli \ - stdlib/listLabels.cmi stdlib/listLabels.ml stdlib/listLabels.mli \ - stdlib/map.cmi stdlib/map.ml stdlib/map.mli \ - stdlib/marshal.cmi stdlib/marshal.ml stdlib/marshal.mli \ - stdlib/moreLabels.cmi stdlib/moreLabels.ml stdlib/moreLabels.mli \ - stdlib/nativeint.cmi stdlib/nativeint.ml stdlib/nativeint.mli \ - stdlib/obj.cmi stdlib/obj.ml stdlib/obj.mli \ - stdlib/oo.cmi stdlib/oo.ml stdlib/oo.mli \ - stdlib/parsing.cmi stdlib/parsing.ml stdlib/parsing.mli \ - stdlib/pervasives.cmi stdlib/pervasives.ml stdlib/pervasives.mli \ - stdlib/printexc.cmi stdlib/printexc.ml stdlib/printexc.mli \ - stdlib/printf.cmi stdlib/printf.ml stdlib/printf.mli \ - stdlib/queue.cmi stdlib/queue.ml stdlib/queue.mli \ - stdlib/random.cmi stdlib/random.ml stdlib/random.mli \ - stdlib/scanf.cmi stdlib/scanf.ml stdlib/scanf.mli \ - stdlib/sort.cmi stdlib/sort.ml stdlib/sort.mli \ - stdlib/stack.cmi stdlib/stack.ml stdlib/stack.mli \ - stdlib/stdLabels.cmi stdlib/stdLabels.ml stdlib/stdLabels.mli \ - stdlib/stream.cmi stdlib/stream.ml stdlib/stream.mli \ - stdlib/string.cmi stdlib/string.ml stdlib/string.mli \ - stdlib/stringLabels.cmi stdlib/stringLabels.ml stdlib/stringLabels.mli \ - stdlib/sys.cmi stdlib/sys.ml stdlib/sys.mli \ - stdlib/weak.cmi stdlib/weak.ml stdlib/weak.mli \ - stdlib/$set.cmi stdlib/$set.ml stdlib/$set.mli \ - stdlib/arg.cmx stdlib/arg.p.cmx \ - stdlib/array.cmx stdlib/array.p.cmx \ - stdlib/arrayLabels.cmx stdlib/arrayLabels.p.cmx \ - stdlib/buffer.cmx stdlib/buffer.p.cmx \ - stdlib/callback.cmx stdlib/callback.p.cmx \ - stdlib/camlinternalLazy.cmx stdlib/camlinternalLazy.p.cmx \ - stdlib/camlinternalMod.cmx stdlib/camlinternalMod.p.cmx \ - stdlib/camlinternalOO.cmx stdlib/camlinternalOO.p.cmx \ - stdlib/char.cmx stdlib/char.p.cmx \ - stdlib/complex.cmx stdlib/complex.p.cmx \ - stdlib/digest.cmx stdlib/digest.p.cmx \ - stdlib/filename.cmx stdlib/filename.p.cmx \ - stdlib/format.cmx stdlib/format.p.cmx \ - stdlib/gc.cmx stdlib/gc.p.cmx \ - stdlib/genlex.cmx stdlib/genlex.p.cmx \ - stdlib/hashtbl.cmx stdlib/hashtbl.p.cmx \ - stdlib/int32.cmx stdlib/int32.p.cmx \ - stdlib/int64.cmx stdlib/int64.p.cmx \ - stdlib/lazy.cmx stdlib/lazy.p.cmx \ - stdlib/lexing.cmx stdlib/lexing.p.cmx \ - stdlib/list.cmx stdlib/list.p.cmx \ - stdlib/listLabels.cmx stdlib/listLabels.p.cmx \ - stdlib/map.cmx stdlib/map.p.cmx \ - stdlib/marshal.cmx stdlib/marshal.p.cmx \ - stdlib/moreLabels.cmx stdlib/moreLabels.p.cmx \ - stdlib/nativeint.cmx stdlib/nativeint.p.cmx \ - stdlib/obj.cmx stdlib/obj.p.cmx \ - stdlib/oo.cmx stdlib/oo.p.cmx \ - stdlib/parsing.cmx stdlib/parsing.p.cmx \ - stdlib/pervasives.cmx stdlib/pervasives.p.cmx \ - stdlib/printexc.cmx stdlib/printexc.p.cmx \ - stdlib/printf.cmx stdlib/printf.p.cmx \ - stdlib/queue.cmx stdlib/queue.p.cmx \ - stdlib/random.cmx stdlib/random.p.cmx \ - stdlib/scanf.cmx stdlib/scanf.p.cmx \ - stdlib/sort.cmx stdlib/sort.p.cmx \ - stdlib/stack.cmx stdlib/stack.p.cmx \ - stdlib/stdLabels.cmx stdlib/stdLabels.p.cmx \ - stdlib/std_exit.cmx stdlib/std_exit.p.cmx stdlib/std_exit.$O stdlib/std_exit.p.$O \ - stdlib/stream.cmx stdlib/stream.p.cmx \ - stdlib/string.cmx stdlib/string.p.cmx \ - stdlib/stringLabels.cmx stdlib/stringLabels.p.cmx \ - stdlib/sys.cmx stdlib/sys.p.cmx \ - stdlib/weak.cmx stdlib/weak.p.cmx \ - stdlib/$set.cmx stdlib/$set.p.cmx \ - $LIBDIR - -installlibdir \ - stdlib/stdlib.$A stdlib/stdlib.p.$A \ - $LIBDIR - -echo "Installing ocamllex, ocamldebug..." -installbin lex/ocamllex$EXE $BINDIR/ocamllex$EXE -installbin debugger/ocamldebug$EXE $BINDIR/ocamldebug$EXE -installbin lex/ocamllex.opt$EXE $BINDIR/ocamllex.opt$EXE -installbin tools/ocamldep.native$EXE $BINDIR/ocamldep.opt$EXE - -echo "Installing some tools..." -installbin tools/objinfo.byte$EXE $BINDIR/ocamlobjinfo$EXE -installbin ../tools/objinfo_helper$EXE $LIBDIR/objinfo_helper$EXE -installbin tools/ocamlcp.byte$EXE $BINDIR/ocamlcp$EXE -installbin tools/ocamldep.byte$EXE $BINDIR/ocamldep$EXE -installbin tools/ocamlmklib.byte$EXE $BINDIR/ocamlmklib$EXE -installbin tools/ocamlmktop.byte$EXE $BINDIR/ocamlmktop$EXE -installbin tools/ocamlprof.byte$EXE $BINDIR/ocamlprof$EXE -installbin toplevel/expunge.byte$EXE $LIBDIR/expunge$EXE -installbin tools/addlabels.byte $LIBDIR/addlabels -installbin tools/scrapelabels.byte $LIBDIR/scrapelabels -installbin otherlibs/dynlink/extract_crc.byte $LIBDIR/extract_crc -installbin otherlibs/labltk/lib/labltk$EXE $BINDIR/labltk$EXE -installbin otherlibs/labltk/browser/ocamlbrowser$EXE $BINDIR/ocamlbrowser$EXE -installbin otherlibs/labltk/compiler/pp$EXE $LIBDIR/labltk/pp$EXE -installbin otherlibs/labltk/lib/labltktop$EXE $LIBDIR/labltk/labltktop$EXE - -echo "Installing libraries..." -installdir \ - otherlibs/bigarray/bigarray.cma \ - otherlibs/dbm/dbm.cma \ - otherlibs/dynlink/dynlink.cma \ - otherlibs/"$WIN32"graph/graphics.cma \ - otherlibs/num/nums.cma \ - otherlibs/str/str.cma \ - otherlibs/"$WIN32"unix/unix.cma \ - otherlibs/bigarray/bigarray.cmxa \ - otherlibs/dbm/dbm.cmxa \ - otherlibs/dynlink/dynlink.cmxa \ - otherlibs/"$WIN32"graph/graphics.cmxa \ - otherlibs/num/nums.cmxa \ - otherlibs/str/str.cmxa \ - otherlibs/"$WIN32"unix/unix.cmxa \ - toplevel/toplevellib.cma \ - otherlibs/systhreads/thread.mli \ - otherlibs/systhreads/mutex.mli \ - otherlibs/systhreads/condition.mli \ - otherlibs/systhreads/event.mli \ - otherlibs/systhreads/threadUnix.mli \ - $LIBDIR - -installdir \ - otherlibs/labltk/support/fileevent.mli \ - otherlibs/labltk/support/fileevent.cmi \ - otherlibs/labltk/support/fileevent.cmx \ - otherlibs/labltk/support/protocol.mli \ - otherlibs/labltk/support/protocol.cmi \ - otherlibs/labltk/support/protocol.cmx \ - otherlibs/labltk/support/textvariable.mli \ - otherlibs/labltk/support/textvariable.cmi \ - otherlibs/labltk/support/textvariable.cmx \ - otherlibs/labltk/support/timer.mli \ - otherlibs/labltk/support/timer.cmi \ - otherlibs/labltk/support/timer.cmx \ - otherlibs/labltk/support/rawwidget.mli \ - otherlibs/labltk/support/rawwidget.cmi \ - otherlibs/labltk/support/rawwidget.cmx \ - otherlibs/labltk/support/widget.mli \ - otherlibs/labltk/support/widget.cmi \ - otherlibs/labltk/support/widget.cmx \ - otherlibs/labltk/support/tkthread.mli \ - otherlibs/labltk/support/tkthread.cmi \ - otherlibs/labltk/support/tkthread.cmo \ - otherlibs/labltk/support/tkthread.$O \ - otherlibs/labltk/support/tkthread.cmx \ - otherlibs/labltk/labltk/[^_]*.mli \ - otherlibs/labltk/labltk/*.cmi \ - otherlibs/labltk/labltk/*.cmx \ - otherlibs/labltk/camltk/[^_]*.mli \ - otherlibs/labltk/camltk/*.cmi \ - otherlibs/labltk/camltk/*.cmx \ - otherlibs/labltk/frx/frxlib.cma \ - otherlibs/labltk/frx/frxlib.cmxa \ - ../otherlibs/labltk/frx/*.mli \ - otherlibs/labltk/frx/*.cmi \ - otherlibs/labltk/jpf/jpflib.cma \ - otherlibs/labltk/jpf/jpflib.cmxa \ - otherlibs/labltk/jpf/*.mli \ - otherlibs/labltk/jpf/*.cmi \ - otherlibs/labltk/jpf/*.cmx \ - otherlibs/labltk/lib/labltk.cma \ - otherlibs/labltk/lib/labltk.cmxa \ - otherlibs/labltk/lib/labltk.cmx \ - otherlibs/labltk/compiler/tkcompiler \ - $LIBDIR/labltk - -installdir \ - otherlibs/systhreads/threads.cma \ - otherlibs/systhreads/threads.cmxa \ - otherlibs/systhreads/thread.cmi \ - otherlibs/systhreads/thread.cmx \ - otherlibs/systhreads/mutex.cmi \ - otherlibs/systhreads/mutex.cmx \ - otherlibs/systhreads/condition.cmi \ - otherlibs/systhreads/condition.cmx \ - otherlibs/systhreads/event.cmi \ - otherlibs/systhreads/event.cmx \ - otherlibs/systhreads/threadUnix.cmi \ - otherlibs/systhreads/threadUnix.cmx \ - $LIBDIR/threads - -installdir \ - otherlibs/bigarray/dllbigarray$EXT_DLL \ - otherlibs/dbm/dllmldbm$EXT_DLL \ - otherlibs/"$WIN32"graph/dllgraphics$EXT_DLL \ - otherlibs/num/dllnums$EXT_DLL \ - otherlibs/str/dllstr$EXT_DLL \ - otherlibs/systhreads/dllthreads$EXT_DLL \ - otherlibs/"$WIN32"unix/dllunix$EXT_DLL \ - otherlibs/threads/dllvmthreads$EXT_DLL \ - otherlibs/labltk/support/dlllabltk$EXT_DLL \ - $STUBLIBDIR - -installlibdir \ - otherlibs/threads/libvmthreads.$A \ - $LIBDIR/vmthreads - -installdir \ - otherlibs/threads/thread.cmi \ - otherlibs/threads/thread.mli \ - otherlibs/threads/mutex.cmi \ - otherlibs/threads/mutex.mli \ - otherlibs/threads/condition.cmi \ - otherlibs/threads/condition.mli \ - otherlibs/threads/event.cmi \ - otherlibs/threads/event.mli \ - otherlibs/threads/threadUnix.cmi \ - otherlibs/threads/threadUnix.mli \ - otherlibs/threads/threads.cma \ - otherlibs/threads/stdlib.cma \ - otherlibs/threads/unix.cma \ - $LIBDIR/vmthreads - -installlibdir \ - otherlibs/labltk/support/liblabltk.$A \ - otherlibs/labltk/lib/labltk.$A \ - otherlibs/labltk/jpf/jpflib.$A \ - otherlibs/labltk/frx/frxlib.$A \ - $LIBDIR/labltk - -installlibdir \ - otherlibs/bigarray/libbigarray.$A \ - otherlibs/dbm/libmldbm.$A \ - otherlibs/"$WIN32"graph/libgraphics.$A \ - otherlibs/num/libnums.$A \ - otherlibs/str/libstr.$A \ - otherlibs/systhreads/libthreads.$A \ - otherlibs/systhreads/libthreadsnat.$A \ - otherlibs/"$WIN32"unix/libunix.$A \ - $LIBDIR - -echo "Installing object files and interfaces..." -installdir \ - tools/profiling.cm[oi] \ - toplevel/topstart.cmo \ - toplevel/toploop.cmi \ - toplevel/topdirs.cmi \ - toplevel/topmain.cmi \ - typing/outcometree.cmi \ - typing/outcometree.mli \ - otherlibs/graph/graphicsX11.cmi \ - otherlibs/graph/graphicsX11.mli \ - otherlibs/dynlink/dynlink.cmi \ - otherlibs/dynlink/dynlink.mli \ - otherlibs/num/arith_status.cmi \ - otherlibs/num/arith_status.mli \ - otherlibs/num/big_int.cmi \ - otherlibs/num/big_int.mli \ - otherlibs/num/nat.cmi \ - otherlibs/num/nat.mli \ - otherlibs/num/num.cmi \ - otherlibs/num/num.mli \ - otherlibs/num/ratio.cmi \ - otherlibs/num/ratio.mli \ - otherlibs/bigarray/bigarray.cmi \ - otherlibs/bigarray/bigarray.mli \ - otherlibs/dbm/dbm.cmi \ - otherlibs/dbm/dbm.mli \ - otherlibs/dynlink/dynlink.cmx \ - otherlibs/"$WIN32"graph/graphics.cmi \ - otherlibs/"$WIN32"graph/graphics.mli \ - otherlibs/str/str.cmi \ - otherlibs/str/str.mli \ - otherlibs/"$WIN32"unix/unix.cmi \ - otherlibs/"$WIN32"unix/unix.mli \ - otherlibs/"$WIN32"unix/unixLabels.cmi \ - otherlibs/"$WIN32"unix/unixLabels.mli \ - otherlibs/num/arith_flags.cmx \ - otherlibs/num/int_misc.cmx \ - otherlibs/num/arith_status.cmx \ - otherlibs/num/big_int.cmx \ - otherlibs/num/nat.cmx \ - otherlibs/num/num.cmx \ - otherlibs/num/ratio.cmx \ - otherlibs/bigarray/bigarray.cmx \ - otherlibs/dbm/dbm.cmx \ - otherlibs/"$WIN32"graph/graphics.cmx \ - otherlibs/graph/graphicsX11.cmx \ - otherlibs/str/str.cmx \ - otherlibs/"$WIN32"unix/unix.cmx \ - otherlibs/"$WIN32"unix/unixLabels.cmx \ - $LIBDIR - -installlibdir \ - otherlibs/bigarray/bigarray.$A \ - otherlibs/dbm/dbm.$A \ - otherlibs/dynlink/dynlink.$A \ - otherlibs/"$WIN32"graph/graphics.$A \ - otherlibs/num/nums.$A \ - otherlibs/str/str.$A \ - otherlibs/"$WIN32"unix/unix.$A \ - stdlib/stdlib.$A \ - $LIBDIR - -installlibdir \ - otherlibs/systhreads/threads.$A \ - $LIBDIR/threads - -echo "Installing manuals..." -(cd ../man && make install) - -echo "Installing ocamldoc..." -installbin ocamldoc/ocamldoc $BINDIR/ocamldoc$EXE -installbin ocamldoc/ocamldoc.opt $BINDIR/ocamldoc.opt$EXE - -installdir \ - ../ocamldoc/ocamldoc.hva \ - ocamldoc/*.cmi \ - ocamldoc/odoc_info.mli ocamldoc/odoc_info.cm[ia] ocamldoc/odoc_info.cmxa \ - ocamldoc/odoc_info.$A \ - $LIBDIR/ocamldoc - -installdir \ - ocamldoc/stdlib_man/* \ - $MANDIR/man3 - -echo "Installing camlp4..." -installbin camlp4/camlp4prof.byte$EXE $BINDIR/camlp4prof$EXE -installbin camlp4/mkcamlp4.byte$EXE $BINDIR/mkcamlp4$EXE -installbin camlp4/camlp4.byte$EXE $BINDIR/camlp4$EXE -installbin camlp4/camlp4boot.byte$EXE $BINDIR/camlp4boot$EXE -installbin camlp4/camlp4o.byte$EXE $BINDIR/camlp4o$EXE -installbin camlp4/camlp4of.byte$EXE $BINDIR/camlp4of$EXE -installbin camlp4/camlp4oof.byte$EXE $BINDIR/camlp4oof$EXE -installbin camlp4/camlp4orf.byte$EXE $BINDIR/camlp4orf$EXE -installbin camlp4/camlp4r.byte$EXE $BINDIR/camlp4r$EXE -installbin camlp4/camlp4rf.byte$EXE $BINDIR/camlp4rf$EXE -installbin camlp4/camlp4o.native$EXE $BINDIR/camlp4o.opt$EXE -installbin camlp4/camlp4of.native$EXE $BINDIR/camlp4of.opt$EXE -installbin camlp4/camlp4oof.native$EXE $BINDIR/camlp4oof.opt$EXE -installbin camlp4/camlp4orf.native$EXE $BINDIR/camlp4orf.opt$EXE -installbin camlp4/camlp4r.native$EXE $BINDIR/camlp4r.opt$EXE -installbin camlp4/camlp4rf.native$EXE $BINDIR/camlp4rf.opt$EXE - -cd camlp4 -CAMLP4DIR=$LIBDIR/camlp4 -for dir in Camlp4Parsers Camlp4Printers Camlp4Filters Camlp4Top; do - echo "Installing $dir..." - mkdir -p $CAMLP4DIR/$dir - installdir \ - $dir/*.cm* \ - $dir/*.$O \ - $CAMLP4DIR/$dir -done -installdir \ - camlp4lib.cma camlp4lib.cmxa Camlp4.cmi \ - camlp4fulllib.cma camlp4fulllib.cmxa \ - 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_import.cmi \ - $CAMLP4DIR -installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR -cd .. - -echo "Installing ocamlbuild..." - -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 \ - ocamlbuildlib.$A \ - $LIBDIR/ocamlbuild - -installdir \ - ocamlbuildlib.cmxa \ - ocamlbuildlib.cma \ - ocamlbuild_plugin.cmi \ - ocamlbuild_plugin.cmo \ - ocamlbuild_plugin.cmx \ - 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 \ - $MANDIR/man1 diff -Nru ocaml-4.01.0/build/mixed-boot.sh ocaml-4.02.3/build/mixed-boot.sh --- ocaml-4.01.0/build/mixed-boot.sh 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/build/mixed-boot.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,22 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -ex -cd `dirname $0`/.. -touch build/ocamlbuild_mixed_mode -mkdir -p _build -cp -rf boot _build/ -./build/mkconfig.sh -./build/mkmyocamlbuild_config.sh -./build/boot.sh diff -Nru ocaml-4.01.0/build/mkconfig.sh ocaml-4.02.3/build/mkconfig.sh --- ocaml-4.01.0/build/mkconfig.sh 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/build/mkconfig.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,27 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. - -sed -e 's/^\(.*\$([0-9]).*\)$/# \1/' \ - -e 's/\$(\([^)]*\))/${\1}/g' \ - -e 's/^FLEX.*$//g' \ - -e 's/^\([^#=]*\)=\([^"]*\)$/if [ "x$\1" = "x" ]; then \1="\2"; fi/' \ - config/Makefile > config/config.sh - -if [ "x$EXE" = "x.exe" -a "x$SYSTEM" != "xcygwin" ]; then - echo "WINDOWS=true" >> config/config.sh -else - echo "WINDOWS=false" >> config/config.sh -fi diff -Nru ocaml-4.01.0/build/mkmyocamlbuild_config.sh ocaml-4.02.3/build/mkmyocamlbuild_config.sh --- ocaml-4.01.0/build/mkmyocamlbuild_config.sh 2013-05-17 14:03:58.000000000 +0200 +++ ocaml-4.02.3/build/mkmyocamlbuild_config.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,40 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. - -sed \ - -e 's/^.*FLEXDIR.*$//g' \ - -e '/^SET_LD_PATH/d' \ - -e 's/^#ml \(.*\)/\1/' \ - -e 's/^\([^"][^"]*\("[^"]*"[^"]*\)*\)#.*$/\1/' \ - -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 myocamlbuild_config.ml diff -Nru ocaml-4.01.0/build/mkruntimedef.sh ocaml-4.02.3/build/mkruntimedef.sh --- ocaml-4.01.0/build/mkruntimedef.sh 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/build/mkruntimedef.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,21 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -echo 'let builtin_exceptions = [|'; \ -sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$| \1;|p' byterun/fail.h | \ -sed -e '$s/;$//'; \ -echo '|]'; \ -echo 'let builtin_primitives = [|'; \ -sed -e 's/.*/ "&";/' -e '$s/;$//' byterun/primitives; \ -echo '|]' diff -Nru ocaml-4.01.0/build/myocamlbuild.sh ocaml-4.02.3/build/myocamlbuild.sh --- ocaml-4.01.0/build/myocamlbuild.sh 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/build/myocamlbuild.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,31 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0`/.. -set -xe -if [ ! -x _build/ocamlbuild/ocamlbuildlight.byte ]; then - if [ ! -x ocamlbuild/_build/ocamlbuildlight.byte ]; then - (cd ocamlbuild && ${GNUMAKE:-make}) - fi - mkdir -p _build/ocamlbuild - for i in "light.cmo" "light.byte" "lightlib.cma" "_plugin.cmi" "_pack.cmi" - do - cp ocamlbuild/_build/ocamlbuild$i _build/ocamlbuild - done -fi -rm -f ocamlbuild/myocamlbuild_config.ml ocamlbuild/myocamlbuild_config.mli -rm -rf _build/myocamlbuild boot/myocamlbuild boot/myocamlbuild.native -./boot/ocamlrun _build/ocamlbuild/ocamlbuildlight.byte -no-hygiene \ - -tag debug -install-lib-dir _build/ocamlbuild -byte-plugin -just-plugin -cp _build/myocamlbuild boot/myocamlbuild.boot diff -Nru ocaml-4.01.0/build/new-build-system ocaml-4.02.3/build/new-build-system --- ocaml-4.01.0/build/new-build-system 2012-08-02 10:17:59.000000000 +0200 +++ ocaml-4.02.3/build/new-build-system 1970-01-01 01:00:00.000000000 +0100 @@ -1,52 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -_tags # Defines tags to setup exceptions -myocamlbuild.ml # Contains all needed rules that are differents -boot/ocamldep -myocamlbuild_config.mli -utils/config.mlbuild # Should be renamed as utils/config.ml - -# Files that just contain module names of object files. -**/*.mllib # Files that describe the contents of an OCaml library -**/*.mlpack # Files that describe the contents of an OCaml package -**/*.cilb # Files that describe the contents of an C static library -**/*.dilb # Files that describe the contents of an C dynamic library - -build/ - world.sh # Build all the OCaml world - world.byte.sh # Build the bytecode world - world.native.sh # Build the native world - world.all.sh # Build all the world the don't bootstrap - fastworld.sh # Same as above but faster - boot-c-parts.sh # Compile byterun, ocamlyacc and asmrun with the Makefiles - boot.sh # Compile the stdlib and ocamlc - camlp4-targets.sh # Setup camlp4 targets - otherlibs-targets.sh # Setup otherlibs targets - targets.sh # All targets of the OCaml distribution - - - install.sh # Install all needed files - distclean.sh # Clean all generated files - - myocamlbuild.sh # Regenerate the boot/myocamlbuild program - mkconfig.sh # Generate config/config.sh - mkmyocamlbuild_config.sh # Generate myocamlbuild_config.ml - - camlp4-bootstrap.sh - - # Partial stuffs (just camlp4 and ocamlbuild) - mixed-boot.sh - camlp4-byte-only.sh - camlp4-native-only.sh - ocamlbuild-byte-only.sh - ocamlbuild-native-only.sh diff -Nru ocaml-4.01.0/build/ocamlbuild-byte-only.sh ocaml-4.02.3/build/ocamlbuild-byte-only.sh --- ocaml-4.01.0/build/ocamlbuild-byte-only.sh 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/build/ocamlbuild-byte-only.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,19 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ byte_stdlib_mixed_mode $OCAMLC_BYTE $OCAMLLEX_BYTE $OCAMLBUILD_BYTE diff -Nru ocaml-4.01.0/build/ocamlbuildlib-native-only.sh ocaml-4.02.3/build/ocamlbuildlib-native-only.sh --- ocaml-4.01.0/build/ocamlbuildlib-native-only.sh 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/build/ocamlbuildlib-native-only.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,19 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ native_stdlib_mixed_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $OCAMLBUILDLIB_NATIVE diff -Nru ocaml-4.01.0/build/ocamlbuild-native-only.sh ocaml-4.02.3/build/ocamlbuild-native-only.sh --- ocaml-4.01.0/build/ocamlbuild-native-only.sh 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/build/ocamlbuild-native-only.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,19 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ native_stdlib_mixed_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $OCAMLBUILD_NATIVE diff -Nru ocaml-4.01.0/build/otherlibs-targets.sh ocaml-4.02.3/build/otherlibs-targets.sh --- ocaml-4.01.0/build/otherlibs-targets.sh 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/build/otherlibs-targets.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,120 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -OTHERLIBS_BYTE="" -OTHERLIBS_NATIVE="" -OTHERLIBS_UNIX_NATIVE="" -UNIXDIR="otherlibs/unix" - -add_native() { - for native_file in $@; do - OTHERLIBS_NATIVE="$OTHERLIBS_NATIVE otherlibs/$lib/$native_file" - case $lib in - unix|win32unix) - OTHERLIBS_UNIX_NATIVE="$OTHERLIBS_UNIX_NATIVE otherlibs/$lib/$native_file";; - esac - done -} - -add_byte() { - for byte_file in $@; do - OTHERLIBS_BYTE="$OTHERLIBS_BYTE otherlibs/$lib/$byte_file" - done -} - -add_file() { - add_byte $@ - add_native $@ -} - -add_bin() { - for bin_file in $@; do - add_byte $bin_file.byte$EXE - add_native $bin_file.native$EXE - done -} - -add_c_lib() { - add_file "lib$1.$A" -} - -add_ocaml_lib() { - add_native "$1.cmxa" - add_native "$1.$A" - add_byte "$1.cma" -} - -add_dll() { - add_file "dll$1$EXT_DLL" -} - -add() { - add_c_lib $1 - add_ocaml_lib $1 - add_dll $1 -} - -THREADS_CMIS="thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi" - -for lib in $OTHERLIBRARIES; do - case $lib in - num) - add nums;; - systhreads) - add_ocaml_lib threads - add_dll threads - add_file $THREADS_CMIS - add_byte libthreads.$A - add_native libthreadsnat.$A;; - graph|win32graph) - add graphics;; - threads) - add_byte pervasives.cmi pervasives.mli \ - $THREADS_CMIS marshal.cmi marshal.mli \ - stdlib.cma unix.cma threads.cma libvmthreads.$A;; - labltk) - add_file support/camltk.h - add_byte support/byte.otarget - add_native support/native.otarget - add_file support/liblabltk.$A - add_byte compiler/tkcompiler$EXE compiler/pp$EXE - add_file labltk/tk.ml labltk/labltk.ml - add_byte labltk/byte.otarget - add_native labltk/native.otarget - add_byte camltk/byte.otarget - add_native camltk/native.otarget - add_ocaml_lib lib/labltk - add_byte lib/labltktop$EXE lib/labltk$EXE - add_ocaml_lib jpf/jpflib - add_ocaml_lib frx/frxlib - add_byte browser/ocamlbrowser$EXE - ;; - dbm) - add_ocaml_lib dbm - add_c_lib mldbm;; - dynlink) - add_ocaml_lib dynlink - add_native dynlink.cmx dynlink.$O - add_file $lib.cmi extract_crc;; - win32unix) - UNIXDIR="otherlibs/win32unix" - add_file unixsupport.h cst2constr.h socketaddr.h - add unix;; - unix) - add_file unixsupport.h - add unix;; - *) - add $lib - esac -done diff -Nru ocaml-4.01.0/build/partial-install.sh ocaml-4.02.3/build/partial-install.sh --- ocaml-4.01.0/build/partial-install.sh 2013-01-01 05:53:49.000000000 +0100 +++ ocaml-4.02.3/build/partial-install.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,188 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -###################################### -######### Copied from build/install.sh -###################################### - -set -e - -cd `dirname $0`/.. - -. config/config.sh - -not_installed=$PWD/_build/not_installed - -rm -f "$not_installed" -touch "$not_installed" - -wontinstall() { - echo "$1" >> "$not_installed" - echo " don't install $1" -} - -installbin() { - if [ -f "$1" ]; then - echo " install binary $2" - cp -f "$1" "$2" - [ -x "$2" ] || chmod +x "$2" - else - wontinstall "$1" - fi -} - -installbestbin() { - if [ -f "$1" ]; then - echo " install binary $3 (with `basename $1`)" - cp -f "$1" "$3" - else - if [ -f "$2" ]; then - echo " install binary $3 (with `basename $2`)" - cp -f "$2" "$3" - else - echo "None of $1, $2 exists" - exit 3 - fi - fi - [ -x "$3" ] || chmod +x "$3" -} - -installlib() { - if [ -f "$1" ]; then - dest="$2/`basename $1`" - echo " install library $dest" - cp -f "$1" "$2" - if [ "$RANLIB" != "" ]; then - "$RANLIB" "$dest" - fi - else - wontinstall "$1" - fi -} - -installdir() { - args="" - while [ $# -gt 1 ]; do - if [ -f "$1" ]; then - args="$args $1" - else - wontinstall "$1" - fi - shift - done - last="$1" - for file in $args; do - echo " install $last/`basename $file`" - cp -f "$file" "$last" - done -} - -installlibdir() { - args="" - while [ $# -gt 1 ]; do - args="$args $1" - shift - done - last="$1" - for file in $args; do - installlib "$file" "$last" - done -} - -mkdir -p $BINDIR -mkdir -p $LIBDIR -mkdir -p $LIBDIR/camlp4 -mkdir -p $LIBDIR/ocamlbuild -mkdir -p $STUBLIBDIR -mkdir -p $MANDIR/man1 -mkdir -p $MANDIR/man3 -mkdir -p $MANDIR/man$MANEXT - -cd _build - -echo "Installing camlp4..." -installbin camlp4/camlp4prof.byte$EXE $BINDIR/camlp4prof$EXE -installbin camlp4/mkcamlp4.byte$EXE $BINDIR/mkcamlp4$EXE -installbin camlp4/camlp4.byte$EXE $BINDIR/camlp4$EXE -installbin camlp4/camlp4boot.byte$EXE $BINDIR/camlp4boot$EXE -installbin camlp4/camlp4o.byte$EXE $BINDIR/camlp4o$EXE -installbin camlp4/camlp4of.byte$EXE $BINDIR/camlp4of$EXE -installbin camlp4/camlp4oof.byte$EXE $BINDIR/camlp4oof$EXE -installbin camlp4/camlp4orf.byte$EXE $BINDIR/camlp4orf$EXE -installbin camlp4/camlp4r.byte$EXE $BINDIR/camlp4r$EXE -installbin camlp4/camlp4rf.byte$EXE $BINDIR/camlp4rf$EXE -installbin camlp4/camlp4o.native$EXE $BINDIR/camlp4o.opt$EXE -installbin camlp4/camlp4of.native$EXE $BINDIR/camlp4of.opt$EXE -installbin camlp4/camlp4oof.native$EXE $BINDIR/camlp4oof.opt$EXE -installbin camlp4/camlp4orf.native$EXE $BINDIR/camlp4orf.opt$EXE -installbin camlp4/camlp4r.native$EXE $BINDIR/camlp4r.opt$EXE -installbin camlp4/camlp4rf.native$EXE $BINDIR/camlp4rf.opt$EXE - -if test -d camlp4; then - cd camlp4 - CAMLP4DIR=$LIBDIR/camlp4 - for dir in Camlp4Parsers Camlp4Printers Camlp4Filters Camlp4Top; do - echo "Installing $dir..." - mkdir -p $CAMLP4DIR/$dir - installdir \ - $dir/*.cm* \ - $dir/*.$O \ - $CAMLP4DIR/$dir - done - installdir \ - camlp4lib.cma camlp4lib.cmxa Camlp4.cmi \ - camlp4fulllib.cma camlp4fulllib.cmxa \ - 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_import.cmi \ - $CAMLP4DIR - installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR - cd .. -fi - -echo "Installing ocamlbuild..." -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 \ - ocamlbuildlib.$A \ - $LIBDIR/ocamlbuild - -installdir \ - ocamlbuildlib.cmxa \ - ocamlbuildlib.cma \ - ocamlbuild_plugin.cmi \ - ocamlbuild_plugin.cmo \ - ocamlbuild_plugin.cmx \ - 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 \ - $MANDIR/man1 diff -Nru ocaml-4.01.0/build/targets.sh ocaml-4.02.3/build/targets.sh --- ocaml-4.01.0/build/targets.sh 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/build/targets.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,62 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -. config/config.sh -. build/otherlibs-targets.sh -. build/camlp4-targets.sh - -INSTALL_BIN="$BINDIR" -export INSTALL_BIN - -STDLIB_BYTE="stdlib/libcamlrun.$A stdlib/stdlib.cma \ - stdlib/std_exit.cmo stdlib/camlheader stdlib/camlheader_ur" -OCAMLLEX_BYTE=lex/ocamllex$EXE -OCAMLC_BYTE=ocamlc$EXE -OCAMLOPT_BYTE=ocamlopt$EXE -OCAMLBUILD_BYTE="ocamlbuild/ocamlbuildlib.cma \ - ocamlbuild/ocamlbuildlightlib.cma \ - ocamlbuild/ocamlbuild.byte$EXE \ - ocamlbuild/ocamlbuildlight.byte$EXE" -TOPLEVEL=ocaml$EXE -TOOLS_BYTE="tools/objinfo.byte$EXE \ - tools/ocamldep.byte$EXE tools/profiling.cmo \ - tools/ocamlprof.byte$EXE tools/ocamlcp.byte$EXE \ - tools/ocamlmktop.byte$EXE tools/ocamlmklib$EXE \ - tools/scrapelabels.byte tools/addlabels.byte \ - tools/dumpobj.byte$EXE" -if [ ! -z "$DEBUGGER" ]; then - DEBUGGER=debugger/ocamldebug$EXE -fi -OCAMLDOC_BYTE="ocamldoc/ocamldoc$EXE ocamldoc/odoc_info.cma" -STDLIB_NATIVE="stdlib/stdlib.cmxa stdlib/std_exit.cmx asmrun/libasmrun.$A" -case $PROFILING in -prof) - STDLIB_NATIVE="$STDLIB_NATIVE asmrun/libasmrunp.$A \ - stdlib/stdlib.p.cmxa stdlib/std_exit.p.cmx";; -noprof) ;; -*) echo "unexpected PROFILING value $PROFILING"; exit 1;; -esac -OCAMLC_NATIVE=ocamlc.opt$EXE -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" -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 - OCAMLBUILD=./boot/myocamlbuild.native -else - OCAMLBUILD="./boot/ocamlrun boot/myocamlbuild" -fi diff -Nru ocaml-4.01.0/build/tolower.sed ocaml-4.02.3/build/tolower.sed --- ocaml-4.01.0/build/tolower.sed 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/build/tolower.sed 1970-01-01 01:00:00.000000000 +0100 @@ -1,23 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# tolower.sed expands one ...<:lower>... to ...foo... per line -h -s/.*<:lower<\(.*\)>>.*/\1/ -t cont -b end -:cont -y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ -s/$/|/ -G -s/\(.*\)|\n\(.*\)<:lower<\(.*\)>>/\2\1/ -:end diff -Nru ocaml-4.01.0/build/world.all.sh ocaml-4.02.3/build/world.all.sh --- ocaml-4.01.0/build/world.all.sh 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/build/world.all.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,24 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ \ - $STDLIB_BYTE $OCAMLC_BYTE $OCAMLLEX_BYTE $OCAMLOPT_BYTE $TOPLEVEL \ - $TOOLS_BYTE $OTHERLIBS_BYTE $OCAMLBUILD_BYTE $DEBUGGER $OCAMLDOC_BYTE \ - $CAMLP4_BYTE $STDLIB_NATIVE $OCAMLC_NATIVE $OCAMLOPT_NATIVE \ - $OCAMLLEX_NATIVE $TOOLS_NATIVE $OTHERLIBS_NATIVE \ - $OCAMLBUILD_NATIVE $OCAMLDOC_NATIVE $CAMLP4_NATIVE diff -Nru ocaml-4.01.0/build/world.byte.sh ocaml-4.02.3/build/world.byte.sh --- ocaml-4.01.0/build/world.byte.sh 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/build/world.byte.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,21 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ \ - $STDLIB_BYTE $OCAMLC_BYTE $OCAMLLEX_BYTE $OCAMLOPT_BYTE $TOPLEVEL $TOOLS_BYTE \ - $OTHERLIBS_BYTE $OCAMLBUILD_BYTE $DEBUGGER $OCAMLDOC_BYTE $CAMLP4_BYTE diff -Nru ocaml-4.01.0/build/world.native.sh ocaml-4.02.3/build/world.native.sh --- ocaml-4.01.0/build/world.native.sh 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/build/world.native.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,22 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -set -e -cd `dirname $0`/.. -. build/targets.sh -set -x -$OCAMLBUILD $@ \ - $STDLIB_NATIVE $OCAMLC_NATIVE $OCAMLOPT_NATIVE \ - $OCAMLLEX_NATIVE $TOOLS_NATIVE $OTHERLIBS_NATIVE \ - $OCAMLBUILD_NATIVE $OCAMLDOC_NATIVE $CAMLP4_NATIVE diff -Nru ocaml-4.01.0/build/world.sh ocaml-4.02.3/build/world.sh --- ocaml-4.01.0/build/world.sh 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/build/world.sh 1970-01-01 01:00:00.000000000 +0100 @@ -1,35 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2008 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -cd `dirname $0` -set -e -if [ -e ocamlbuild_mixed_mode ]; then - echo ocamlbuild mixed mode detected - echo 'please cleanup and re-launch (make clean ; ./build/distclean.sh)' - exit 1 -fi -case "$1" in - all|a|al) mode=all;; - byte|b|by|byt) mode=byte;; - native|na|nat|nati|nativ) mode=native;; - *) echo 'Unexpected target. Expected targets are: all,byte,native' \ - >/dev/stderr - exit 1;; -esac -shift -./mkconfig.sh -./mkmyocamlbuild_config.sh -./boot-c-parts.sh -./boot.sh "$@" -./world."$mode".sh "$@" diff -Nru ocaml-4.01.0/bytecomp/bytegen.ml ocaml-4.02.3/bytecomp/bytegen.ml --- ocaml-4.01.0/bytecomp/bytegen.ml 2012-11-29 10:55:00.000000000 +0100 +++ ocaml-4.02.3/bytecomp/bytegen.ml 2015-07-20 16:04:29.000000000 +0200 @@ -74,7 +74,7 @@ match cont with (Kbranch _ as branch) :: _ -> (branch, cont) | (Kreturn _ as return) :: _ -> (return, cont) - | Kraise :: _ -> (Kraise, cont) + | Kraise k :: _ -> (Kraise k, cont) | Klabel lbl :: _ -> make_branch_2 (Some lbl) 0 cont cont | _ -> make_branch_2 (None) 0 cont cont @@ -108,7 +108,7 @@ match cont with Kpop m :: cont -> add_pop (n + m) cont | Kreturn m :: cont -> Kreturn(n + m) :: cont - | Kraise :: _ -> cont + | Kraise _ :: _ -> cont | _ -> Kpop n :: cont (* Add the constant "unit" in front of a continuation *) @@ -128,6 +128,7 @@ | RHS_block of int | RHS_floatblock of int | RHS_nonrec + | RHS_function of int * int ;; let rec check_recordwith_updates id e = @@ -140,7 +141,7 @@ let rec size_of_lambda = function | Lfunction(kind, params, body) as funct -> - RHS_block (1 + IdentSet.cardinal(free_variables funct)) + RHS_function (1 + IdentSet.cardinal(free_variables funct), List.length params) | Llet (Strict, id, Lprim (Pduprecord (kind, size), _), body) when check_recordwith_updates id body -> begin match kind with @@ -233,9 +234,15 @@ (**** Compilation of a lambda expression ****) -(* association staticraise numbers -> (lbl,size of stack *) +let try_blocks = ref [] (* list of stack size for each nested try block *) + +(* association staticraise numbers -> (lbl,size of stack, try_blocks *) let sz_static_raises = ref [] + +let push_static_raise i lbl_handler sz = + sz_static_raises := (i, (lbl_handler, sz, !try_blocks)) :: !sz_static_raises + let find_raise_label i = try List.assoc i !sz_static_raises @@ -247,8 +254,8 @@ (* Will the translation of l lead to a jump to label ? *) let code_as_jump l sz = match l with | Lstaticraise (i,[]) -> - let label,size = find_raise_label i in - if sz = size then + let label,size,tb = find_raise_label i in + if sz = size && tb == !try_blocks then Some label else None @@ -275,6 +282,10 @@ let max_stack_used = ref 0 + +(* Sequence of string tests *) + + (* Translate a primitive to a bytecode instruction (possibly a call to a C function) *) @@ -397,10 +408,15 @@ | Pbigstring_set_64(_) -> Kccall("caml_ba_uint8_set64", 3) | Pbswap16 -> Kccall("caml_bswap16", 1) | Pbbswap(bi) -> comp_bint_primitive bi "bswap" args + | Pint_as_pointer -> Kccall("caml_int_as_pointer", 1) | _ -> fatal_error "Bytegen.comp_primitive" let is_immed n = immed_min <= n && n <= immed_max +module Storer = + Switch.Store + (struct type t = lambda type key = lambda + let make_key = Lambda.make_key end) (* Compile an expression. The value of the expression is left in the accumulator. @@ -426,7 +442,6 @@ let ofs = Ident.find_same id env.ce_rec in Koffsetclosure(ofs) :: cont with Not_found -> - Format.eprintf "%a@." Ident.print id; fatal_error ("Bytegen.comp_expr: var " ^ Ident.unique_name id) end | Lconst cst -> @@ -520,19 +535,25 @@ Kconst(Const_base(Const_int blocksize)) :: Kccall("caml_alloc_dummy", 1) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem + | (id, exp, RHS_function (blocksize,arity)) :: rem -> + Kconst(Const_base(Const_int arity)) :: + Kpush :: + Kconst(Const_base(Const_int blocksize)) :: + Kccall("caml_alloc_dummy_function", 2) :: Kpush :: + comp_init (add_var id (sz+1) new_env) (sz+1) rem | (id, exp, RHS_nonrec) :: rem -> Kconst(Const_base(Const_int 0)) :: Kpush :: comp_init (add_var id (sz+1) new_env) (sz+1) rem and comp_nonrec new_env sz i = function | [] -> comp_rec new_env sz ndecl decl_size - | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> + | (id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) :: rem -> comp_nonrec new_env sz (i-1) rem | (id, exp, RHS_nonrec) :: rem -> comp_expr new_env exp sz (Kassign (i-1) :: comp_nonrec new_env sz (i-1) rem) and comp_rec new_env sz i = function | [] -> comp_expr new_env body sz (add_pop ndecl cont) - | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> + | (id, exp, (RHS_block _ | RHS_floatblock _ | RHS_function _)) :: rem -> comp_expr new_env exp sz (Kpush :: Kacc i :: Kccall("caml_update_dummy", 2) :: comp_rec new_env sz (i-1) rem) @@ -584,8 +605,8 @@ comp_expr env exp1 sz (Kstrictbranchif lbl :: comp_expr env exp2 sz cont1) end - | Lprim(Praise, [arg]) -> - comp_expr env arg sz (Kraise :: discard_dead_code cont) + | Lprim(Praise k, [arg]) -> + comp_expr env arg sz (Kraise k :: discard_dead_code cont) | Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))]) when is_immed n -> comp_expr env arg sz (Koffsetint n :: cont) @@ -618,7 +639,7 @@ comp_args env args sz (comp_primitive p args :: cont) | Lprim(p, args) -> comp_args env args sz (comp_primitive p args :: cont) - | Lstaticcatch (body, (i, vars) , handler) -> + | Lstaticcatch (body, (i, vars) , handler) -> let nvars = List.length vars in let branch1, cont1 = make_branch cont in let r = @@ -628,8 +649,7 @@ (comp_expr (add_vars vars (sz+1) env) handler (sz+nvars) (add_pop nvars cont1)) in - sz_static_raises := - (i, (lbl_handler, sz+nvars)) :: !sz_static_raises ; + push_static_raise i lbl_handler (sz+nvars); push_dummies nvars (comp_expr env body (sz+nvars) (add_pop nvars (branch1 :: cont2))) @@ -640,30 +660,39 @@ (Kpush::comp_expr (add_var var (sz+1) env) handler (sz+1) (add_pop 1 cont1)) in - sz_static_raises := - (i, (lbl_handler, sz)) :: !sz_static_raises ; + push_static_raise i lbl_handler sz; comp_expr env body sz (branch1 :: cont2) end in sz_static_raises := List.tl !sz_static_raises ; r | Lstaticraise (i, args) -> let cont = discard_dead_code cont in - let label,size = find_raise_label i in + let label,size,tb = find_raise_label i in + let cont = branch_to label cont in + let rec loop sz tbb = + if tb == tbb then add_pop (sz-size) cont + else match tbb with + | [] -> assert false + | try_sz :: tbb -> add_pop (sz-try_sz-4) (Kpoptrap :: loop try_sz tbb) + in + let cont = loop sz !try_blocks in begin match args with | [arg] -> (* optim, argument passed in accumulator *) - comp_expr env arg sz - (add_pop (sz-size) (branch_to label cont)) - | _ -> - comp_exit_args env args sz size - (add_pop (sz-size) (branch_to label cont)) + comp_expr env arg sz cont + | _ -> comp_exit_args env args sz size cont end | Ltrywith(body, id, handler) -> let (branch1, cont1) = make_branch cont in let lbl_handler = new_label() in - Kpushtrap lbl_handler :: - comp_expr env body (sz+4) (Kpoptrap :: branch1 :: - Klabel lbl_handler :: Kpush :: - comp_expr (add_var id (sz+1) env) handler (sz+1) (add_pop 1 cont1)) + let body_cont = + Kpoptrap :: branch1 :: + Klabel lbl_handler :: Kpush :: + comp_expr (add_var id (sz+1) env) handler (sz+1) (add_pop 1 cont1) + in + try_blocks := sz :: !try_blocks; + let l = comp_expr env body (sz+4) body_cont in + try_blocks := List.tl !try_blocks; + Kpushtrap lbl_handler :: l | Lifthenelse(cond, ifso, ifnot) -> comp_binary_test env cond ifso ifnot sz cont | Lsequence(exp1, exp2) -> @@ -691,10 +720,11 @@ | Lswitch(arg, sw) -> let (branch, cont1) = make_branch cont in let c = ref (discard_dead_code cont1) in + (* Build indirection vectors *) - let store = mk_store Lambda.same in - let act_consts = Array.create sw.sw_numconsts 0 - and act_blocks = Array.create sw.sw_numblocks 0 in + let store = Storer.mk_store () in + let act_consts = Array.make sw.sw_numconsts 0 + and act_blocks = Array.make sw.sw_numblocks 0 in begin match sw.sw_failaction with (* default is index 0 *) | Some fail -> ignore (store.act_store fail) | None -> () @@ -703,10 +733,20 @@ (fun (n, act) -> act_consts.(n) <- store.act_store act) sw.sw_consts; List.iter (fun (n, act) -> act_blocks.(n) <- store.act_store act) sw.sw_blocks; - (* Compile and label actions *) let acts = store.act_get () in - let lbls = Array.create (Array.length acts) 0 in +(* + let a = store.act_get_shared () in + Array.iter + (function + | Switch.Shared (Lstaticraise _) -> () + | Switch.Shared act -> + Printlambda.lambda Format.str_formatter act ; + Printf.eprintf "SHARE BYTE:\n%s\n" (Format.flush_str_formatter ()) + | _ -> ()) + a ; +*) + let lbls = Array.make (Array.length acts) 0 in for i = Array.length acts-1 downto 0 do let lbl,c1 = label_code (comp_expr env acts.(i) sz (branch :: !c)) in lbls.(i) <- lbl ; @@ -714,15 +754,17 @@ done ; (* Build label vectors *) - let lbl_blocks = Array.create sw.sw_numblocks 0 in + let lbl_blocks = Array.make sw.sw_numblocks 0 in for i = sw.sw_numblocks - 1 downto 0 do lbl_blocks.(i) <- lbls.(act_blocks.(i)) done; - let lbl_consts = Array.create sw.sw_numconsts 0 in + let lbl_consts = Array.make sw.sw_numconsts 0 in for i = sw.sw_numconsts - 1 downto 0 do lbl_consts.(i) <- lbls.(act_consts.(i)) done; comp_expr env arg sz (Kswitch(lbl_consts, lbl_blocks) :: !c) + | Lstringswitch (arg,sw,d) -> + comp_expr env (Matching.expand_stringswitch arg sw d) sz cont | Lassign(id, expr) -> begin try let pos = Ident.find_same id env.ce_stack in @@ -827,6 +869,10 @@ comp_expr env cond sz cont_cond +(* Compile string switch *) + +and comp_string_switch env arg cases default sz cont = () + (**** Compilation of a code block (with tracking of stack usage) ****) let comp_block env exp sz cont = @@ -890,3 +936,10 @@ let init_code = comp_block empty_env expr 1 [Kreturn 1] in let fun_code = comp_remainder [] in (init_code, fun_code) + +let reset () = + label_counter := 0; + sz_static_raises := []; + compunit_name := ""; + Stack.clear functions_to_compile; + max_stack_used := 0 diff -Nru ocaml-4.01.0/bytecomp/bytegen.mli ocaml-4.02.3/bytecomp/bytegen.mli --- ocaml-4.01.0/bytecomp/bytegen.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/bytegen.mli 2014-05-09 14:01:21.000000000 +0200 @@ -17,3 +17,4 @@ val compile_implementation: string -> lambda -> instruction list val compile_phrase: lambda -> instruction list * instruction list +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/bytelibrarian.ml ocaml-4.02.3/bytecomp/bytelibrarian.ml --- ocaml-4.01.0/bytecomp/bytelibrarian.ml 2013-06-05 18:34:40.000000000 +0200 +++ ocaml-4.02.3/bytecomp/bytelibrarian.ml 2014-05-09 14:01:21.000000000 +0200 @@ -60,7 +60,7 @@ raise(Error(File_not_found name)) in let ic = open_in_bin file_name in try - let buffer = input_bytes ic (String.length cmo_magic_number) in + let buffer = really_input_string ic (String.length cmo_magic_number) in if buffer = cmo_magic_number then begin let compunit_pos = input_binary_int ic in seek_in ic compunit_pos; @@ -117,3 +117,15 @@ | Not_an_object_file name -> fprintf ppf "The file %a is not a bytecode object file" Location.print_filename name + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + +let reset () = + lib_ccobjs := []; + lib_ccopts := []; + lib_dllibs := [] diff -Nru ocaml-4.01.0/bytecomp/bytelibrarian.mli ocaml-4.02.3/bytecomp/bytelibrarian.mli --- ocaml-4.01.0/bytecomp/bytelibrarian.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/bytelibrarian.mli 2014-05-09 14:01:21.000000000 +0200 @@ -30,3 +30,5 @@ open Format val report_error: formatter -> error -> unit + +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/bytelink.ml ocaml-4.02.3/bytecomp/bytelink.ml --- ocaml-4.01.0/bytecomp/bytelink.ml 2013-07-23 16:48:47.000000000 +0200 +++ ocaml-4.02.3/bytecomp/bytelink.ml 2015-05-15 18:49:18.000000000 +0200 @@ -42,7 +42,7 @@ let lib_ccopts = ref [] let lib_dllibs = ref [] -let add_ccobjs l = +let add_ccobjs origin l = if not !Clflags.no_auto_link then begin if String.length !Clflags.use_runtime = 0 @@ -50,7 +50,8 @@ then begin if l.lib_custom then Clflags.custom_runtime := true; lib_ccobjs := l.lib_ccobjs @ !lib_ccobjs; - lib_ccopts := l.lib_ccopts @ !lib_ccopts; + let replace_origin = Misc.replace_substring ~before:"$CAMLORIGIN" ~after:origin in + lib_ccopts := List.map replace_origin l.lib_ccopts @ !lib_ccopts; end; lib_dllibs := l.lib_dllibs @ !lib_dllibs end @@ -113,7 +114,7 @@ raise(Error(File_not_found obj_name)) in let ic = open_in_bin file_name in try - let buffer = input_bytes ic (String.length cmo_magic_number) in + let buffer = really_input_string ic (String.length cmo_magic_number) in if buffer = cmo_magic_number then begin (* This is a .cmo file. It must be linked in any case. Read the relocation information to see which modules it @@ -132,7 +133,7 @@ seek_in ic pos_toc; let toc = (input_value ic : library) in close_in ic; - add_ccobjs toc; + add_ccobjs (Filename.dirname file_name) toc; let required = List.fold_right (fun compunit reqd -> @@ -158,15 +159,20 @@ (* Consistency check between interfaces *) let crc_interfaces = Consistbl.create () +let interfaces = ref ([] : string list) let implementations_defined = ref ([] : (string * string) list) let check_consistency ppf file_name cu = begin try List.iter - (fun (name, crc) -> - if name = cu.cu_name - then Consistbl.set crc_interfaces name crc file_name - else Consistbl.check crc_interfaces name crc file_name) + (fun (name, crco) -> + interfaces := name :: !interfaces; + match crco with + None -> () + | Some crc -> + if name = cu.cu_name + then Consistbl.set crc_interfaces name crc file_name + else Consistbl.check crc_interfaces name crc file_name) cu.cu_imports with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_import(name, user, auth))) @@ -183,11 +189,15 @@ (cu.cu_name, file_name) :: !implementations_defined let extract_crc_interfaces () = - Consistbl.extract crc_interfaces + Consistbl.extract !interfaces crc_interfaces + +let clear_crc_interfaces () = + Consistbl.clear crc_interfaces; + interfaces := [] (* Record compilation events *) -let debug_info = ref ([] : (int * LongString.t) list) +let debug_info = ref ([] : (int * Instruct.debug_event list * string list) list) (* Link in a compilation unit *) @@ -198,8 +208,14 @@ Symtable.ls_patch_object code_block compunit.cu_reloc; if !Clflags.debug && compunit.cu_debug > 0 then begin seek_in inchan compunit.cu_debug; - let buffer = LongString.input_bytes inchan compunit.cu_debugsize in - debug_info := (currpos_fun(), buffer) :: !debug_info + let debug_event_list : Instruct.debug_event list = input_value inchan in + let debug_dirs : string list = input_value inchan in + let file_path = Filename.dirname (Location.absolute_path file_name) in + let debug_dirs = + if List.mem file_path debug_dirs + then debug_dirs + else file_path :: debug_dirs in + debug_info := (currpos_fun(), debug_event_list, debug_dirs) :: !debug_info end; Array.iter output_fun code_block; if !Clflags.link_everything then @@ -254,9 +270,10 @@ let output_debug_info oc = output_binary_int oc (List.length !debug_info); List.iter - (fun (ofs, evl) -> + (fun (ofs, evl, debug_dirs) -> output_binary_int oc ofs; - Array.iter (output_string oc) evl) + output_value oc evl; + output_value oc debug_dirs) !debug_info; debug_info := [] @@ -300,26 +317,27 @@ Bytesections.init_record outchan; (* The path to the bytecode interpreter (in use_runtime mode) *) if String.length !Clflags.use_runtime > 0 then begin - output_string outchan (make_absolute !Clflags.use_runtime); + output_string outchan ("#!" ^ (make_absolute !Clflags.use_runtime)); output_char outchan '\n'; Bytesections.record outchan "RNTM" end; (* The bytecode *) let start_code = pos_out outchan in Symtable.init(); - Consistbl.clear crc_interfaces; + clear_crc_interfaces (); let sharedobjs = List.map Dll.extract_dll_name !Clflags.dllibs in - if standalone then begin + let check_dlls = standalone && Config.target = Config.host in + if check_dlls then begin (* Initialize the DLL machinery *) Dll.init_compile !Clflags.no_std_include; Dll.add_path !load_path; try Dll.open_dlls Dll.For_checking sharedobjs with Failure reason -> raise(Error(Cannot_open_dll reason)) end; - let output_fun = output_string outchan + let output_fun = output_bytes outchan and currpos_fun () = pos_out outchan - start_code in List.iter (link_file ppf output_fun currpos_fun) tolink; - if standalone then Dll.close_all_dlls(); + if check_dlls then Dll.close_all_dlls(); (* The final STOP instruction *) output_byte outchan Opcodes.opSTOP; output_byte outchan 0; output_byte outchan 0; output_byte outchan 0; @@ -370,12 +388,12 @@ let output_code_string outchan code = let pos = ref 0 in - let len = String.length code in + let len = Bytes.length code in while !pos < len do - let c1 = Char.code(code.[!pos]) in - let c2 = Char.code(code.[!pos + 1]) in - let c3 = Char.code(code.[!pos + 2]) in - let c4 = Char.code(code.[!pos + 3]) in + let c1 = Char.code(Bytes.get code !pos) in + let c2 = Char.code(Bytes.get code (!pos + 1)) in + let c3 = Char.code(Bytes.get code (!pos + 2)) in + let c4 = Char.code(Bytes.get code (!pos + 3)) in pos := !pos + 4; Printf.fprintf outchan "0x%02x%02x%02x%02x, " c4 c3 c2 c1; incr output_code_string_counter; @@ -439,11 +457,11 @@ \n char **argv);\n"; output_string outchan "static int caml_code[] = {\n"; Symtable.init(); - Consistbl.clear crc_interfaces; + clear_crc_interfaces (); let currpos = ref 0 in let output_fun code = output_code_string outchan code; - currpos := !currpos + String.length code + currpos := !currpos + Bytes.length code and currpos_fun () = !currpos in List.iter (link_file ppf output_fun currpos_fun) tolink; (* The final STOP instruction *) @@ -562,8 +580,15 @@ raise x end else begin let basename = Filename.chop_extension output_name in - let c_file = basename ^ ".c" - and obj_file = basename ^ Config.ext_obj in + let c_file = + if !Clflags.output_complete_object + then Filename.temp_file "camlobj" ".c" + else basename ^ ".c" + and obj_file = + if !Clflags.output_complete_object + then Filename.temp_file "camlobj" Config.ext_obj + else basename ^ Config.ext_obj + in if Sys.file_exists c_file then raise(Error(File_exists c_file)); let temps = ref [] in try @@ -571,13 +596,19 @@ if not (Filename.check_suffix output_name ".c") then begin temps := c_file :: !temps; if Ccomp.compile_file c_file <> 0 then raise(Error Custom_runtime); - if not (Filename.check_suffix output_name Config.ext_obj) then begin + if not (Filename.check_suffix output_name Config.ext_obj) || + !Clflags.output_complete_object then begin temps := obj_file :: !temps; + let mode, c_libs = + if Filename.check_suffix output_name Config.ext_obj + then Ccomp.Partial, "" + else Ccomp.MainDll, Config.bytecomp_c_libraries + in if not ( let runtime_lib = "-lcamlrun" ^ !Clflags.runtime_variant in - Ccomp.call_linker Ccomp.MainDll output_name + Ccomp.call_linker mode output_name ([obj_file] @ List.rev !Clflags.ccobjs @ [runtime_lib]) - Config.bytecomp_c_libraries + c_libs ) then raise (Error Custom_runtime); end end; @@ -621,3 +652,20 @@ | Not_compatible_32 -> fprintf ppf "Generated bytecode executable cannot be run\ \ on a 32-bit platform" + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + +let reset () = + lib_ccobjs := []; + lib_ccopts := []; + lib_dllibs := []; + missing_globals := IdentSet.empty; + Consistbl.clear crc_interfaces; + implementations_defined := []; + debug_info := []; + output_code_string_counter := 0 diff -Nru ocaml-4.01.0/bytecomp/bytelink.mli ocaml-4.02.3/bytecomp/bytelink.mli --- ocaml-4.01.0/bytecomp/bytelink.mli 2013-04-18 13:58:59.000000000 +0200 +++ ocaml-4.02.3/bytecomp/bytelink.mli 2014-05-09 14:01:21.000000000 +0200 @@ -13,11 +13,12 @@ (* Link .cmo files and produce a bytecode executable. *) val link : Format.formatter -> string list -> string -> unit +val reset : unit -> unit val check_consistency: Format.formatter -> string -> Cmo_format.compilation_unit -> unit -val extract_crc_interfaces: unit -> (string * Digest.t) list +val extract_crc_interfaces: unit -> (string * Digest.t option) list type error = File_not_found of string diff -Nru ocaml-4.01.0/bytecomp/bytepackager.ml ocaml-4.02.3/bytecomp/bytepackager.ml --- ocaml-4.01.0/bytecomp/bytepackager.ml 2013-07-23 16:48:47.000000000 +0200 +++ ocaml-4.02.3/bytecomp/bytepackager.ml 2014-09-20 00:04:19.000000000 +0200 @@ -17,6 +17,8 @@ open Instruct open Cmo_format +module StringSet = Set.Make(String) + type error = Forward_reference of string * Ident.t | Multiple_definition of string * Ident.t @@ -30,6 +32,7 @@ let relocs = ref ([] : (reloc_info * int) list) let events = ref ([] : debug_event list) +let debug_dirs = ref StringSet.empty let primitives = ref ([] : string list) let force_link = ref false @@ -98,7 +101,9 @@ if Filename.check_suffix file ".cmo" then begin let ic = open_in_bin file in try - let buffer = input_bytes ic (String.length Config.cmo_magic_number) in + let buffer = + really_input_string ic (String.length Config.cmo_magic_number) + in if buffer <> Config.cmo_magic_number then raise(Error(Not_an_object_file file)); let compunit_pos = input_binary_int ic in @@ -137,6 +142,10 @@ if !Clflags.debug && compunit.cu_debug > 0 then begin seek_in ic compunit.cu_debug; List.iter (relocate_debug ofs prefix subst) (input_value ic); + debug_dirs := List.fold_left + (fun s e -> StringSet.add e s) + !debug_dirs + (input_value ic); end; close_in ic; compunit.cu_codesize @@ -182,6 +191,8 @@ let lam = Translmod.transl_package components (Ident.create_persistent target_name) coercion in + if !Clflags.dump_lambda then + Format.printf "%a@." Printlambda.lambda lam; let instrs = Bytegen.compile_implementation target_name lam in let rel = @@ -211,8 +222,10 @@ targetname Subst.identity members in build_global_target oc targetname members mapping ofs coercion; let pos_debug = pos_out oc in - if !Clflags.debug && !events <> [] then + if !Clflags.debug && !events <> [] then begin output_value oc (List.rev !events); + output_value oc (StringSet.elements !debug_dirs); + end; let pos_final = pos_out oc in let imports = List.filter @@ -223,7 +236,8 @@ cu_pos = pos_code; cu_codesize = pos_debug - pos_code; cu_reloc = List.rev !relocs; - cu_imports = (targetname, Env.crc_of_unit targetname) :: imports; + cu_imports = + (targetname, Some (Env.crc_of_unit targetname)) :: imports; cu_primitives = !primitives; cu_force_link = !force_link; cu_debug = if pos_final > pos_debug then pos_debug else 0; @@ -238,7 +252,7 @@ (* The entry point *) -let package_files ppf files targetfile = +let package_files ppf initial_env files targetfile = let files = List.map (fun f -> @@ -249,11 +263,12 @@ let targetcmi = prefix ^ ".cmi" in let targetname = String.capitalize(Filename.basename prefix) in try - let coercion = Typemod.package_units files targetcmi targetname in - let ret = package_object_files ppf files targetfile targetname coercion in - ret - with x -> - remove_file targetfile; raise x + let coercion = + Typemod.package_units initial_env files targetcmi targetname in + let ret = package_object_files ppf files targetfile targetname coercion in + ret + with x -> + remove_file targetfile; raise x (* Error report *) @@ -276,3 +291,16 @@ Location.print_filename file name id | File_not_found file -> fprintf ppf "File %s not found" file + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + +let reset () = + relocs := []; + events := []; + primitives := []; + force_link := false diff -Nru ocaml-4.01.0/bytecomp/bytepackager.mli ocaml-4.02.3/bytecomp/bytepackager.mli --- ocaml-4.01.0/bytecomp/bytepackager.mli 2013-04-29 16:57:38.000000000 +0200 +++ ocaml-4.02.3/bytecomp/bytepackager.mli 2014-05-09 14:01:21.000000000 +0200 @@ -13,7 +13,7 @@ (* "Package" a set of .cmo files into one .cmo file having the original compilation units as sub-modules. *) -val package_files: Format.formatter -> string list -> string -> unit +val package_files: Format.formatter -> Env.t -> string list -> string -> unit type error = Forward_reference of string * Ident.t @@ -25,3 +25,4 @@ exception Error of error val report_error: Format.formatter -> error -> unit +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/bytesections.ml ocaml-4.02.3/bytecomp/bytesections.ml --- ocaml-4.01.0/bytecomp/bytesections.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/bytesections.ml 2014-05-09 14:01:21.000000000 +0200 @@ -46,12 +46,14 @@ let pos_trailer = in_channel_length ic - 16 in seek_in ic pos_trailer; let num_sections = input_binary_int ic in - let header = Misc.input_bytes ic (String.length Config.exec_magic_number) in + let header = + really_input_string ic (String.length Config.exec_magic_number) + in if header <> Config.exec_magic_number then raise Bad_magic_number; seek_in ic (pos_trailer - 8 * num_sections); section_table := []; for _i = 1 to num_sections do - let name = Misc.input_bytes ic 4 in + let name = really_input_string ic 4 in let len = input_binary_int ic in section_table := (name, len) :: !section_table done @@ -77,7 +79,7 @@ (* Return the contents of a section, as a string *) let read_section_string ic name = - Misc.input_bytes ic (seek_section ic name) + really_input_string ic (seek_section ic name) (* Return the contents of a section, as marshalled data *) @@ -90,3 +92,7 @@ let pos_first_section ic = in_channel_length ic - 16 - 8 * List.length !section_table - List.fold_left (fun total (name, len) -> total + len) 0 !section_table + +let reset () = + section_table := []; + section_beginning := 0 diff -Nru ocaml-4.01.0/bytecomp/bytesections.mli ocaml-4.02.3/bytecomp/bytesections.mli --- ocaml-4.01.0/bytecomp/bytesections.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/bytesections.mli 2014-05-09 14:01:21.000000000 +0200 @@ -50,3 +50,5 @@ val pos_first_section: in_channel -> int (* Return the position of the beginning of the first section *) + +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/cmo_format.mli ocaml-4.02.3/bytecomp/cmo_format.mli --- ocaml-4.01.0/bytecomp/cmo_format.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/cmo_format.mli 2014-05-07 02:34:20.000000000 +0200 @@ -27,7 +27,8 @@ mutable cu_pos: int; (* Absolute position in file *) cu_codesize: int; (* Size of code block *) cu_reloc: (reloc_info * int) list; (* Relocation information *) - cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *) + cu_imports: + (string * Digest.t option) list; (* Names and CRC of intfs imported *) cu_primitives: string list; (* Primitives declared inside *) mutable cu_force_link: bool; (* Must be linked even if unref'ed *) mutable cu_debug: int; (* Position of debugging info, or 0 *) diff -Nru ocaml-4.01.0/bytecomp/dll.ml ocaml-4.02.3/bytecomp/dll.ml --- ocaml-4.01.0/bytecomp/dll.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/dll.ml 2014-05-09 14:01:21.000000000 +0200 @@ -173,3 +173,9 @@ opened_dlls := Array.to_list (get_current_dlls()); names_of_opened_dlls := []; linking_in_core := true + +let reset () = + search_path := []; + opened_dlls :=[]; + names_of_opened_dlls := []; + linking_in_core := false diff -Nru ocaml-4.01.0/bytecomp/dll.mli ocaml-4.02.3/bytecomp/dll.mli --- ocaml-4.01.0/bytecomp/dll.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/dll.mli 2014-05-09 14:01:21.000000000 +0200 @@ -59,3 +59,5 @@ contents of ld.conf file). Take note of the DLLs that were opened when starting the running program. *) val init_toplevel: string -> unit + +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/emitcode.ml ocaml-4.02.3/bytecomp/emitcode.ml --- ocaml-4.01.0/bytecomp/emitcode.ml 2013-04-17 11:07:00.000000000 +0200 +++ ocaml-4.02.3/bytecomp/emitcode.ml 2014-10-03 17:27:17.000000000 +0200 @@ -20,6 +20,8 @@ open Opcodes open Cmo_format +module StringSet = Set.Make(String) + (* Buffering of bytecode *) let out_buffer = ref(LongString.create 1024) @@ -80,7 +82,7 @@ let extend_label_table needed = let new_size = ref(Array.length !label_table) in while needed >= !new_size do new_size := 2 * !new_size done; - let new_table = Array.create !new_size (Label_undefined []) in + let new_table = Array.make !new_size (Label_undefined []) in Array.blit !label_table 0 new_table 0 (Array.length !label_table); label_table := new_table @@ -135,8 +137,13 @@ (* Debugging events *) let events = ref ([] : debug_event list) +let debug_dirs = ref StringSet.empty let record_event ev = + let path = ev.ev_loc.Location.loc_start.Lexing.pos_fname in + let abspath = Location.absolute_path path in + debug_dirs := StringSet.add (Filename.dirname abspath) !debug_dirs; + if Filename.is_relative path then debug_dirs := StringSet.add (Sys.getcwd ()) !debug_dirs; ev.ev_pos <- !out_position; events := ev :: !events @@ -144,8 +151,9 @@ let init () = out_position := 0; - label_table := Array.create 16 (Label_undefined []); + label_table := Array.make 16 (Label_undefined []); reloc_info := []; + debug_dirs := StringSet.empty; events := [] (* Emission of one instruction *) @@ -243,7 +251,9 @@ | Kboolnot -> out opBOOLNOT | Kpushtrap lbl -> out opPUSHTRAP; out_label lbl | Kpoptrap -> out opPOPTRAP - | Kraise -> out opRAISE + | Kraise Raise_regular -> out opRAISE + | Kraise Raise_reraise -> out opRERAISE + | Kraise Raise_notrace -> out opRAISE_NOTRACE | Kcheck_signals -> out opCHECK_SIGNALS | Kccall(name, n) -> if n <= 5 @@ -351,7 +361,7 @@ (* Emission to a file *) -let to_file outchan unit_name code = +let to_file outchan unit_name objfile code = init(); output_string outchan cmo_magic_number; let pos_depl = pos_out outchan in @@ -361,8 +371,12 @@ LongString.output outchan !out_buffer 0 !out_position; let (pos_debug, size_debug) = if !Clflags.debug then begin + debug_dirs := StringSet.add + (Filename.dirname (Location.absolute_path objfile)) + !debug_dirs; let p = pos_out outchan in output_value outchan !events; + output_value outchan (StringSet.elements !debug_dirs); (p, pos_out outchan - p) end else (0, 0) in @@ -371,7 +385,7 @@ cu_pos = pos_code; cu_codesize = !out_position; cu_reloc = List.rev !reloc_info; - cu_imports = Env.imported_units(); + cu_imports = Env.imports(); cu_primitives = List.map Primitive.byte_name !Translmod.primitive_declarations; cu_force_link = false; @@ -392,7 +406,7 @@ emit init_code; emit fun_code; let code = Meta.static_alloc !out_position in - LongString.unsafe_blit_to_string !out_buffer 0 code 0 !out_position; + LongString.unsafe_blit_to_bytes !out_buffer 0 code 0 !out_position; let reloc = List.rev !reloc_info and code_size = !out_position in init(); @@ -407,3 +421,9 @@ let reloc = !reloc_info in init(); reloc + +let reset () = + out_buffer := LongString.create 1024; + out_position := 0; + label_table := [| |]; + reloc_info := [] diff -Nru ocaml-4.01.0/bytecomp/emitcode.mli ocaml-4.02.3/bytecomp/emitcode.mli --- ocaml-4.01.0/bytecomp/emitcode.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/emitcode.mli 2014-07-30 22:38:09.000000000 +0200 @@ -15,13 +15,14 @@ open Cmo_format open Instruct -val to_file: out_channel -> string -> instruction list -> unit +val to_file: out_channel -> string -> string -> instruction list -> unit (* Arguments: channel on output file name of compilation unit implemented + path of cmo file being written list of instructions to emit *) val to_memory: instruction list -> instruction list -> - string * int * (reloc_info * int) list + bytes * int * (reloc_info * int) list (* Arguments: initialization code (terminated by STOP) function code @@ -36,3 +37,5 @@ list of instructions to emit Result: relocation information (reversed) *) + +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/instruct.ml ocaml-4.02.3/bytecomp/instruct.ml --- ocaml-4.01.0/bytecomp/instruct.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/instruct.ml 2013-11-13 14:55:13.000000000 +0100 @@ -85,7 +85,7 @@ | Kboolnot | Kpushtrap of label | Kpoptrap - | Kraise + | Kraise of raise_kind | Kcheck_signals | Kccall of string * int | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint diff -Nru ocaml-4.01.0/bytecomp/instruct.mli ocaml-4.02.3/bytecomp/instruct.mli --- ocaml-4.01.0/bytecomp/instruct.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/instruct.mli 2013-11-13 14:55:13.000000000 +0100 @@ -105,7 +105,7 @@ | Kboolnot | Kpushtrap of label | Kpoptrap - | Kraise + | Kraise of raise_kind | Kcheck_signals | Kccall of string * int | Knegint | Kaddint | Ksubint | Kmulint | Kdivint | Kmodint diff -Nru ocaml-4.01.0/bytecomp/lambda.ml ocaml-4.02.3/bytecomp/lambda.ml --- ocaml-4.01.0/bytecomp/lambda.ml 2012-11-29 10:55:00.000000000 +0100 +++ ocaml-4.02.3/bytecomp/lambda.ml 2015-05-06 11:53:49.000000000 +0200 @@ -21,11 +21,19 @@ | Ostype_win32 | Ostype_cygwin +type loc_kind = + | Loc_FILE + | Loc_LINE + | Loc_MODULE + | Loc_LOC + | Loc_POS + type primitive = Pidentity | Pignore | Prevapply of Location.t | Pdirapply of Location.t + | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t @@ -41,7 +49,7 @@ (* External call *) | Pccall of Primitive.description (* Exceptions *) - | Praise + | Praise of raise_kind (* Boolean operations *) | Psequand | Psequor | Pnot (* Integer operations *) @@ -113,6 +121,8 @@ (* byte swap *) | Pbswap16 | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge @@ -137,6 +147,11 @@ | Pbigarray_c_layout | Pbigarray_fortran_layout +and raise_kind = + | Raise_regular + | Raise_reraise + | Raise_notrace + type structured_constant = Const_base of constant | Const_pointer of int @@ -161,6 +176,7 @@ | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list | Lswitch of lambda * lambda_switch + | Lstringswitch of lambda * (string * lambda) list * lambda option | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda @@ -195,68 +211,96 @@ let lambda_unit = Lconst const_unit -let rec same l1 l2 = - match (l1, l2) with - | Lvar v1, Lvar v2 -> - Ident.same v1 v2 - | Lconst c1, Lconst c2 -> - c1 = c2 - | Lapply(a1, bl1, _), Lapply(a2, bl2, _) -> - same a1 a2 && samelist same bl1 bl2 - | Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) -> - k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2 - | Llet(k1, id1, a1, b1), Llet(k2, id2, a2, b2) -> - k1 = k2 && Ident.same id1 id2 && same a1 a2 && same b1 b2 - | Lletrec (bl1, a1), Lletrec (bl2, a2) -> - samelist samebinding bl1 bl2 && same a1 a2 - | Lprim(p1, al1), Lprim(p2, al2) -> - p1 = p2 && samelist same al1 al2 - | Lswitch(a1, s1), Lswitch(a2, s2) -> - same a1 a2 && sameswitch s1 s2 - | Lstaticraise(n1, al1), Lstaticraise(n2, al2) -> - n1 = n2 && samelist same al1 al2 - | Lstaticcatch(a1, (n1, idl1), b1), Lstaticcatch(a2, (n2, idl2), b2) -> - same a1 a2 && n1 = n2 && samelist Ident.same idl1 idl2 && same b1 b2 - | Ltrywith(a1, id1, b1), Ltrywith(a2, id2, b2) -> - same a1 a2 && Ident.same id1 id2 && same b1 b2 - | Lifthenelse(a1, b1, c1), Lifthenelse(a2, b2, c2) -> - same a1 a2 && same b1 b2 && same c1 c2 - | Lsequence(a1, b1), Lsequence(a2, b2) -> - same a1 a2 && same b1 b2 - | Lwhile(a1, b1), Lwhile(a2, b2) -> - same a1 a2 && same b1 b2 - | Lfor(id1, a1, b1, df1, c1), Lfor(id2, a2, b2, df2, c2) -> - Ident.same id1 id2 && same a1 a2 && - same b1 b2 && df1 = df2 && same c1 c2 - | Lassign(id1, a1), Lassign(id2, a2) -> - Ident.same id1 id2 && same a1 a2 - | Lsend(k1, a1, b1, cl1, _), Lsend(k2, a2, b2, cl2, _) -> - k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2 - | Levent(a1, ev1), Levent(a2, ev2) -> - same a1 a2 && ev1.lev_loc = ev2.lev_loc - | Lifused(id1, a1), Lifused(id2, a2) -> - Ident.same id1 id2 && same a1 a2 - | _, _ -> - false - -and samebinding (id1, c1) (id2, c2) = - Ident.same id1 id2 && same c1 c2 - -and sameswitch sw1 sw2 = - let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in - sw1.sw_numconsts = sw2.sw_numconsts && - sw1.sw_numblocks = sw2.sw_numblocks && - samelist samecase sw1.sw_consts sw2.sw_consts && - samelist samecase sw1.sw_blocks sw2.sw_blocks && - (match (sw1.sw_failaction, sw2.sw_failaction) with - | (None, None) -> true - | (Some a1, Some a2) -> same a1 a2 - | _ -> false) +(* Build sharing keys *) +(* + Those keys are later compared with Pervasives.compare. + For that reason, they should not include cycles. +*) + +exception Not_simple + +let max_raw = 32 + +let make_key e = + let count = ref 0 (* Used for controling size *) + and make_key = Ident.make_key_generator () in + (* make_key is used for normalizing let-bound variables *) + let rec tr_rec env e = + incr count ; + if !count > max_raw then raise Not_simple ; (* Too big ! *) + match e with + | Lvar id -> + begin + try Ident.find_same id env + with Not_found -> e + end + | Lconst (Const_base (Const_string _)|Const_float_array _) -> + (* Mutable constants are not shared *) + raise Not_simple + | Lconst _ -> e + | Lapply (e,es,loc) -> + Lapply (tr_rec env e,tr_recs env es,Location.none) + | Llet (Alias,x,ex,e) -> (* Ignore aliases -> substitute *) + let ex = tr_rec env ex in + tr_rec (Ident.add x ex env) e + | Llet (str,x,ex,e) -> + (* Because of side effects, keep other lets with normalized names *) + let ex = tr_rec env ex in + let y = make_key x in + Llet (str,y,ex,tr_rec (Ident.add x (Lvar y) env) e) + | Lprim (p,es) -> + Lprim (p,tr_recs env es) + | Lswitch (e,sw) -> + Lswitch (tr_rec env e,tr_sw env sw) + | Lstringswitch (e,sw,d) -> + Lstringswitch + (tr_rec env e, + List.map (fun (s,e) -> s,tr_rec env e) sw, + tr_opt env d) + | Lstaticraise (i,es) -> + Lstaticraise (i,tr_recs env es) + | Lstaticcatch (e1,xs,e2) -> + Lstaticcatch (tr_rec env e1,xs,tr_rec env e2) + | Ltrywith (e1,x,e2) -> + Ltrywith (tr_rec env e1,x,tr_rec env e2) + | Lifthenelse (cond,ifso,ifnot) -> + Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot) + | Lsequence (e1,e2) -> + Lsequence (tr_rec env e1,tr_rec env e2) + | Lassign (x,e) -> + Lassign (x,tr_rec env e) + | Lsend (m,e1,e2,es,loc) -> + Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none) + | Lifused (id,e) -> Lifused (id,tr_rec env e) + | Lletrec _|Lfunction _ + | Lfor _ | Lwhile _ +(* Beware: (PR#6412) the event argument to Levent + may include cyclic structure of type Type.typexpr *) + | Levent _ -> + raise Not_simple + + and tr_recs env es = List.map (tr_rec env) es + + and tr_sw env sw = + { sw with + sw_consts = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_consts ; + sw_blocks = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_blocks ; + sw_failaction = tr_opt env sw.sw_failaction ; } + + and tr_opt env = function + | None -> None + | Some e -> Some (tr_rec env e) in + + try + Some (tr_rec Ident.empty e) + with Not_simple -> None + +(***************) -let name_lambda arg fn = +let name_lambda strict arg fn = match arg with Lvar id -> fn id - | _ -> let id = Ident.create "let" in Llet(Strict, id, arg, fn id) + | _ -> let id = Ident.create "let" in Llet(strict, id, arg, fn id) let name_lambda_list args fn = let rec name_list names = function @@ -268,6 +312,11 @@ Llet(Strict, id, arg, name_list (Lvar id :: names) rem) in name_list [] args + +let iter_opt f = function + | None -> () + | Some e -> f e + let iter f = function Lvar _ | Lconst _ -> () @@ -286,10 +335,11 @@ f arg; List.iter (fun (key, case) -> f case) sw.sw_consts; List.iter (fun (key, case) -> f case) sw.sw_blocks; - begin match sw.sw_failaction with - | None -> () - | Some l -> f l - end + iter_opt f sw.sw_failaction + | Lstringswitch (arg,cases,default) -> + f arg ; + List.iter (fun (_,act) -> f act) cases ; + iter_opt f default | Lstaticraise (_,args) -> List.iter f args | Lstaticcatch(e1, (_,vars), e2) -> @@ -313,6 +363,7 @@ | Lifused (v, e) -> f e + module IdentSet = Set.Make(struct type t = Ident.t @@ -340,7 +391,7 @@ | Lassign(id, e) -> fv := IdentSet.add id !fv | Lvar _ | Lconst _ | Lapply _ - | Lprim _ | Lswitch _ | Lstaticraise _ + | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _ | Lifthenelse _ | Lsequence _ | Lwhile _ | Lsend _ | Levent _ | Lifused _ -> () in free l; !fv @@ -358,6 +409,12 @@ incr raise_count ; !raise_count +let negative_raise_count = ref 0 + +let next_negative_raise_count () = + decr negative_raise_count ; + !negative_raise_count + (* Anticipated staticraise, for guards *) let staticfail = Lstaticraise (0,[]) @@ -378,14 +435,19 @@ (* Translate an access path *) -let rec transl_path = function +let rec transl_normal_path = function Pident id -> if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id | Pdot(p, s, pos) -> - Lprim(Pfield pos, [transl_path p]) + Lprim(Pfield pos, [transl_normal_path p]) | Papply(p1, p2) -> fatal_error "Lambda.transl_path" +(* Translation of value identifiers *) + +let transl_path ?(loc=Location.none) env path = + transl_normal_path (Env.normalize_path (Some loc) env path) + (* Compile a sequence of expressions *) let rec make_sequence fn = function @@ -414,11 +476,10 @@ Lswitch(subst arg, {sw with sw_consts = List.map subst_case sw.sw_consts; sw_blocks = List.map subst_case sw.sw_blocks; - sw_failaction = - match sw.sw_failaction with - | None -> None - | Some l -> Some (subst l)}) - + sw_failaction = subst_opt sw.sw_failaction; }) + | Lstringswitch (arg,cases,default) -> + Lstringswitch + (subst arg,List.map subst_strcase cases,subst_opt default) | Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args) | Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2) | Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2) @@ -433,6 +494,10 @@ | Lifused (v, e) -> Lifused (v, subst e) and subst_decl (id, exp) = (id, subst exp) and subst_case (key, case) = (key, subst case) + and subst_strcase (key, case) = (key, subst case) + and subst_opt = function + | None -> None + | Some e -> Some (subst e) in subst lam @@ -452,3 +517,36 @@ | Ceq -> Cneq| Cneq -> Ceq | Clt -> Cge | Cle -> Cgt | Cgt -> Cle | Cge -> Clt + +let raise_kind = function + | Raise_regular -> "raise" + | Raise_reraise -> "reraise" + | Raise_notrace -> "raise_notrace" + +let lam_of_loc kind loc = + let loc_start = loc.Location.loc_start in + let (file, lnum, cnum) = Location.get_pos_info loc_start in + let enum = loc.Location.loc_end.Lexing.pos_cnum - + loc_start.Lexing.pos_cnum + cnum in + match kind with + | Loc_POS -> + Lconst (Const_block (0, [ + Const_immstring file; + Const_base (Const_int lnum); + Const_base (Const_int cnum); + Const_base (Const_int enum); + ])) + | Loc_FILE -> Lconst (Const_immstring file) + | Loc_MODULE -> + let filename = Filename.basename file in + let name = Env.get_unit_name () in + let module_name = if name = "" then "//"^filename^"//" else name in + Lconst (Const_immstring module_name) + | Loc_LOC -> + let loc = Printf.sprintf "File %S, line %d, characters %d-%d" + file lnum cnum enum in + Lconst (Const_immstring loc) + | Loc_LINE -> Lconst (Const_base (Const_int lnum)) + +let reset () = + raise_count := 0 diff -Nru ocaml-4.01.0/bytecomp/lambda.mli ocaml-4.02.3/bytecomp/lambda.mli --- ocaml-4.01.0/bytecomp/lambda.mli 2012-11-29 10:55:00.000000000 +0100 +++ ocaml-4.02.3/bytecomp/lambda.mli 2014-05-21 17:08:11.000000000 +0200 @@ -21,11 +21,19 @@ | Ostype_win32 | Ostype_cygwin +type loc_kind = + | Loc_FILE + | Loc_LINE + | Loc_MODULE + | Loc_LOC + | Loc_POS + type primitive = Pidentity | Pignore | Prevapply of Location.t | Pdirapply of Location.t + | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t @@ -41,7 +49,7 @@ (* External call *) | Pccall of Primitive.description (* Exceptions *) - | Praise + | Praise of raise_kind (* Boolean operations *) | Psequand | Psequor | Pnot (* Integer operations *) @@ -113,6 +121,8 @@ (* byte swap *) | Pbswap16 | Pbbswap of boxed_integer + (* Integer to external pointer *) + | Pint_as_pointer and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge @@ -137,6 +147,11 @@ | Pbigarray_c_layout | Pbigarray_fortran_layout +and raise_kind = + | Raise_regular + | Raise_reraise + | Raise_notrace + type structured_constant = Const_base of constant | Const_pointer of int @@ -170,6 +185,9 @@ | Lletrec of (Ident.t * lambda) list * lambda | Lprim of primitive * lambda list | Lswitch of lambda * lambda_switch +(* switch on strings, clauses are sorted by string order, + strings are pairwise distinct *) + | Lstringswitch of lambda * (string * lambda) list * lambda option | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda | Ltrywith of lambda * Ident.t * lambda @@ -199,10 +217,12 @@ | Lev_after of Types.type_expr | Lev_function -val same: lambda -> lambda -> bool +(* Sharing key *) +val make_key: lambda -> lambda option + val const_unit: structured_constant val lambda_unit: lambda -val name_lambda: lambda -> (Ident.t -> lambda) -> lambda +val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda val iter: (lambda -> unit) -> lambda -> unit @@ -210,7 +230,8 @@ val free_variables: lambda -> IdentSet.t val free_methods: lambda -> IdentSet.t -val transl_path: Path.t -> lambda +val transl_normal_path: Path.t -> lambda (* Path.t is already normal *) +val transl_path: ?loc:Location.t -> Env.t -> Path.t -> lambda val make_sequence: ('a -> lambda) -> 'a list -> lambda val subst_lambda: lambda Ident.tbl -> lambda -> lambda @@ -225,10 +246,19 @@ (* Get a new static failure ident *) val next_raise_count : unit -> int - +val next_negative_raise_count : unit -> int + (* Negative raise counts are used to compile 'match ... with + exception x -> ...'. This disabled some simplifications + performed by the Simplif module that assume that static raises + are in tail position in their handler. *) val staticfail : lambda (* Anticipated static failure *) (* Check anticipated failure, substitute its final value *) val is_guarded: lambda -> bool val patch_guarded : lambda -> lambda -> lambda + +val raise_kind: raise_kind -> string +val lam_of_loc : loc_kind -> Location.t -> lambda + +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/matching.ml ocaml-4.02.3/bytecomp/matching.ml --- ocaml-4.01.0/bytecomp/matching.ml 2013-07-23 16:48:47.000000000 +0200 +++ ocaml-4.02.3/bytecomp/matching.ml 2014-08-18 20:26:49.000000000 +0200 @@ -21,6 +21,9 @@ open Parmatch open Printf + +let dbg = false + (* See Peyton-Jones, ``The Implementation of functional programming languages'', chapter 5. *) (* @@ -38,6 +41,10 @@ - Jump summaries: mapping from exit numbers to contexts *) +let string_of_lam lam = + Printlambda.lambda Format.str_formatter lam ; + Format.flush_str_formatter () + type matrix = pattern list list let add_omega_column pss = List.map (fun ps -> omega::ps) pss @@ -160,12 +167,24 @@ let ctx_matcher p = let p = normalize_pat p in match p.pat_desc with - | Tpat_construct (_, cstr,omegas,_) -> - (fun q rem -> match q.pat_desc with - | Tpat_construct (_, cstr',args,_) when cstr.cstr_tag=cstr'.cstr_tag -> - p,args @ rem - | Tpat_any -> p,omegas @ rem - | _ -> raise NoMatch) + | Tpat_construct (_, cstr,omegas) -> + begin match cstr.cstr_tag with + | Cstr_extension _ -> + let nargs = List.length omegas in + (fun q rem -> match q.pat_desc with + | Tpat_construct (_, cstr',args) + when List.length args = nargs -> + p,args @ rem + | Tpat_any -> p,omegas @ rem + | _ -> raise NoMatch) + | _ -> + (fun q rem -> match q.pat_desc with + | Tpat_construct (_, cstr',args) + when cstr.cstr_tag=cstr'.cstr_tag -> + p,args @ rem + | Tpat_any -> p,omegas @ rem + | _ -> raise NoMatch) + end | Tpat_constant cst -> (fun q rem -> match q.pat_desc with | Tpat_constant cst' when const_compare cst cst' = 0 -> @@ -412,6 +431,7 @@ | PmOr x -> prerr_endline "++++ OR ++++" ; pretty_pm x.body ; + pretty_matrix x.or_matrix ; List.iter (fun (_,i,_,pm) -> eprintf "++ Handler %d ++\n" i ; @@ -428,67 +448,123 @@ -(* A slight attempt to identify semantically equivalent lambda-expressions *) -exception Not_simple +(* Identifing some semantically equivalent lambda-expressions, + Our goal here is also to + find alpha-equivalent (simple) terms *) + +(* However, as shown by PR#6359 such sharing may hinders the + lambda-code invariant that all bound idents are unique, + when switchs are compiled to test sequences. + The definitive fix is the systematic introduction of exit/catch + in case action sharing is present. +*) + + +module StoreExp = + Switch.Store + (struct + type t = lambda + type key = lambda + let make_key = Lambda.make_key + end) + + +let make_exit i = Lstaticraise (i,[]) + +(* Introduce a catch, if worth it *) +let make_catch d k = match d with +| Lstaticraise (_,[]) -> k d +| _ -> + let e = next_raise_count () in + Lstaticcatch (k (make_exit e),(e,[]),d) + +(* Introduce a catch, if worth it, delayed version *) +let rec as_simple_exit = function + | Lstaticraise (i,[]) -> Some i + | Llet (Alias,_,_,e) -> as_simple_exit e + | _ -> None -let rec raw_rec env : lambda -> lambda = function - | Llet(Alias,x,ex, body) -> raw_rec ((x,raw_rec env ex)::env) body - | Lvar id as l -> - begin try List.assoc id env with - | Not_found -> l - end - | Lprim (Pfield i,args) -> - Lprim (Pfield i, List.map (raw_rec env) args) - | Lconst _ as l -> l - | Lstaticraise (i,args) -> - Lstaticraise (i, List.map (raw_rec env) args) - | _ -> raise Not_simple -let raw_action l = try raw_rec [] l with Not_simple -> l +let make_catch_delayed handler = match as_simple_exit handler with +| Some i -> i,(fun act -> act) +| None -> + let i = next_raise_count () in +(* + Printf.eprintf "SHARE LAMBDA: %i\n%s\n" i (string_of_lam handler); +*) + i, + (fun body -> match body with + | Lstaticraise (j,_) -> + if i=j then handler else body + | _ -> Lstaticcatch (body,(i,[]),handler)) + + +let raw_action l = + match make_key l with | Some l -> l | None -> l + + +let tr_raw act = match make_key act with +| Some act -> act +| None -> raise Exit let same_actions = function | [] -> None | [_,act] -> Some act | (_,act0) :: rem -> try - let raw_act0 = raw_rec [] act0 in + let raw_act0 = tr_raw act0 in let rec s_rec = function | [] -> Some act0 | (_,act)::rem -> - if raw_act0 = raw_rec [] act then + if raw_act0 = tr_raw act then s_rec rem else None in s_rec rem with - | Not_simple -> None + | Exit -> None -let equal_action act1 act2 = - try - let raw1 = raw_rec [] act1 - and raw2 = raw_rec [] act2 in - raw1 = raw2 - with - | Not_simple -> false (* Test for swapping two clauses *) let up_ok_action act1 act2 = try - let raw1 = raw_rec [] act1 - and raw2 = raw_rec [] act2 in - match raw1, raw2 with - | Lstaticraise (i1,[]), Lstaticraise (i2,[]) -> i1=i2 - | _,_ -> raw1 = raw2 + let raw1 = tr_raw act1 + and raw2 = tr_raw act2 in + raw1 = raw2 with - | Not_simple -> false + | Exit -> false + +(* Nothing is kown about exception/extension patterns, + because of potential rebind *) +let rec exc_inside p = match p.pat_desc with + | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> true + | Tpat_any|Tpat_constant _|Tpat_var _ + | Tpat_construct (_,_,[]) + | Tpat_variant (_,None,_) + -> false + | Tpat_construct (_,_,ps) + | Tpat_tuple ps + | Tpat_array ps + -> exc_insides ps + | Tpat_variant (_, Some q,_) + | Tpat_alias (q,_,_) + | Tpat_lazy q + -> exc_inside q + | Tpat_record (lps,_) -> + List.exists (fun (_,_,p) -> exc_inside p) lps + | Tpat_or (p1,p2,_) -> exc_inside p1 || exc_inside p2 + +and exc_insides ps = List.exists exc_inside ps let up_ok (ps,act_p) l = - List.for_all - (fun (qs,act_q) -> - up_ok_action act_p act_q || - not (Parmatch.compats ps qs)) - l + if exc_insides ps then match l with [] -> true | _::_ -> false + else + List.for_all + (fun (qs,act_q) -> + up_ok_action act_p act_q || + not (Parmatch.compats ps qs)) + l (* @@ -584,6 +660,16 @@ (* A few operation on default environments *) let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases) +(* For extension matching, record no imformation in matrix *) +let as_matrix_omega cases = + get_mins le_pats + (List.map + (fun (ps,_) -> + match ps with + | [] -> assert false + | _::ps -> omega::ps) + cases) + let cons_default matrix raise_num default = match matrix with | [] -> default @@ -614,7 +700,7 @@ List.fold_left (fun r (_, _, p) -> extract_vars r p) r lpats -| Tpat_construct (_, _, pats,_) -> +| Tpat_construct (_, _, pats) -> List.fold_left extract_vars r pats | Tpat_array pats -> List.fold_left extract_vars r pats @@ -658,13 +744,16 @@ (* Basic grouping predicates *) +let pat_as_constr = function + | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr + | _ -> fatal_error "Matching.pat_as_constr" let group_constant = function | {pat_desc= Tpat_constant _} -> true | _ -> false and group_constructor = function - | {pat_desc = Tpat_construct _} -> true + | {pat_desc = Tpat_construct (_,_,_)} -> true | _ -> false and group_variant = function @@ -847,10 +936,74 @@ do_split [] [] [] cls +(* Ultra-naive spliting, close to semantics, used for extension, + as potential rebind prevents any kind of optimisation *) + +and split_naive cls args def k = + + let rec split_exc cstr0 yes = function + | [] -> + let yes = List.rev yes in + { me = Pm {cases=yes; args=args; default=def;} ; + matrix = as_matrix_omega yes ; + top_default=def}, + k + | (p::_,_ as cl)::rem -> + if group_constructor p then + let cstr = pat_as_constr p in + if cstr = cstr0 then split_exc cstr0 (cl::yes) rem + else + let yes = List.rev yes in + let {me=next ; matrix=matrix ; top_default=def}, nexts = + split_exc cstr [cl] rem in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + { me = Pm {cases=yes; args=args; default=def} ; + matrix = as_matrix_omega yes ; + top_default = def; }, + (idef,next)::nexts + else + let yes = List.rev yes in + let {me=next ; matrix=matrix ; top_default=def}, nexts = + split_noexc [cl] rem in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + { me = Pm {cases=yes; args=args; default=def} ; + matrix = as_matrix_omega yes ; + top_default = def; }, + (idef,next)::nexts + | _ -> assert false + + and split_noexc yes = function + | [] -> precompile_var args (List.rev yes) def k + | (p::_,_ as cl)::rem -> + if group_constructor p then + let yes= List.rev yes in + let {me=next; matrix=matrix; top_default=def;},nexts = + split_exc (pat_as_constr p) [cl] rem in + let idef = next_raise_count () in + precompile_var + args yes + (cons_default matrix idef def) + ((idef,next)::nexts) + else split_noexc (cl::yes) rem + | _ -> assert false in + + match cls with + | [] -> assert false + | (p::_,_ as cl)::rem -> + if group_constructor p then + split_exc (pat_as_constr p) [cl] rem + else + split_noexc [cl] rem + | _ -> assert false + and split_constr cls args def k = let ex_pat = what_is_cases cls in match ex_pat.pat_desc with | Tpat_any -> precompile_var args cls def k + | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> + split_naive cls args def k | _ -> let group = get_group ex_pat in @@ -956,12 +1109,21 @@ matrix=as_matrix cls ; top_default=def},k +and is_exc p = match p.pat_desc with +| Tpat_or (p1,p2,_) -> is_exc p1 || is_exc p2 +| Tpat_alias (p,v,_) -> is_exc p +| Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> true +| _ -> false + and precompile_or argo cls ors args def k = match ors with | [] -> split_constr cls args def k | _ -> let rec do_cases = function | ({pat_desc=Tpat_or _} as orp::patl, action)::rem -> - let others,rem = get_equiv orp rem in + let do_opt = not (is_exc orp) in + let others,rem = + if do_opt then get_equiv orp rem + else [],rem in let orpm = {cases = (patl, action):: @@ -971,7 +1133,7 @@ | _ -> assert false) others ; args = (match args with _::r -> r | _ -> assert false) ; - default = default_compat orp def} in + default = default_compat (if do_opt then orp else omega) def} in let vars = IdentSet.elements (IdentSet.inter @@ -984,17 +1146,19 @@ Lstaticraise (or_num, List.map (fun v -> Lvar v) vs) in - let body,handlers = do_cases rem in + let do_optrec,body,handlers = do_cases rem in + do_opt && do_optrec, explode_or_pat argo new_patl mk_new_action body vars [] orp, - (([[orp]], or_num, vars , orpm):: handlers) + let mat = if do_opt then [[orp]] else [[omega]] in + ((mat, or_num, vars , orpm):: handlers) | cl::rem -> - let new_ord,new_to_catch = do_cases rem in - cl::new_ord,new_to_catch - | [] -> [],[] in + let b,new_ord,new_to_catch = do_cases rem in + b,cl::new_ord,new_to_catch + | [] -> true,[],[] in - let end_body, handlers = do_cases ors in - let matrix = as_matrix (cls@ors) + let do_opt,end_body, handlers = do_cases ors in + let matrix = (if do_opt then as_matrix else as_matrix_omega) (cls@ors) and body = {cases=cls@end_body ; args=args ; default=def} in {me = PmOr {body=body ; handlers=handlers ; or_matrix=matrix} ; matrix=matrix ; @@ -1003,13 +1167,12 @@ let split_precompile argo pm = let {me=next}, nexts = split_or argo pm.cases pm.args pm.default in -(* - if nexts <> [] || (match next with PmOr _ -> true | _ -> false) then begin + if dbg && (nexts <> [] || (match next with PmOr _ -> true | _ -> false)) + then begin prerr_endline "** SPLIT **" ; pretty_pm pm ; pretty_precompiled_res next nexts end ; -*) next, nexts @@ -1129,18 +1292,13 @@ in make_args first_pos let get_key_constr = function - | {pat_desc=Tpat_construct (_, cstr,_,_)} -> cstr.cstr_tag + | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr.cstr_tag | _ -> assert false let get_args_constr p rem = match p with -| {pat_desc=Tpat_construct (_, _, args, _)} -> args @ rem +| {pat_desc=Tpat_construct (_, _, args)} -> args @ rem | _ -> assert false -let pat_as_constr = function - | {pat_desc=Tpat_construct (_, cstr,_,_)} -> cstr - | _ -> fatal_error "Matching.pat_as_constr" - - let matcher_constr cstr = match cstr.cstr_arity with | 0 -> let rec matcher_rec q rem = match q.pat_desc with @@ -1151,7 +1309,7 @@ with | NoMatch -> matcher_rec p2 rem end - | Tpat_construct (_, cstr1, [],_) when cstr.cstr_tag = cstr1.cstr_tag -> + | Tpat_construct (_, cstr1, []) when cstr.cstr_tag = cstr1.cstr_tag -> rem | Tpat_any -> rem | _ -> raise NoMatch in @@ -1172,7 +1330,7 @@ rem | _, _ -> assert false end - | Tpat_construct (_, cstr1, [arg],_) + | Tpat_construct (_, cstr1, [arg]) when cstr.cstr_tag = cstr1.cstr_tag -> arg::rem | Tpat_any -> omega::rem | _ -> raise NoMatch in @@ -1180,7 +1338,7 @@ | _ -> fun q rem -> match q.pat_desc with | Tpat_or (_,_,_) -> raise OrPat - | Tpat_construct (_, cstr1, args,_) + | Tpat_construct (_, cstr1, args) when cstr.cstr_tag = cstr1.cstr_tag -> args @ rem | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem | _ -> raise NoMatch @@ -1193,7 +1351,7 @@ match cstr.cstr_tag with Cstr_constant _ | Cstr_block _ -> make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl - | Cstr_exception _ -> + | Cstr_extension _ -> make_field_args Alias arg 1 cstr.cstr_arity argl in {pm= {cases = []; args = newargs; @@ -1324,7 +1482,7 @@ lazy ( try let mod_ident = Ident.create_persistent modname in - let env = Env.open_pers_signature modname Env.initial in + let env = Env.open_pers_signature modname Env.initial_safe_string in let p = try match Env.lookup_value (Longident.Lident field) env with | (Path.Pdot(_,_,i), _) -> i @@ -1446,7 +1604,7 @@ let record_matching_line num_fields lbl_pat_list = - let patv = Array.create num_fields omega in + let patv = Array.make num_fields omega in List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; Array.to_list patv @@ -1527,10 +1685,161 @@ (make_array_matching kind) (=) get_key_array get_args_array ctx pm -(* To combine sub-matchings together *) + +(* + Specific string test sequence + Will be called by the bytecode compiler, from bytegen.ml. + The strategy is first dichotomic search (we perform 3-way tests + with compare_string), then sequence of equality tests + when there are less then T=strings_test_threshold static strings to match. + + Increasing T entails (slightly) less code, decreasing T + (slightly) favors runtime speed. + T=8 looks a decent tradeoff. +*) + +(* Utilities *) + +let strings_test_threshold = 8 + +let prim_string_notequal = + Pccall{prim_name = "caml_string_notequal"; + prim_arity = 2; prim_alloc = false; + prim_native_name = ""; prim_native_float = false} + +let prim_string_compare = + Pccall{prim_name = "caml_string_compare"; + prim_arity = 2; prim_alloc = false; + prim_native_name = ""; prim_native_float = false} + +let bind_sw arg k = match arg with +| Lvar _ -> k arg +| _ -> + let id = Ident.create "switch" in + Llet (Strict,id,arg,k (Lvar id)) + + +(* Sequential equality tests *) + +let make_string_test_sequence arg sw d = + let d,sw = match d with + | None -> + begin match sw with + | (_,d)::sw -> d,sw + | [] -> assert false + end + | Some d -> d,sw in + bind_sw arg + (fun arg -> + List.fold_right + (fun (s,lam) k -> + Lifthenelse + (Lprim + (prim_string_notequal, + [arg; Lconst (Const_immstring s)]), + k,lam)) + sw d) + +let rec split k xs = match xs with +| [] -> assert false +| x0::xs -> + if k <= 1 then [],x0,xs + else + let xs,y0,ys = split (k-2) xs in + x0::xs,y0,ys + +let zero_lam = Lconst (Const_base (Const_int 0)) + +let tree_way_test arg lt eq gt = + Lifthenelse + (Lprim (Pintcomp Clt,[arg;zero_lam]),lt, + Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg]),gt,eq)) + +(* Dichotomic tree *) + + +let rec do_make_string_test_tree arg sw delta d = + let len = List.length sw in + if len <= strings_test_threshold+delta then + make_string_test_sequence arg sw d + else + let lt,(s,act),gt = split len sw in + bind_sw + (Lprim + (prim_string_compare, + [arg; Lconst (Const_immstring s)];)) + (fun r -> + tree_way_test r + (do_make_string_test_tree arg lt delta d) + act + (do_make_string_test_tree arg gt delta d)) + +(* Entry point *) +let expand_stringswitch arg sw d = match d with +| None -> + bind_sw arg + (fun arg -> do_make_string_test_tree arg sw 0 None) +| Some e -> + bind_sw arg + (fun arg -> + make_catch e + (fun d -> do_make_string_test_tree arg sw 1 (Some d))) + +(**********************) +(* Generic test trees *) +(**********************) + +(* Sharing *) + +(* Add handler, if shared *) +let handle_shared () = + let hs = ref (fun x -> x) in + let handle_shared act = match act with + | Switch.Single act -> act + | Switch.Shared act -> + let i,h = make_catch_delayed act in + let ohs = !hs in + hs := (fun act -> h (ohs act)) ; + make_exit i in + hs,handle_shared + + +let share_actions_tree sw d = + let store = StoreExp.mk_store () in +(* Default action is always shared *) + let d = + match d with + | None -> None + | Some d -> Some (store.Switch.act_store_shared d) in +(* Store all other actions *) + let sw = + List.map (fun (cst,act) -> cst,store.Switch.act_store act) sw in + +(* Retrieve all actions, includint potentiel default *) + let acts = store.Switch.act_get_shared () in + +(* Array of actual actions *) + let hs,handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + +(* Recontruct default and switch list *) + let d = match d with + | None -> None + | Some d -> Some (acts.(d)) in + let sw = List.map (fun (cst,j) -> cst,acts.(j)) sw in + !hs,sw,d + +(* Note: dichotomic search requires sorted input with no duplicates *) +let rec uniq_lambda_list sw = match sw with + | []|[_] -> sw + | (c1,_ as p1)::((c2,_)::sw2 as sw1) -> + if const_compare c1 c2 = 0 then uniq_lambda_list (p1::sw2) + else p1::uniq_lambda_list sw1 let sort_lambda_list l = - List.sort (fun (x,_) (y,_) -> const_compare x y) l + let l = + List.stable_sort (fun (x,_) (y,_) -> const_compare x y) l in + uniq_lambda_list l let rec cut n l = if n = 0 then [],l @@ -1556,8 +1865,12 @@ act) let make_test_sequence fail tst lt_tst arg const_lambda_list = + let const_lambda_list = sort_lambda_list const_lambda_list in + let hs,const_lambda_list,fail = + share_actions_tree const_lambda_list fail in + let rec make_test_sequence const_lambda_list = - if List.length const_lambda_list >= 4 && lt_tst <> Praise then + if List.length const_lambda_list >= 4 && lt_tst <> Pignore then split_sequence const_lambda_list else match fail with | None -> do_tests_nofail tst arg const_lambda_list @@ -1568,18 +1881,10 @@ cut (List.length const_lambda_list / 2) const_lambda_list in Lifthenelse(Lprim(lt_tst,[arg; Lconst(Const_base (fst(List.hd list2)))]), make_test_sequence list1, make_test_sequence list2) - in make_test_sequence (sort_lambda_list const_lambda_list) - - -let make_offset x arg = if x=0 then arg else Lprim(Poffsetint(x), [arg]) - + in + hs (make_test_sequence const_lambda_list) -let prim_string_notequal = - Pccall{prim_name = "caml_string_notequal"; - prim_arity = 2; prim_alloc = false; - prim_native_name = ""; prim_native_float = false} - let rec explode_inter offset i j act k = if i <= j then explode_inter offset i (j-1) act ((j-offset,act)::k) @@ -1587,7 +1892,7 @@ k let max_vals cases acts = - let vals = Array.create (Array.length acts) 0 in + let vals = Array.make (Array.length acts) 0 in for i=Array.length cases-1 downto 0 do let l,h,act = cases.(i) in vals.(act) <- h - l + 1 + vals.(act) @@ -1620,65 +1925,6 @@ (if default >= 0 then Some acts.(default) else None) -let make_switch_offset arg min_key max_key int_lambda_list default = - let numcases = max_key - min_key + 1 in - let cases = - List.map (fun (key, l) -> (key - min_key, l)) int_lambda_list in - let offsetarg = make_offset (-min_key) arg in - Lswitch(offsetarg, - {sw_numconsts = numcases; sw_consts = cases; - sw_numblocks = 0; sw_blocks = []; - sw_failaction = default}) - -let make_switch_switcher arg cases acts = - let l = ref [] in - for i = Array.length cases-1 downto 0 do - l := (i,acts.(cases.(i))) :: !l - done ; - Lswitch(arg, - {sw_numconsts = Array.length cases ; sw_consts = !l ; - sw_numblocks = 0 ; sw_blocks = [] ; - sw_failaction = None}) - -let full sw = - List.length sw.sw_consts = sw.sw_numconsts && - List.length sw.sw_blocks = sw.sw_numblocks - -let make_switch (arg,sw) = match sw.sw_failaction with -| None -> - let t = Hashtbl.create 17 in - let seen l = match l with - | Lstaticraise (i,[]) -> - let old = try Hashtbl.find t i with Not_found -> 0 in - Hashtbl.replace t i (old+1) - | _ -> () in - List.iter (fun (_,lam) -> seen lam) sw.sw_consts ; - List.iter (fun (_,lam) -> seen lam) sw.sw_blocks ; - let i_max = ref (-1) - and max = ref (-1) in - Hashtbl.iter - (fun i c -> - if c > !max then begin - i_max := i ; - max := c - end) t ; - if !i_max >= 0 then - let default = !i_max in - let rec remove = function - | [] -> [] - | (_,Lstaticraise (j,[]))::rem when j=default -> - remove rem - | x::rem -> x::remove rem in - Lswitch - (arg, - {sw with -sw_consts = remove sw.sw_consts ; -sw_blocks = remove sw.sw_blocks ; -sw_failaction = Some (Lstaticraise (default,[]))}) - else - Lswitch (arg,sw) -| _ -> Lswitch (arg,sw) - module SArg = struct type primitive = Lambda.primitive @@ -1695,6 +1941,7 @@ let make_offset arg n = match n with | 0 -> arg | _ -> Lprim (Poffsetint n,[arg]) + let bind arg body = let newvar,newarg = match arg with | Lvar v -> v,arg @@ -1702,13 +1949,89 @@ let newvar = Ident.create "switcher" in newvar,Lvar newvar in bind Alias newvar arg (body newarg) - + let make_const i = Lconst (Const_base (Const_int i)) let make_isout h arg = Lprim (Pisout, [h ; arg]) let make_isin h arg = Lprim (Pnot,[make_isout h arg]) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) - let make_switch = make_switch_switcher + let make_switch arg cases acts = + let l = ref [] in + for i = Array.length cases-1 downto 0 do + l := (i,acts.(cases.(i))) :: !l + done ; + Lswitch(arg, + {sw_numconsts = Array.length cases ; sw_consts = !l ; + sw_numblocks = 0 ; sw_blocks = [] ; + sw_failaction = None}) + let make_catch = make_catch_delayed + let make_exit = make_exit + end +(* Action sharing for Lswitch argument *) +let share_actions_sw sw = +(* Attempt sharing on all actions *) + let store = StoreExp.mk_store () in + let fail = match sw.sw_failaction with + | None -> None + | Some fail -> + (* Fail is translated to exit, whatever happens *) + Some (store.Switch.act_store_shared fail) in + let consts = + List.map + (fun (i,e) -> i,store.Switch.act_store e) + sw.sw_consts + and blocks = + List.map + (fun (i,e) -> i,store.Switch.act_store e) + sw.sw_blocks in + let acts = store.Switch.act_get_shared () in + let hs,handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + let fail = match fail with + | None -> None + | Some fail -> Some (acts.(fail)) in + !hs, + { sw with + sw_consts = List.map (fun (i,j) -> i,acts.(j)) consts ; + sw_blocks = List.map (fun (i,j) -> i,acts.(j)) blocks ; + sw_failaction = fail; } + +(* Reintroduce fail action in switch argument, + for the sake of avoiding carrying over huge switches *) + +let reintroduce_fail sw = match sw.sw_failaction with +| None -> + let t = Hashtbl.create 17 in + let seen (_,l) = match as_simple_exit l with + | Some i -> + let old = try Hashtbl.find t i with Not_found -> 0 in + Hashtbl.replace t i (old+1) + | None -> () in + List.iter seen sw.sw_consts ; + List.iter seen sw.sw_blocks ; + let i_max = ref (-1) + and max = ref (-1) in + Hashtbl.iter + (fun i c -> + if c > !max then begin + i_max := i ; + max := c + end) t ; + if !max >= 3 then + let default = !i_max in + let remove = + List.filter + (fun (_,lam) -> match as_simple_exit lam with + | Some j -> j <> default + | None -> true) in + {sw with + sw_consts = remove sw.sw_consts ; + sw_blocks = remove sw.sw_blocks ; + sw_failaction = Some (make_exit default)} + else sw +| Some _ -> sw + + module Switcher = Switch.Make(SArg) open Switch @@ -1725,7 +2048,16 @@ let as_interval_canfail fail low high l = - let store = mk_store equal_action in + let store = StoreExp.mk_store () in + + let do_store tag act = + let i = store.act_store act in +(* + Printlambda.lambda Format.str_formatter act ; + eprintf "STORE [%s] %i %s\n" tag i (Format.flush_str_formatter ()) ; +*) + i in + let rec nofail_rec cur_low cur_high cur_act = function | [] -> if cur_high = high then @@ -1733,7 +2065,7 @@ else [(cur_low,cur_high,cur_act) ; (cur_high+1,high, 0)] | ((i,act_i)::rem) as all -> - let act_index = store.act_store act_i in + let act_index = do_store "NO" act_i in if cur_high+1= i then if act_index=cur_act then nofail_rec cur_low i cur_act rem @@ -1741,14 +2073,18 @@ (cur_low,i-1, cur_act)::fail_rec i i rem else (cur_low, i-1, cur_act)::nofail_rec i i act_index rem + else if act_index = 0 then + (cur_low, cur_high, cur_act):: + fail_rec (cur_high+1) (cur_high+1) all else (cur_low, cur_high, cur_act):: - fail_rec ((cur_high+1)) (cur_high+1) all + (cur_high+1,i-1,0):: + nofail_rec i i act_index rem and fail_rec cur_low cur_high = function | [] -> [(cur_low, cur_high, 0)] | (i,act_i)::rem -> - let index = store.act_store act_i in + let index = do_store "YES" act_i in if index=0 then fail_rec cur_low i rem else (cur_low,i-1,0):: @@ -1757,7 +2093,7 @@ let init_rec = function | [] -> [] | (i,act_i)::rem -> - let index = store.act_store act_i in + let index = do_store "INIT" act_i in if index=0 then fail_rec low i rem else @@ -1766,12 +2102,12 @@ else nofail_rec i i index rem in - ignore (store.act_store fail) ; (* fail has action index 0 *) + assert (do_store "FAIL" fail = 0) ; (* fail has action index 0 *) let r = init_rec l in - Array.of_list r, store.act_get () + Array.of_list r, store let as_interval_nofail l = - let store = mk_store equal_action in + let store = StoreExp.mk_store () in let rec i_rec cur_low cur_high cur_act = function | [] -> @@ -1789,7 +2125,7 @@ i_rec i i act_index rem | _ -> assert false in - Array.of_list inters, store.act_get () + Array.of_list inters, store let sort_int_lambda_list l = @@ -1807,10 +2143,10 @@ | None -> as_interval_nofail l | Some act -> as_interval_canfail act low high l) -let call_switcher konst fail arg low high int_lambda_list = +let call_switcher fail arg low high int_lambda_list = let edges, (cases, actions) = as_interval fail low high int_lambda_list in - Switcher.zyva edges konst arg cases actions + Switcher.zyva edges arg cases actions let exists_ctx ok ctx = @@ -1920,6 +2256,11 @@ (* Conforme a l'article et plus simple qu'avant *) and mk_failaction_pos partial seen ctx defs = + if dbg then begin + prerr_endline "**POS**" ; + pretty_def defs ; + () + end ; let rec scan_def env to_test defs = match to_test,defs with | ([],_)|(_,[]) -> List.fold_left @@ -1960,19 +2301,27 @@ let int_lambda_list = List.map (function Const_int n, l -> n,l | _ -> assert false) const_lambda_list in - call_switcher - lambda_of_int fail arg min_int max_int int_lambda_list + call_switcher fail arg min_int max_int int_lambda_list | Const_char _ -> let int_lambda_list = List.map (function Const_char c, l -> (Char.code c, l) | _ -> assert false) const_lambda_list in - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - fail arg 0 255 int_lambda_list + call_switcher fail arg 0 255 int_lambda_list | Const_string _ -> - make_test_sequence - fail prim_string_notequal Praise arg const_lambda_list +(* Note as the bytecode compiler may resort to dichotmic search, + the clauses of strinswitch are sorted with duplicate removed. + This partly applies to the native code compiler, which requires + no duplicates *) + let const_lambda_list = sort_lambda_list const_lambda_list in + let sw = + List.map + (fun (c,act) -> match c with + | Const_string (s,_) -> s,act + | _ -> assert false) + const_lambda_list in + let hs,sw,fail = share_actions_tree sw fail in + hs (Lstringswitch (arg,sw,fail)) | Const_float _ -> make_test_sequence fail @@ -2010,32 +2359,61 @@ sort_int_lambda_list const, sort_int_lambda_list nonconst +let split_extension_cases tag_lambda_list = + let rec split_rec = function + [] -> ([], []) + | (cstr, act) :: rem -> + let (consts, nonconsts) = split_rec rem in + match cstr with + Cstr_extension(path, true) -> ((path, act) :: consts, nonconsts) + | Cstr_extension(path, false) -> (consts, (path, act) :: nonconsts) + | _ -> assert false in + split_rec tag_lambda_list + let combine_constructor arg ex_pat cstr partial ctx def (tag_lambda_list, total1, pats) = if cstr.cstr_consts < 0 then begin - (* Special cases for exceptions *) + (* Special cases for extensions *) let fail, to_add, local_jumps = mk_failaction_neg partial ctx def in let tag_lambda_list = to_add@tag_lambda_list in let lambda1 = - let default, tests = + let consts, nonconsts = split_extension_cases tag_lambda_list in + let default, consts, nonconsts = match fail with | None -> - begin match tag_lambda_list with - | (_, act)::rem -> act,rem + begin match consts, nonconsts with + | _, (_, act)::rem -> act, consts, rem + | (_, act)::rem, _ -> act, rem, nonconsts | _ -> assert false end - | Some fail -> fail, tag_lambda_list in - List.fold_right - (fun (ex, act) rem -> - match ex with - | Cstr_exception (path, _) -> - Lifthenelse(Lprim(Pintcomp Ceq, - [Lprim(Pfield 0, [arg]); transl_path path]), - act, rem) - | _ -> assert false) - tests default in + | Some fail -> fail, consts, nonconsts in + let nonconst_lambda = + match nonconsts with + [] -> default + | _ -> + let tag = Ident.create "tag" in + let tests = + List.fold_right + (fun (path, act) rem -> + Lifthenelse(Lprim(Pintcomp Ceq, + [Lvar tag; + transl_path ex_pat.pat_env path]), + act, rem)) + nonconsts + default + in + Llet(Alias, tag, Lprim(Pfield 0, [arg]), tests) + in + List.fold_right + (fun (path, act) rem -> + Lifthenelse(Lprim(Pintcomp Ceq, + [arg; transl_path ex_pat.pat_env path]), + act, rem)) + consts + nonconst_lambda + in lambda1, jumps_union local_jumps total1 end else begin (* Regular concrete type *) @@ -2059,22 +2437,22 @@ | (1, 1, [0, act1], [0, act2]) -> Lifthenelse(arg, act2, act1) | (n,_,_,[]) -> - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - None arg 0 (n-1) consts + call_switcher None arg 0 (n-1) consts | (n, _, _, _) -> match same_actions nonconsts with | None -> - make_switch(arg, {sw_numconsts = cstr.cstr_consts; - sw_consts = consts; - sw_numblocks = cstr.cstr_nonconsts; - sw_blocks = nonconsts; - sw_failaction = None}) +(* Emit a switch, as bytecode implements this sophisticated instruction *) + let sw = + {sw_numconsts = cstr.cstr_consts; sw_consts = consts; + sw_numblocks = cstr.cstr_nonconsts; sw_blocks = nonconsts; + sw_failaction = None} in + let hs,sw = share_actions_sw sw in + let sw = reintroduce_fail sw in + hs (Lswitch (arg,sw)) | Some act -> Lifthenelse (Lprim (Pisint, [arg]), call_switcher - (fun i -> Lconst (Const_base (Const_int i))) None arg 0 (n-1) consts, act) in @@ -2084,20 +2462,16 @@ let make_test_sequence_variant_constant fail arg int_lambda_list = let _, (cases, actions) = as_interval fail min_int max_int int_lambda_list in - Switcher.test_sequence - (fun i -> Lconst (Const_base (Const_int i))) arg cases actions + Switcher.test_sequence arg cases actions let call_switcher_variant_constant fail arg int_lambda_list = - call_switcher - (fun i -> Lconst (Const_base (Const_int i))) - fail arg min_int max_int int_lambda_list + call_switcher fail arg min_int max_int int_lambda_list let call_switcher_variant_constr fail arg int_lambda_list = let v = Ident.create "variant" in Llet(Alias, v, Lprim(Pfield 0, [arg]), call_switcher - (fun i -> Lconst (Const_base (Const_int i))) fail (Lvar v) min_int max_int int_lambda_list) let combine_variant row arg partial ctx def (tag_lambda_list, total1, pats) = @@ -2161,7 +2535,6 @@ let newvar = Ident.create "len" in let switch = call_switcher - lambda_of_int fail (Lvar newvar) 0 max_int len_lambda_list in bind @@ -2280,10 +2653,6 @@ | Lvar vv -> Ident.same v vv | _ -> true -let string_of_lam lam = - Printlambda.lambda Format.str_formatter lam ; - Format.flush_str_formatter () - let rec lower_bind v arg lam = match lam with | Lifthenelse (cond, ifso, ifnot) -> let pcond = approx_present v cond @@ -2385,8 +2754,6 @@ Output: a lambda term, a jump summary {..., exit number -> context, .. } *) -let dbg = false - let rec compile_match repr partial ctx m = match m with | { cases = [] } -> comp_exit ctx m | { cases = ([], action) :: rem } -> @@ -2444,7 +2811,7 @@ divide_constant (combine_constant arg cst partial) ctx pm - | Tpat_construct (_, cstr, _, _) -> + | Tpat_construct (_, cstr, _) -> compile_test (compile_match repr partial) partial divide_constructor (combine_constructor arg pat cstr partial) @@ -2507,7 +2874,7 @@ begin match p.pat_desc with | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p -> find_rec p - | Tpat_tuple ps|Tpat_construct (_,_,ps,_) | Tpat_array ps -> + | Tpat_tuple ps|Tpat_construct (_,_,ps) | Tpat_array ps -> List.exists find_rec ps | Tpat_record (lpats,_) -> List.exists @@ -2604,10 +2971,10 @@ let partial_function loc () = (* [Location.get_pos_info] is too expensive *) let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in - Lprim(Praise, [Lprim(Pmakeblock(0, Immutable), - [transl_path Predef.path_match_failure; + Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable), + [transl_normal_path Predef.path_match_failure; Lconst(Const_block(0, - [Const_base(Const_string fname); + [Const_base(Const_string (fname, None)); Const_base(Const_int line); Const_base(Const_int char)]))])]) @@ -2616,7 +2983,8 @@ (* In the following two cases, exhaustiveness info is not available! *) let for_trywith param pat_act_list = - compile_matching Location.none None (fun () -> Lprim(Praise, [param])) + compile_matching Location.none None + (fun () -> Lprim(Praise Raise_reraise, [param])) param pat_act_list Partial let for_let loc param pat body = diff -Nru ocaml-4.01.0/bytecomp/matching.mli ocaml-4.02.3/bytecomp/matching.mli --- ocaml-4.01.0/bytecomp/matching.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/matching.mli 2014-04-07 17:43:20.000000000 +0200 @@ -15,6 +15,8 @@ open Typedtree open Lambda + +(* Entry points to match compiler *) val for_function: Location.t -> int ref option -> lambda -> (pattern * lambda) list -> partial -> lambda @@ -34,8 +36,8 @@ val flatten_pattern: int -> pattern -> pattern list -val make_test_sequence: - lambda option -> primitive -> primitive -> lambda -> - (Asttypes.constant * lambda) list -> lambda +(* Expand stringswitch to string test tree *) +val expand_stringswitch: + lambda -> (string * lambda) list -> lambda option -> lambda val inline_lazy_force : lambda -> Location.t -> lambda diff -Nru ocaml-4.01.0/bytecomp/meta.ml ocaml-4.02.3/bytecomp/meta.ml --- ocaml-4.01.0/bytecomp/meta.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/meta.ml 2014-04-29 13:56:17.000000000 +0200 @@ -12,13 +12,13 @@ external global_data : unit -> Obj.t array = "caml_get_global_data" external realloc_global_data : int -> unit = "caml_realloc_global" -external static_alloc : int -> string = "caml_static_alloc" -external static_free : string -> unit = "caml_static_free" -external static_resize : string -> int -> string = "caml_static_resize" -external static_release_bytecode : string -> int -> unit +external static_alloc : int -> bytes = "caml_static_alloc" +external static_free : bytes -> unit = "caml_static_free" +external static_resize : bytes -> int -> bytes = "caml_static_resize" +external static_release_bytecode : bytes -> int -> unit = "caml_static_release_bytecode" type closure = unit -> Obj.t -external reify_bytecode : string -> int -> closure = "caml_reify_bytecode" +external reify_bytecode : bytes -> int -> closure = "caml_reify_bytecode" external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t = "caml_invoke_traced_function" external get_section_table : unit -> (string * Obj.t) list diff -Nru ocaml-4.01.0/bytecomp/meta.mli ocaml-4.02.3/bytecomp/meta.mli --- ocaml-4.01.0/bytecomp/meta.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/meta.mli 2014-04-29 13:56:17.000000000 +0200 @@ -14,13 +14,13 @@ external global_data : unit -> Obj.t array = "caml_get_global_data" external realloc_global_data : int -> unit = "caml_realloc_global" -external static_alloc : int -> string = "caml_static_alloc" -external static_free : string -> unit = "caml_static_free" -external static_release_bytecode : string -> int -> unit +external static_alloc : int -> bytes = "caml_static_alloc" +external static_free : bytes -> unit = "caml_static_free" +external static_release_bytecode : bytes -> int -> unit = "caml_static_release_bytecode" -external static_resize : string -> int -> string = "caml_static_resize" +external static_resize : bytes -> int -> bytes = "caml_static_resize" type closure = unit -> Obj.t -external reify_bytecode : string -> int -> closure = "caml_reify_bytecode" +external reify_bytecode : bytes -> int -> closure = "caml_reify_bytecode" external invoke_traced_function : Obj.t -> Obj.t -> Obj.t -> Obj.t = "caml_invoke_traced_function" external get_section_table : unit -> (string * Obj.t) list diff -Nru ocaml-4.01.0/bytecomp/printinstr.ml ocaml-4.02.3/bytecomp/printinstr.ml --- ocaml-4.01.0/bytecomp/printinstr.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/printinstr.ml 2013-11-13 14:55:13.000000000 +0100 @@ -67,7 +67,7 @@ | Kboolnot -> fprintf ppf "\tboolnot" | Kpushtrap lbl -> fprintf ppf "\tpushtrap L%i" lbl | Kpoptrap -> fprintf ppf "\tpoptrap" - | Kraise -> fprintf ppf "\traise" + | Kraise k-> fprintf ppf "\t%s" (Lambda.raise_kind k) | Kcheck_signals -> fprintf ppf "\tcheck_signals" | Kccall(s, n) -> fprintf ppf "\tccall %s, %i" s n diff -Nru ocaml-4.01.0/bytecomp/printlambda.ml ocaml-4.02.3/bytecomp/printlambda.ml --- ocaml-4.01.0/bytecomp/printlambda.ml 2012-11-29 10:55:00.000000000 +0100 +++ ocaml-4.02.3/bytecomp/printlambda.ml 2014-05-02 14:47:02.000000000 +0200 @@ -20,7 +20,7 @@ let rec struct_const ppf = function | Const_base(Const_int n) -> fprintf ppf "%i" n | Const_base(Const_char c) -> fprintf ppf "%C" c - | Const_base(Const_string s) -> fprintf ppf "%S" s + | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s | Const_immstring s -> fprintf ppf "#%S" s | Const_base(Const_float f) -> fprintf ppf "%s" f | Const_base(Const_int32 n) -> fprintf ppf "%lil" n @@ -87,11 +87,19 @@ | Record_float -> fprintf ppf "float" ;; +let string_of_loc_kind = function + | Loc_FILE -> "loc_FILE" + | Loc_LINE -> "loc_LINE" + | Loc_MODULE -> "loc_MODULE" + | Loc_POS -> "loc_POS" + | Loc_LOC -> "loc_LOC" + let primitive ppf = function | Pidentity -> fprintf ppf "id" | Pignore -> fprintf ppf "ignore" | Prevapply _ -> fprintf ppf "revapply" | Pdirapply _ -> fprintf ppf "dirapply" + | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind) | Pgetglobal id -> fprintf ppf "global %a" Ident.print id | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag @@ -105,7 +113,7 @@ | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size | Plazyforce -> fprintf ppf "force" | Pccall p -> fprintf ppf "%s" p.prim_name - | Praise -> fprintf ppf "raise" + | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) | Psequand -> fprintf ppf "&&" | Psequor -> fprintf ppf "||" | Pnot -> fprintf ppf "not" @@ -229,6 +237,7 @@ else fprintf ppf "bigarray.array1.set64" | Pbswap16 -> fprintf ppf "bswap16" | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi + | Pint_as_pointer -> fprintf ppf "int_as_pointer" let rec lam ppf = function | Lvar id -> @@ -255,12 +264,15 @@ fprintf ppf ")" in fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body | Llet(str, id, arg, body) -> + let kind = function + Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" in let rec letbody = function | Llet(str, id, arg, body) -> - fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg; + fprintf ppf "@ @[<2>%a =%s@ %a@]" Ident.print id (kind str) lam arg; letbody body | expr -> expr in - fprintf ppf "@[<2>(let@ @[(@[<2>%a@ %a@]" Ident.print id lam arg; + fprintf ppf "@[<2>(let@ @[(@[<2>%a =%s@ %a@]" + Ident.print id (kind str) lam arg; let expr = letbody body in fprintf ppf ")@]@ %a)@]" lam expr | Lletrec(id_arg_list, body) -> @@ -296,11 +308,26 @@ if !spc then fprintf ppf "@ " else spc := true; fprintf ppf "@[default:@ %a@]" lam l end in - fprintf ppf "@[<1>(%s %a@ @[%a@])@]" (match sw.sw_failaction with None -> "switch*" | _ -> "switch") lam larg switch sw + | Lstringswitch(arg, cases, default) -> + let switch ppf cases = + let spc = ref false in + List.iter + (fun (s, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) + cases; + begin match default with + | Some default -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam default + | None -> () + end in + fprintf ppf + "@[<1>(stringswitch %a@ @[%a@])@]" lam arg switch cases | Lstaticraise (i, ls) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in diff -Nru ocaml-4.01.0/bytecomp/simplif.ml ocaml-4.02.3/bytecomp/simplif.ml --- ocaml-4.01.0/bytecomp/simplif.ml 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/bytecomp/simplif.ml 2014-05-05 13:49:37.000000000 +0200 @@ -51,9 +51,13 @@ sw_numblocks = sw.sw_numblocks; sw_blocks = List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks; - sw_failaction = match sw.sw_failaction with - | None -> None - | Some l -> Some (eliminate_ref id l)}) + sw_failaction = + Misc.may_map (eliminate_ref id) sw.sw_failaction; }) + | Lstringswitch(e, sw, default) -> + Lstringswitch + (eliminate_ref id e, + List.map (fun (s, e) -> (s, eliminate_ref id e)) sw, + Misc.may_map (eliminate_ref id) default) | Lstaticraise (i,args) -> Lstaticraise (i,List.map (eliminate_ref id) args) | Lstaticcatch(e1, i, e2) -> @@ -115,6 +119,15 @@ count l; List.iter (fun (_, l) -> count l) sw.sw_consts; List.iter (fun (_, l) -> count l) sw.sw_blocks + | Lstringswitch(l, sw, d) -> + count l; + List.iter (fun (_, l) -> count l) sw; + begin match d with + | None -> () + | Some d -> match sw with + | []|[_] -> count d + | _ -> count d; count d (* default will get replicated *) + end | Lstaticraise (i,ls) -> incr_exit i ; List.iter count ls | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) -> (* i will be replaced by j in l1, so each occurence of i in l1 @@ -138,10 +151,7 @@ | Lsequence(l1, l2) -> count l1; count l2 | Lwhile(l1, l2) -> count l1; count l2 | Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3 - | Lassign(v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refcount *) - count l + | Lassign(v, l) -> count l | Lsend(k, m, o, ll, _) -> List.iter count (m::o::ll) | Levent(l, _) -> count l | Lifused(v, l) -> count l @@ -209,13 +219,15 @@ let new_l = simplif l and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks - and new_fail = match sw.sw_failaction with - | None -> None - | Some l -> Some (simplif l) in + and new_fail = Misc.may_map simplif sw.sw_failaction in Lswitch (new_l, {sw with sw_consts = new_consts ; sw_blocks = new_blocks; sw_failaction = new_fail}) + | Lstringswitch(l,sw,d) -> + Lstringswitch + (simplif l,List.map (fun (s,l) -> s,simplif l) sw, + Misc.may_map simplif d) | Lstaticraise (i,[]) as l -> begin try let _,handler = Hashtbl.find subst i in @@ -241,17 +253,10 @@ | Lstaticcatch (l1,(i,[]),(Lstaticraise (j,[]) as l2)) -> Hashtbl.add subst i ([],simplif l2) ; simplif l1 - | Lstaticcatch (l1,(i,xs), (Lvar _ as l2)) -> - begin match count_exit i with - | 0 -> simplif l1 - | _ -> - Hashtbl.add subst i (xs,l2) ; - simplif l1 - end | Lstaticcatch (l1,(i,xs),l2) -> begin match count_exit i with | 0 -> simplif l1 - | 1 -> + | 1 when i >= 0 -> Hashtbl.add subst i (xs,simplif l2) ; simplif l1 | _ -> @@ -361,6 +366,17 @@ count bv l; List.iter (fun (_, l) -> count bv l) sw.sw_consts; List.iter (fun (_, l) -> count bv l) sw.sw_blocks + | Lstringswitch(l, sw, d) -> + count bv l ; + List.iter (fun (_, l) -> count bv l) sw ; + begin match d with + | Some d -> + begin match sw with + | []|[_] -> count bv d + | _ -> count bv d ; count bv d + end + | None -> () + end | Lstaticraise (i,ls) -> List.iter (count bv) ls | Lstaticcatch(l1, (i,_), l2) -> count bv l1; count bv l2 | Ltrywith(l1, v, l2) -> count bv l1; count bv l2 @@ -453,13 +469,15 @@ let new_l = simplif l and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts and new_blocks = List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks - and new_fail = match sw.sw_failaction with - | None -> None - | Some l -> Some (simplif l) in + and new_fail = Misc.may_map simplif sw.sw_failaction in Lswitch (new_l, {sw with sw_consts = new_consts ; sw_blocks = new_blocks; sw_failaction = new_fail}) + | Lstringswitch (l,sw,d) -> + Lstringswitch + (simplif l,List.map (fun (s,l) -> s,simplif l) sw, + Misc.may_map simplif d) | Lstaticraise (i,ls) -> Lstaticraise (i, List.map simplif ls) | Lstaticcatch(l1, (i,args), l2) -> @@ -520,7 +538,14 @@ | Lswitch (lam, sw) -> emit_tail_infos false lam; list_emit_tail_infos_fun snd is_tail sw.sw_consts; - list_emit_tail_infos_fun snd is_tail sw.sw_blocks + list_emit_tail_infos_fun snd is_tail sw.sw_blocks; + Misc.may (emit_tail_infos is_tail) sw.sw_failaction + | Lstringswitch (lam, sw, d) -> + emit_tail_infos false lam; + List.iter + (fun (_,lam) -> emit_tail_infos is_tail lam) + sw ; + Misc.may (emit_tail_infos is_tail) d | Lstaticraise (_, l) -> list_emit_tail_infos false l | Lstaticcatch (body, _, handler) -> diff -Nru ocaml-4.01.0/bytecomp/switch.ml ocaml-4.02.3/bytecomp/switch.ml --- ocaml-4.01.0/bytecomp/switch.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/bytecomp/switch.ml 2014-08-18 20:26:49.000000000 +0200 @@ -10,31 +10,81 @@ (* *) (***********************************************************************) -(* Store for actions in object style *) -exception Found of int + +type 'a shared = Shared of 'a | Single of 'a + +let share_out = function + | Shared act|Single act -> act + type 'a t_store = - {act_get : unit -> 'a array ; act_store : 'a -> int} + {act_get : unit -> 'a array ; + act_get_shared : unit -> 'a shared array ; + act_store : 'a -> int ; + act_store_shared : 'a -> int ; } + +exception Not_simple + +module type Stored = sig + type t + type key + val make_key : t -> key option +end -let mk_store same = - let r_acts = ref [] in - let store act = - let rec store_rec i = function - | [] -> i,[act] - | act0::rem -> - if same act0 act then raise (Found i) - else - let i,rem = store_rec (i+1) rem in - i,act0::rem in - try - let i,acts = store_rec 0 !r_acts in - r_acts := acts ; - i - with - | Found i -> i +module Store(A:Stored) = struct + module AMap = + Map.Make(struct type t = A.key let compare = Pervasives.compare end) + + type intern = + { mutable map : (bool * int) AMap.t ; + mutable next : int ; + mutable acts : (bool * A.t) list; } + + let mk_store () = + let st = + { map = AMap.empty ; + next = 0 ; + acts = [] ; } in + + let add mustshare act = + let i = st.next in + st.acts <- (mustshare,act) :: st.acts ; + st.next <- i+1 ; + i in + + let store mustshare act = match A.make_key act with + | Some key -> + begin try + let (shared,i) = AMap.find key st.map in + if not shared then st.map <- AMap.add key (true,i) st.map ; + i + with Not_found -> + let i = add mustshare act in + st.map <- AMap.add key (mustshare,i) st.map ; + i + end + | None -> + add mustshare act + + and get () = Array.of_list (List.rev_map (fun (_,act) -> act) st.acts) - and get () = Array.of_list !r_acts in - {act_store=store ; act_get=get} + and get_shared () = + let acts = + Array.of_list + (List.rev_map + (fun (shared,act) -> + if shared then Shared act else Single act) + st.acts) in + AMap.iter + (fun _ (shared,i) -> + if shared then match acts.(i) with + | Single act -> acts.(i) <- Shared act + | Shared _ -> ()) + st.map ; + acts in + {act_store = store false ; act_store_shared = store true ; + act_get = get; act_get_shared = get_shared; } +end @@ -50,13 +100,15 @@ type act val bind : act -> (act -> act) -> act + val make_const : int -> act val make_offset : act -> int -> act val make_prim : primitive -> act list -> act val make_isout : act -> act -> act val make_isin : act -> act -> act val make_if : act -> act -> act -> act - val make_switch : - act -> int array -> act array -> act + val make_switch : act -> int array -> act array -> act + val make_catch : act -> int * (act -> act) + val make_exit : int -> act end (* The module will ``produce good code for the case statement'' *) @@ -196,7 +248,7 @@ let l1,h1,act1 = c1.(Array.length c1-1) and l2,h2,act2 = c2.(0) in if act1 = act2 then - let r = Array.create (len1+len2-1) c1.(0) in + let r = Array.make (len1+len2-1) c1.(0) in for i = 0 to len1-2 do r.(i) <- c1.(i) done ; @@ -225,7 +277,7 @@ done ; r else if h1 > l1 then - let r = Array.create (len1+len2) c1.(0) in + let r = Array.make (len1+len2) c1.(0) in for i = 0 to len1-2 do r.(i) <- c1.(i) done ; @@ -235,7 +287,7 @@ done ; r else if h2 > l2 then - let r = Array.create (len1+len2) c1.(0) in + let r = Array.make (len1+len2) c1.(0) in for i = 0 to len1-1 do r.(i) <- c1.(i) done ; @@ -489,77 +541,77 @@ end ; !r, !rc - let make_if_test konst test arg i ifso ifnot = + let make_if_test test arg i ifso ifnot = Arg.make_if - (Arg.make_prim test [arg ; konst i]) + (Arg.make_prim test [arg ; Arg.make_const i]) ifso ifnot - let make_if_lt konst arg i ifso ifnot = match i with + let make_if_lt arg i ifso ifnot = match i with | 1 -> - make_if_test konst Arg.leint arg 0 ifso ifnot + make_if_test Arg.leint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.ltint arg i ifso ifnot + make_if_test Arg.ltint arg i ifso ifnot - and make_if_le konst arg i ifso ifnot = match i with + and make_if_le arg i ifso ifnot = match i with | -1 -> - make_if_test konst Arg.ltint arg 0 ifso ifnot + make_if_test Arg.ltint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.leint arg i ifso ifnot + make_if_test Arg.leint arg i ifso ifnot - and make_if_gt konst arg i ifso ifnot = match i with + and make_if_gt arg i ifso ifnot = match i with | -1 -> - make_if_test konst Arg.geint arg 0 ifso ifnot + make_if_test Arg.geint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.gtint arg i ifso ifnot + make_if_test Arg.gtint arg i ifso ifnot - and make_if_ge konst arg i ifso ifnot = match i with + and make_if_ge arg i ifso ifnot = match i with | 1 -> - make_if_test konst Arg.gtint arg 0 ifso ifnot + make_if_test Arg.gtint arg 0 ifso ifnot | _ -> - make_if_test konst Arg.geint arg i ifso ifnot + make_if_test Arg.geint arg i ifso ifnot - and make_if_eq konst arg i ifso ifnot = - make_if_test konst Arg.eqint arg i ifso ifnot + and make_if_eq arg i ifso ifnot = + make_if_test Arg.eqint arg i ifso ifnot - and make_if_ne konst arg i ifso ifnot = - make_if_test konst Arg.neint arg i ifso ifnot + and make_if_ne arg i ifso ifnot = + make_if_test Arg.neint arg i ifso ifnot let do_make_if_out h arg ifso ifno = Arg.make_if (Arg.make_isout h arg) ifso ifno - let make_if_out konst ctx l d mk_ifso mk_ifno = match l with + let make_if_out ctx l d mk_ifso mk_ifno = match l with | 0 -> do_make_if_out - (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) | _ -> Arg.bind (Arg.make_offset ctx.arg (-l)) (fun arg -> let ctx = {off= (-l+ctx.off) ; arg=arg} in do_make_if_out - (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) + (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) let do_make_if_in h arg ifso ifno = Arg.make_if (Arg.make_isin h arg) ifso ifno - let make_if_in konst ctx l d mk_ifso mk_ifno = match l with + let make_if_in ctx l d mk_ifso mk_ifno = match l with | 0 -> do_make_if_in - (konst d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) | _ -> Arg.bind (Arg.make_offset ctx.arg (-l)) (fun arg -> let ctx = {off= (-l+ctx.off) ; arg=arg} in do_make_if_in - (konst d) arg (mk_ifso ctx) (mk_ifno ctx)) - + (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) - let rec c_test konst ctx ({cases=cases ; actions=actions} as s) = + let rec c_test ctx ({cases=cases ; actions=actions} as s) = let lcases = Array.length cases in assert(lcases > 0) ; if lcases = 1 then actions.(get_act cases 0) ctx + else begin let w,c = opt_count false cases in @@ -579,31 +631,31 @@ if low=high then begin if less_tests coutside cinside then make_if_eq - konst ctx.arg + ctx.arg (low+ctx.off) - (c_test konst ctx {s with cases=inside}) - (c_test konst ctx {s with cases=outside}) + (c_test ctx {s with cases=inside}) + (c_test ctx {s with cases=outside}) else make_if_ne - konst ctx.arg + ctx.arg (low+ctx.off) - (c_test konst ctx {s with cases=outside}) - (c_test konst ctx {s with cases=inside}) + (c_test ctx {s with cases=outside}) + (c_test ctx {s with cases=inside}) end else begin if less_tests coutside cinside then make_if_in - konst ctx + ctx (low+ctx.off) (high-low) - (fun ctx -> c_test konst ctx {s with cases=inside}) - (fun ctx -> c_test konst ctx {s with cases=outside}) + (fun ctx -> c_test ctx {s with cases=inside}) + (fun ctx -> c_test ctx {s with cases=outside}) else make_if_out - konst ctx + ctx (low+ctx.off) (high-low) - (fun ctx -> c_test konst ctx {s with cases=outside}) - (fun ctx -> c_test konst ctx {s with cases=inside}) + (fun ctx -> c_test ctx {s with cases=outside}) + (fun ctx -> c_test ctx {s with cases=inside}) end | Sep i -> let lim,left,right = coupe cases i in @@ -613,17 +665,17 @@ and right = {s with cases=right} in if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then - make_if_ne konst + make_if_ne ctx.arg 0 - (c_test konst ctx right) (c_test konst ctx left) + (c_test ctx right) (c_test ctx left) else if less_tests cright cleft then - make_if_lt konst + make_if_lt ctx.arg (lim+ctx.off) - (c_test konst ctx left) (c_test konst ctx right) + (c_test ctx left) (c_test ctx right) else - make_if_ge konst + make_if_ge ctx.arg (lim+ctx.off) - (c_test konst ctx right) (c_test konst ctx left) + (c_test ctx right) (c_test ctx left) end @@ -676,8 +728,8 @@ let comp_clusters ({cases=cases ; actions=actions} as s) = let len = Array.length cases in - let min_clusters = Array.create len max_int - and k = Array.create len 0 in + let min_clusters = Array.make len max_int + and k = Array.make len 0 in let get_min i = if i < 0 then 0 else min_clusters.(i) in for i = 0 to len-1 do @@ -697,7 +749,7 @@ let make_switch {cases=cases ; actions=actions} i j = let ll,_,_ = cases.(i) and _,hh,_ = cases.(j) in - let tbl = Array.create (hh-ll+1) 0 + let tbl = Array.make (hh-ll+1) 0 and t = Hashtbl.create 17 and index = ref 0 in let get_index act = @@ -717,7 +769,7 @@ tbl.(kk) <- index done done ; - let acts = Array.create !index actions.(0) in + let acts = Array.make !index actions.(0) in Hashtbl.iter (fun act i -> acts.(i) <- actions.(act)) t ; @@ -732,7 +784,7 @@ let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k = let len = Array.length cases in - let r = Array.create n_clusters (0,0,0) + let r = Array.make n_clusters (0,0,0) and t = Hashtbl.create 17 and index = ref 0 and bidon = ref (Array.length actions) in @@ -768,13 +820,13 @@ if i > 0 then zyva (i-1) (ir-1) in zyva (len-1) (n_clusters-1) ; - let acts = Array.create !index (fun _ -> assert false) in + let acts = Array.make !index (fun _ -> assert false) in Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ; {cases = r ; actions = acts} ;; -let zyva (low,high) konst arg cases actions = +let do_zyva (low,high) arg cases actions = let old_ok = !ok_inter in ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ; if !ok_inter <> old_ok then Hashtbl.clear t ; @@ -787,12 +839,31 @@ *) let n_clusters,k = comp_clusters s in let clusters = make_clusters s n_clusters k in - let r = c_test konst {arg=arg ; off=0} clusters in + let r = c_test {arg=arg ; off=0} clusters in r - - -and test_sequence konst arg cases actions = +let abstract_shared actions = + let handlers = ref (fun x -> x) in + let actions = + Array.map + (fun act -> match act with + | Single act -> act + | Shared act -> + let i,h = Arg.make_catch act in + let oh = !handlers in + handlers := (fun act -> h (oh act)) ; + Arg.make_exit i) + actions in + !handlers,actions + +let zyva lh arg cases actions = + let actions = actions.act_get_shared () in + let hs,actions = abstract_shared actions in + hs (do_zyva lh arg cases actions) + +and test_sequence arg cases actions = + let actions = actions.act_get_shared () in + let hs,actions = abstract_shared actions in let old_ok = !ok_inter in ok_inter := false ; if !ok_inter <> old_ok then Hashtbl.clear t ; @@ -804,8 +875,7 @@ pcases stderr cases ; prerr_endline "" ; *) - let r = c_test konst {arg=arg ; off=0} s in - r + hs (c_test {arg=arg ; off=0} s) ;; end diff -Nru ocaml-4.01.0/bytecomp/switch.mli ocaml-4.02.3/bytecomp/switch.mli --- ocaml-4.01.0/bytecomp/switch.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/bytecomp/switch.mli 2014-04-12 12:17:02.000000000 +0200 @@ -17,9 +17,35 @@ (* For detecting action sharing, object style *) +(* Store for actions in object style: + act_store : store an action, returns index in table + In case an action with equal key exists, returns index + of the stored action. Otherwise add entry in table. + act_store_shared : This stored action will always be shared. + act_get : retrieve table + act_get_shared : retrieve table, with sharing explicit +*) + +type 'a shared = Shared of 'a | Single of 'a + type 'a t_store = - {act_get : unit -> 'a array ; act_store : 'a -> int} -val mk_store : ('a -> 'a -> bool) -> 'a t_store + {act_get : unit -> 'a array ; + act_get_shared : unit -> 'a shared array ; + act_store : 'a -> int ; + act_store_shared : 'a -> int ; } + +exception Not_simple + +module type Stored = sig + type t + type key + val make_key : t -> key option +end + +module Store(A:Stored) : + sig + val mk_store : unit -> A.t t_store + end (* Arguments to the Make functor *) module type S = @@ -39,6 +65,7 @@ (* Various constructors, for making a binder, adding one integer, etc. *) val bind : act -> (act -> act) -> act + val make_const : int -> act val make_offset : act -> int -> act val make_prim : primitive -> act list -> act val make_isout : act -> act -> act @@ -49,12 +76,15 @@ NB: cases is in the value form *) val make_switch : act -> int array -> act array -> act + (* Build last minute sharing of action stuff *) + val make_catch : act -> int * (act -> act) + val make_exit : int -> act + end (* - Make.zyva mk_const arg low high cases actions where - - mk_const takes an integer sends a constant action. + Make.zyva arg low high cases actions where - arg is the argument of the switch. - low, high are the interval limits. - cases is a list of sub-interval and action indices @@ -66,17 +96,18 @@ module Make : functor (Arg : S) -> sig +(* Standard entry point, sharing is tracked *) val zyva : (int * int) -> - (int -> Arg.act) -> Arg.act -> (int * int * int) array -> - Arg.act array -> + Arg.act t_store -> Arg.act + +(* Output test sequence, sharing tracked *) val test_sequence : - (int -> Arg.act) -> Arg.act -> (int * int * int) array -> - Arg.act array -> + Arg.act t_store -> Arg.act end diff -Nru ocaml-4.01.0/bytecomp/symtable.ml ocaml-4.02.3/bytecomp/symtable.ml --- ocaml-4.01.0/bytecomp/symtable.ml 2013-04-17 11:07:00.000000000 +0200 +++ ocaml-4.02.3/bytecomp/symtable.ml 2015-05-12 17:31:26.000000000 +0200 @@ -81,7 +81,9 @@ try find_numtable !c_prim_table name with Not_found -> - if !Clflags.custom_runtime then + if !Clflags.custom_runtime || Config.host <> Config.target + || !Clflags.no_check_prims + then enter_numtable c_prim_table name else begin let symb = @@ -96,7 +98,7 @@ if name.[0] <> '%' then ignore(num_of_prim name) let all_primitives () = - let prim = Array.create !c_prim_table.num_cnt "" in + let prim = Array.make !c_prim_table.num_cnt "" in Tbl.iter (fun name number -> prim.(number) <- name) !c_prim_table.num_tbl; prim @@ -134,13 +136,17 @@ let init () = (* Enter the predefined exceptions *) - Array.iter - (fun name -> + Array.iteri + (fun i name -> let id = try List.assoc name Predef.builtin_values with Not_found -> fatal_error "Symtable.init" in let c = slot_for_setglobal id in - let cst = Const_block(0, [Const_base(Const_string name)]) in + let cst = Const_block(Obj.object_tag, + [Const_base(Const_string (name, None)); + Const_base(Const_int (-i-1)) + ]) + in literal_table := (c, cst) :: !literal_table) Runtimedef.builtin_exceptions; (* Initialize the known C primitives *) @@ -194,7 +200,7 @@ gen_patch_int str_set buff pos (num_of_prim name)) patchlist -let patch_object = gen_patch_object String.unsafe_set +let patch_object = gen_patch_object Bytes.unsafe_set let ls_patch_object = gen_patch_object LongString.set (* Translate structured constants *) @@ -202,7 +208,7 @@ let rec transl_const = function Const_base(Const_int i) -> Obj.repr i | Const_base(Const_char c) -> Obj.repr c - | Const_base(Const_string s) -> Obj.repr s + | Const_base(Const_string (s, _)) -> Obj.repr s | Const_base(Const_float f) -> Obj.repr (float_of_string f) | Const_base(Const_int32 i) -> Obj.repr i | Const_base(Const_int64 i) -> Obj.repr i @@ -222,7 +228,7 @@ (* Build the initial table of globals *) let initial_global_table () = - let glob = Array.create !global_table.num_cnt (Obj.repr 0) in + let glob = Array.make !global_table.num_cnt (Obj.repr 0) in List.iter (fun (slot, cst) -> glob.(slot) <- transl_const cst) !literal_table; @@ -296,7 +302,8 @@ Dll.init_toplevel dllpath; (* Recover CRC infos for interfaces *) let crcintfs = - try (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t) list) + try + (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t option) list) with Not_found -> [] in (* Done *) sect.close_reader(); @@ -372,3 +379,15 @@ fprintf ppf "Cannot find or execute the runtime system %s" s | Uninitialized_global s -> fprintf ppf "The value of the global `%s' is not yet computed" s + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + +let reset () = + global_table := empty_numtable; + literal_table := []; + c_prim_table := empty_numtable diff -Nru ocaml-4.01.0/bytecomp/symtable.mli ocaml-4.02.3/bytecomp/symtable.mli --- ocaml-4.01.0/bytecomp/symtable.mli 2013-04-17 11:07:00.000000000 +0200 +++ ocaml-4.02.3/bytecomp/symtable.mli 2014-05-09 14:01:21.000000000 +0200 @@ -17,7 +17,7 @@ (* Functions for batch linking *) val init: unit -> unit -val patch_object: string -> (reloc_info * int) list -> unit +val patch_object: bytes -> (reloc_info * int) list -> unit val ls_patch_object: Misc.LongString.t -> (reloc_info * int) list -> unit val require_primitive: string -> unit val initial_global_table: unit -> Obj.t array @@ -29,7 +29,7 @@ (* Functions for the toplevel *) -val init_toplevel: unit -> (string * Digest.t) list +val init_toplevel: unit -> (string * Digest.t option) list val update_global_table: unit -> unit val get_global_value: Ident.t -> Obj.t val is_global_defined: Ident.t -> bool @@ -57,3 +57,5 @@ open Format val report_error: formatter -> error -> unit + +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/translclass.ml ocaml-4.02.3/bytecomp/translclass.ml --- ocaml-4.01.0/bytecomp/translclass.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/translclass.ml 2014-05-21 17:08:11.000000000 +0200 @@ -109,6 +109,15 @@ [obj; Lvar obj'; Lvar cl])))) end +let name_pattern default p = + match p.pat_desc with + | Tpat_var (id, _) -> id + | Tpat_alias(p, id, _) -> id + | _ -> Ident.create default + +let normalize_cl_path cl path = + Env.normalize_path (Some cl.cl_loc) cl.cl_env path + let rec build_object_init cl_table obj params inh_init obj_init cl = match cl.cl_desc with Tcl_ident ( path, _, _) -> @@ -118,7 +127,8 @@ match envs with None -> [] | Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])] in - ((envs, (obj_init, path)::inh_init), + ((envs, (obj_init, normalize_cl_path cl path) + ::inh_init), mkappl(Lvar obj_init, env @ [obj])) | Tcl_structure str -> create_object cl_table obj (fun obj -> @@ -126,18 +136,18 @@ List.fold_right (fun field (inh_init, obj_init, has_init) -> match field.cf_desc with - Tcf_inher (_, cl, _, _, _) -> + Tcf_inherit (_, cl, _, _, _) -> let (inh_init, obj_init') = build_object_init cl_table (Lvar obj) [] inh_init (fun _ -> lambda_unit) cl in (inh_init, lsequence obj_init' obj_init, true) - | Tcf_val (_, _, _, id, Tcfk_concrete exp, _) -> + | Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) -> (inh_init, lsequence (set_inst_var obj id exp) obj_init, has_init) - | Tcf_meth _ | Tcf_val _ | Tcf_constr _ -> + | Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _-> (inh_init, obj_init, has_init) - | Tcf_init _ -> + | Tcf_initializer _ -> (inh_init, obj_init, true) ) str.cstr_fields @@ -156,7 +166,7 @@ in (inh_init, let build params rem = - let param = name_pattern "param" [pat, ()] in + let param = name_pattern "param" pat in Lfunction (Curried, param::params, Matching.for_function pat.pat_loc None (Lvar param) [pat, rem] partial) @@ -247,7 +257,7 @@ Tcl_ident ( path, _, _) -> begin match inh_init with (obj_init, path')::inh_init -> - let lpath = transl_path path in + let lpath = transl_path ~loc:cl.cl_loc cl.cl_env path in (inh_init, Llet (Strict, obj_init, mkappl(Lprim(Pfield 1, [lpath]), Lvar cla :: @@ -262,38 +272,42 @@ List.fold_right (fun field (inh_init, cl_init, methods, values) -> match field.cf_desc with - Tcf_inher (_, cl, _, vals, meths) -> + Tcf_inherit (_, cl, _, vals, meths) -> let cl_init = output_methods cla methods cl_init in let inh_init, cl_init = build_class_init cla false (vals, meths_super cla str.cstr_meths meths) inh_init cl_init msubst top cl in (inh_init, cl_init, [], values) - | Tcf_val (name, _, _, id, exp, over) -> - let values = if over then values else (name, id) :: values in + | Tcf_val (name, _, id, _, over) -> + let values = + if over then values else (name.txt, id) :: values + in (inh_init, cl_init, methods, values) - | Tcf_meth (_, _, _, Tcfk_virtual _, _) - | Tcf_constr _ + | Tcf_method (_, _, Tcfk_virtual _) + | Tcf_constraint _ -> (inh_init, cl_init, methods, values) - | Tcf_meth (name, _, _, Tcfk_concrete exp, over) -> + | Tcf_method (name, _, Tcfk_concrete (_, exp)) -> let met_code = msubst true (transl_exp exp) in let met_code = if !Clflags.native_code && List.length met_code = 1 then (* Force correct naming of method for profiles *) - let met = Ident.create ("method_" ^ name) in + let met = Ident.create ("method_" ^ name.txt) in [Llet(Strict, met, List.hd met_code, Lvar met)] else met_code in (inh_init, cl_init, - Lvar (Meths.find name str.cstr_meths) :: met_code @ methods, + Lvar(Meths.find name.txt str.cstr_meths) :: met_code @ methods, values) - | Tcf_init exp -> + | Tcf_initializer exp -> (inh_init, Lsequence(mkappl (oo_prim "add_initializer", Lvar cla :: msubst false (transl_exp exp)), cl_init), - methods, values)) + methods, values) + | Tcf_attribute _ -> + (inh_init, cl_init, methods, values)) str.cstr_fields (inh_init, cl_init, [], []) in @@ -325,8 +339,8 @@ let cl = ignore_cstrs cl in begin match cl.cl_desc, inh_init with Tcl_ident (path, _, _), (obj_init, path')::inh_init -> - assert (Path.same path path'); - let lpath = transl_path path in + assert (Path.same (normalize_cl_path cl path) path'); + let lpath = transl_normal_path path' in let inh = Ident.create "inh" and ofs = List.length vals + 1 and valids, methids = super in @@ -392,11 +406,11 @@ try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit with Not_found -> raise Exit end; - (path, obj_init) + (normalize_cl_path cl path, obj_init) | Tcl_fun (_, pat, _, cl, partial) -> let path, obj_init = transl_class_rebind obj_init cl vf in let build params rem = - let param = name_pattern "param" [pat, ()] in + let param = name_pattern "param" pat in Lfunction (Curried, param::params, Matching.for_function pat.pat_loc None (Lvar param) [pat, rem] partial) @@ -416,7 +430,7 @@ let path, obj_init = transl_class_rebind obj_init cl' vf in let rec check_constraint = function Cty_constr(path', _, _) when Path.same path path' -> () - | Cty_fun (_, _, cty) -> check_constraint cty + | Cty_arrow (_, _, cty) -> check_constraint cty | _ -> raise Exit in check_constraint cl.cl_type; @@ -440,7 +454,7 @@ if not (Translcore.check_recursive_lambda ids obj_init') then raise(Error(cl.cl_loc, Illegal_class_expr)); let id = (obj_init' = lfunction [self] obj_init0) in - if id then transl_path path else + if id then transl_normal_path path else let cla = Ident.create "class" and new_init = Ident.create "new_init" @@ -450,7 +464,7 @@ Llet( Strict, new_init, lfunction [obj_init] obj_init', Llet( - Alias, cla, transl_path path, + Alias, cla, transl_normal_path path, Lprim(Pmakeblock(0, Immutable), [mkappl(Lvar new_init, [lfield cla 0]); lfunction [table] @@ -735,7 +749,7 @@ Lprim(Pmakeblock(0, Immutable), menv :: List.map (fun id -> Lvar id) !new_ids_init) and linh_envs = - List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p])) + List.map (fun (_, p) -> Lprim(Pfield 3, [transl_normal_path p])) (List.rev inh_init) in let make_envs lam = @@ -752,7 +766,7 @@ List.filter (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in let inh_keys = - List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in + List.map (fun (_,p) -> Lprim(Pfield 1, [transl_normal_path p])) inh_paths in let lclass lam = Llet(Strict, class_init, Lfunction(Curried, [cla], def_ids cla cl_init), lam) @@ -798,7 +812,7 @@ (* let cl_id = ci.ci_id_class in (* TODO: cl_id is used somewhere else as typesharp ? *) - let _arity = List.length (fst ci.ci_params) in + let _arity = List.length ci.ci_params in let pub_meths = m in let cl = ci.ci_expr in let vflag = vf in @@ -820,3 +834,12 @@ | Tags (lab1, lab2) -> fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s" lab1 lab2 "Change one of them." + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer loc report_error err) + | _ -> + None + ) diff -Nru ocaml-4.01.0/bytecomp/translcore.ml ocaml-4.02.3/bytecomp/translcore.ml --- ocaml-4.01.0/bytecomp/translcore.ml 2013-05-28 13:05:58.000000000 +0200 +++ ocaml-4.02.3/bytecomp/translcore.ml 2014-09-15 05:01:17.000000000 +0200 @@ -146,7 +146,9 @@ "%setfield0", Psetfield(0, true); "%makeblock", Pmakeblock(0, Immutable); "%makemutable", Pmakeblock(0, Mutable); - "%raise", Praise; + "%raise", Praise Raise_regular; + "%reraise", Praise Raise_reraise; + "%raise_notrace", Praise Raise_notrace; "%sequand", Psequand; "%sequor", Psequor; "%boolnot", Pnot; @@ -309,6 +311,7 @@ "%bswap_int32", Pbbswap(Pint32); "%bswap_int64", Pbbswap(Pint64); "%bswap_native", Pbbswap(Pnativeint); + "%int_as_pointer", Pint_as_pointer; ] let prim_makearray = @@ -323,6 +326,11 @@ match prim_name with "%revapply" -> Prevapply loc | "%apply" -> Pdirapply loc + | "%loc_LOC" -> Ploc Loc_LOC + | "%loc_FILE" -> Ploc Loc_FILE + | "%loc_LINE" -> Ploc Loc_LINE + | "%loc_POS" -> Ploc Loc_POS + | "%loc_MODULE" -> Ploc Loc_MODULE | name -> Hashtbl.find primitives_table name let transl_prim loc prim args = @@ -333,10 +341,10 @@ simplify_constant_constructor) = Hashtbl.find comparisons_table prim_name in begin match args with - [arg1; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _, _)}] + [arg1; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}] when simplify_constant_constructor -> intcomp - | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _, _)}; arg2] + | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}; arg2] when simplify_constant_constructor -> intcomp | [arg1; {exp_desc = Texp_variant(_, None)}] @@ -402,10 +410,20 @@ with Not_found -> Pccall p in match prim with - Plazyforce -> + | Plazyforce -> let parm = Ident.create "prim" in Lfunction(Curried, [parm], Matching.inline_lazy_force (Lvar parm) Location.none) + | Ploc kind -> + let lam = lam_of_loc kind loc in + begin match p.prim_arity with + | 0 -> lam + | 1 -> (* TODO: we should issue a warning ? *) + let param = Ident.create "prim" in + Lfunction(Curried, [param], + Lprim(Pmakeblock(0, Immutable), [lam; Lvar param])) + | _ -> assert false + end | _ -> let rec make_params n = if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in @@ -495,7 +513,7 @@ let rec name_pattern default = function [] -> Ident.create default - | (p, e) :: rem -> + | {c_lhs=p; _} :: rem -> match p.pat_desc with Tpat_var (id, _) -> id | Tpat_alias(p, id, _) -> id @@ -503,24 +521,29 @@ (* Push the default values under the functional abstractions *) -let rec push_defaults loc bindings pat_expr_list partial = - match pat_expr_list with - [pat, ({exp_desc = Texp_function(l, pl,partial)} as exp)] -> +let rec push_defaults loc bindings cases partial = + match cases with + [{c_lhs=pat; c_guard=None; + c_rhs={exp_desc = Texp_function(l, pl,partial)} as exp}] -> let pl = push_defaults exp.exp_loc bindings pl partial in - [pat, {exp with exp_desc = Texp_function(l, pl, partial)}] - | [pat, {exp_desc = Texp_let - (Default, cases, ({exp_desc = Texp_function _} as e2))}] -> - push_defaults loc (cases :: bindings) [pat, e2] partial - | [pat, exp] -> + [{c_lhs=pat; c_guard=None; + c_rhs={exp with exp_desc = Texp_function(l, pl, partial)}}] + | [{c_lhs=pat; c_guard=None; + c_rhs={exp_attributes=[{txt="#default"},_]; + exp_desc = Texp_let + (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] -> + push_defaults loc (binds :: bindings) [{c_lhs=pat;c_guard=None;c_rhs=e2}] + partial + | [case] -> let exp = List.fold_left - (fun exp cases -> - {exp with exp_desc = Texp_let(Nonrecursive, cases, exp)}) - exp bindings + (fun exp binds -> + {exp with exp_desc = Texp_let(Nonrecursive, binds, exp)}) + case.c_rhs bindings in - [pat, exp] - | (pat, exp) :: _ when bindings <> [] -> - let param = name_pattern "param" pat_expr_list in + [{case with c_rhs=exp}] + | {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] -> + let param = name_pattern "param" cases in let name = Ident.name param in let exp = { exp with exp_loc = loc; exp_desc = @@ -528,14 +551,17 @@ ({exp with exp_type = pat.pat_type; exp_desc = Texp_ident (Path.Pident param, mknoloc (Longident.Lident name), {val_type = pat.pat_type; val_kind = Val_reg; + val_attributes = []; Types.val_loc = Location.none; })}, - pat_expr_list, partial) } + cases, [], partial) } in push_defaults loc bindings - [{pat with pat_desc = Tpat_var (param, mknoloc name)}, exp] Total + [{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)}; + c_guard=None; c_rhs=exp}] + Total | _ -> - pat_expr_list + cases (* Insertion of debugging events *) @@ -581,11 +607,11 @@ let assert_failed exp = let (fname, line, char) = Location.get_pos_info exp.exp_loc.Location.loc_start in - Lprim(Praise, [event_after exp + Lprim(Praise Raise_regular, [event_after exp (Lprim(Pmakeblock(0, Immutable), - [transl_path Predef.path_assert_failure; + [transl_normal_path Predef.path_assert_failure; Lconst(Const_block(0, - [Const_base(Const_string fname); + [Const_base(Const_string (fname, None)); Const_base(Const_int line); Const_base(Const_int char)]))]))]) ;; @@ -597,6 +623,8 @@ (* Translation of expressions *) +let try_ids = Hashtbl.create 8 + let rec transl_exp e = let eval_once = (* Whether classes for immediate objects must be cached *) @@ -627,7 +655,7 @@ | Texp_ident(path, _, {val_kind = Val_anc _}) -> raise(Error(e.exp_loc, Free_super_var)) | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) -> - transl_path path + transl_path ~loc:e.exp_loc e.exp_env path | Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident" | Texp_constant cst -> Lconst(Const_base cst) @@ -641,7 +669,7 @@ transl_function e.exp_loc !Clflags.native_code repr partial pl) in Lfunction(kind, params, body) - | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})} as fn, + | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})}, oargs) when List.length oargs >= p.prim_arity && List.for_all (fun (_, arg,_) -> arg <> None) oargs -> @@ -667,16 +695,25 @@ wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc)) | _ -> assert false else begin - if p.prim_name = "%sequand" && Path.last path = "&" then - Location.prerr_warning fn.exp_loc - (Warnings.Deprecated "operator (&); you should use (&&) instead"); - if p.prim_name = "%sequor" && Path.last path = "or" then - Location.prerr_warning fn.exp_loc - (Warnings.Deprecated "operator (or); you should use (||) instead"); let prim = transl_prim e.exp_loc p args in match (prim, args) with - (Praise, [arg1]) -> - wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)])) + (Praise k, [arg1]) -> + let targ = List.hd argl in + let k = + match k, targ with + | Raise_regular, Lvar id + when Hashtbl.mem try_ids id -> + Raise_reraise + | _ -> + k + in + wrap0 (Lprim(Praise k, [event_after arg1 targ])) + | (Ploc kind, []) -> + lam_of_loc kind e.exp_loc + | (Ploc kind, [arg1]) -> + let lam = lam_of_loc kind arg1.exp_loc in + Lprim(Pmakeblock(0, Immutable), lam :: argl) + | (Ploc _, _) -> assert false | (_, _) -> begin match (prim, argl) with | (Plazyforce, [a]) -> @@ -688,16 +725,12 @@ end | Texp_apply(funct, oargs) -> event_after e (transl_apply (transl_exp funct) oargs e.exp_loc) - | Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) -> - Matching.for_multiple_match e.exp_loc - (transl_list argl) (transl_cases pat_expr_list) partial - | Texp_match(arg, pat_expr_list, partial) -> - Matching.for_function e.exp_loc None - (transl_exp arg) (transl_cases pat_expr_list) partial + | Texp_match(arg, pat_expr_list, exn_pat_expr_list, partial) -> + transl_match e arg pat_expr_list exn_pat_expr_list partial | Texp_try(body, pat_expr_list) -> let id = name_pattern "exn" pat_expr_list in Ltrywith(transl_exp body, id, - Matching.for_trywith (Lvar id) (transl_cases pat_expr_list)) + Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list)) | Texp_tuple el -> let ll = transl_list el in begin try @@ -705,7 +738,7 @@ with Not_constant -> Lprim(Pmakeblock(0, Immutable), ll) end - | Texp_construct(_, cstr, args, _) -> + | Texp_construct(_, cstr, args) -> let ll = transl_list args in begin match cstr.cstr_tag with Cstr_constant n -> @@ -716,8 +749,12 @@ with Not_constant -> Lprim(Pmakeblock(n, Immutable), ll) end - | Cstr_exception (path, _) -> - Lprim(Pmakeblock(0, Immutable), transl_path path :: ll) + | Cstr_extension(path, is_const) -> + if is_const then + transl_path e.exp_env path + else + Lprim(Pmakeblock(0, Immutable), + transl_path e.exp_env path :: ll) end | Texp_variant(l, arg) -> let tag = Btype.hash_variant l in @@ -782,10 +819,6 @@ | Texp_for(param, _, low, high, dir, body) -> Lfor(param, transl_exp low, transl_exp high, dir, event_before body (transl_exp body)) - | Texp_when(cond, body) -> - event_before cond - (Lifthenelse(transl_exp cond, event_before body (transl_exp body), - staticfail)) | Texp_send(_, _, Some exp) -> transl_exp exp | Texp_send(expr, met, None) -> let obj = transl_exp expr in @@ -798,16 +831,18 @@ Lsend (kind, tag, obj, cache, e.exp_loc) in event_after e lam - | Texp_new (cl, _, _) -> - Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none) + | Texp_new (cl, {Location.loc=loc}, _) -> + Lapply(Lprim(Pfield 0, [transl_path ~loc e.exp_env cl]), + [lambda_unit], Location.none) | Texp_instvar(path_self, path, _) -> - Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path]) + Lprim(Parrayrefu Paddrarray, + [transl_normal_path path_self; transl_normal_path path]) | Texp_setinstvar(path_self, path, _, expr) -> - transl_setinstvar (transl_path path_self) path expr + transl_setinstvar (transl_normal_path path_self) path expr | Texp_override(path_self, modifs) -> let cpy = Ident.create "copy" in Llet(Strict, cpy, - Lapply(Translobj.oo_prim "copy", [transl_path path_self], + Lapply(Translobj.oo_prim "copy", [transl_normal_path path_self], Location.none), List.fold_right (fun (path, _, expr) rem -> @@ -818,11 +853,12 @@ Llet(Strict, id, !transl_module Tcoerce_none None modl, transl_exp body) | Texp_pack modl -> !transl_module Tcoerce_none None modl + | Texp_assert {exp_desc=Texp_construct(_, {cstr_name="false"}, _)} -> + assert_failed e | Texp_assert (cond) -> if !Clflags.noassert then lambda_unit else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e) - | Texp_assertfalse -> assert_failed e | Texp_lazy e -> (* when e needs no computation (constants, identifiers, ...), we optimize the translation just as Lazy.lazy_from_val would @@ -833,7 +869,7 @@ ( Const_int _ | Const_char _ | Const_string _ | Const_int32 _ | Const_int64 _ | Const_nativeint _ ) | Texp_function(_, _, _) - | Texp_construct (_, {cstr_arity = 0}, _, _) + | Texp_construct (_, {cstr_arity = 0}, _) -> transl_exp e | Texp_constant(Const_float _) -> Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]) @@ -859,7 +895,6 @@ || has_base_type e Predef.path_exn || has_base_type e Predef.path_array || has_base_type e Predef.path_list - || has_base_type e Predef.path_format6 || has_base_type e Predef.path_option || has_base_type e Predef.path_nativeint || has_base_type e Predef.path_int32 @@ -871,7 +906,7 @@ (* other cases compile to a lazy block holding a function *) | _ -> let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in - Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn]) + Lprim(Pmakeblock(Config.lazy_tag, Mutable), [fn]) end | Texp_object (cs, meths) -> let cty = cs.cstr_type in @@ -880,18 +915,43 @@ { cl_desc = Tcl_structure cs; cl_loc = e.exp_loc; cl_type = Cty_signature cty; - cl_env = e.exp_env } + cl_env = e.exp_env; + cl_attributes = []; + } and transl_list expr_list = List.map transl_exp expr_list -and transl_cases pat_expr_list = - List.map - (fun (pat, expr) -> (pat, event_before expr (transl_exp expr))) - pat_expr_list +and transl_guard guard rhs = + let expr = event_before rhs (transl_exp rhs) in + match guard with + | None -> expr + | Some cond -> + event_before cond (Lifthenelse(transl_exp cond, expr, staticfail)) + +and transl_case {c_lhs; c_guard; c_rhs} = + c_lhs, transl_guard c_guard c_rhs + +and transl_cases cases = + List.map transl_case cases + +and transl_case_try {c_lhs; c_guard; c_rhs} = + match c_lhs.pat_desc with + | Tpat_var (id, _) + | Tpat_alias (_, id, _) -> + Hashtbl.replace try_ids id (); + Misc.try_finally + (fun () -> c_lhs, transl_guard c_guard c_rhs) + (fun () -> Hashtbl.remove try_ids id) + | _ -> + c_lhs, transl_guard c_guard c_rhs + +and transl_cases_try cases = + List.map transl_case_try cases and transl_tupled_cases patl_expr_list = - List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list + List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr)) + patl_expr_list and transl_apply lam sargs loc = let lapply funct args = @@ -943,56 +1003,58 @@ in build_apply lam [] (List.map (fun (l, x,o) -> may_map transl_exp x, o) sargs) -and transl_function loc untuplify_fn repr partial pat_expr_list = - match pat_expr_list with - [pat, ({exp_desc = Texp_function(_, pl,partial')} as exp)] +and transl_function loc untuplify_fn repr partial cases = + match cases with + [{c_lhs=pat; c_guard=None; + c_rhs={exp_desc = Texp_function(_, pl,partial')} as exp}] when Parmatch.fluid pat -> - let param = name_pattern "param" pat_expr_list in + let param = name_pattern "param" cases in let ((_, params), body) = transl_function exp.exp_loc false repr partial' pl in ((Curried, param :: params), Matching.for_function loc None (Lvar param) [pat, body] partial) - | ({pat_desc = Tpat_tuple pl}, _) :: _ when untuplify_fn -> + | {c_lhs={pat_desc = Tpat_tuple pl}} :: _ when untuplify_fn -> begin try let size = List.length pl in let pats_expr_list = List.map - (fun (pat, expr) -> (Matching.flatten_pattern size pat, expr)) - pat_expr_list in + (fun {c_lhs; c_guard; c_rhs} -> + (Matching.flatten_pattern size c_lhs, c_guard, c_rhs)) + cases in let params = List.map (fun p -> Ident.create "param") pl in ((Tupled, params), Matching.for_tupled_function loc params (transl_tupled_cases pats_expr_list) partial) with Matching.Cannot_flatten -> - let param = name_pattern "param" pat_expr_list in + let param = name_pattern "param" cases in ((Curried, [param]), Matching.for_function loc repr (Lvar param) - (transl_cases pat_expr_list) partial) + (transl_cases cases) partial) end | _ -> - let param = name_pattern "param" pat_expr_list in + let param = name_pattern "param" cases in ((Curried, [param]), Matching.for_function loc repr (Lvar param) - (transl_cases pat_expr_list) partial) + (transl_cases cases) partial) and transl_let rec_flag pat_expr_list body = match rec_flag with - Nonrecursive | Default -> + Nonrecursive -> let rec transl = function [] -> body - | (pat, expr) :: rem -> + | {vb_pat=pat; vb_expr=expr} :: rem -> Matching.for_let pat.pat_loc (transl_exp expr) pat (transl rem) in transl pat_expr_list | Recursive -> let idlist = List.map - (fun (pat, expr) -> match pat.pat_desc with + (fun {vb_pat=pat} -> match pat.pat_desc with Tpat_var (id,_) -> id | Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id | _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat))) pat_expr_list in - let transl_case (pat, expr) id = + let transl_case {vb_pat=pat; vb_expr=expr} id = let lam = transl_exp expr in if not (check_recursive_lambda idlist lam) then raise(Error(expr.exp_loc, Illegal_letrec_expr)); @@ -1001,7 +1063,7 @@ and transl_setinstvar self var expr = Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray), - [self; transl_path var; transl_exp expr]) + [self; transl_normal_path var; transl_exp expr]) and transl_record all_labels repres lbl_expr_list opt_init_expr = let size = Array.length all_labels in @@ -1010,7 +1072,7 @@ then begin (* Allocate new record with given fields (and remaining fields taken from init_expr if any *) - let lv = Array.create (Array.length all_labels) staticfail in + let lv = Array.make (Array.length all_labels) staticfail in let init_id = Ident.create "init" in begin match opt_init_expr with None -> () @@ -1068,6 +1130,34 @@ end end +and transl_match e arg pat_expr_list exn_pat_expr_list partial = + let id = name_pattern "exn" exn_pat_expr_list + and cases = transl_cases pat_expr_list + and exn_cases = transl_cases exn_pat_expr_list in + let static_catch body val_ids handler = + let static_exception_id = next_negative_raise_count () in + Lstaticcatch + (Ltrywith (Lstaticraise (static_exception_id, body), id, + Matching.for_trywith (Lvar id) exn_cases), + (static_exception_id, val_ids), + handler) + in + match arg, exn_cases with + | {exp_desc = Texp_tuple argl}, [] -> + Matching.for_multiple_match e.exp_loc (transl_list argl) cases partial + | {exp_desc = Texp_tuple argl}, _ :: _ -> + let val_ids = List.map (fun _ -> name_pattern "val" []) argl in + let lvars = List.map (fun id -> Lvar id) val_ids in + static_catch (transl_list argl) val_ids + (Matching.for_multiple_match e.exp_loc lvars cases partial) + | arg, [] -> + Matching.for_function e.exp_loc None (transl_exp arg) cases partial + | arg, _ :: _ -> + let val_id = name_pattern "val" pat_expr_list in + static_catch [transl_exp arg] [val_id] + (Matching.for_function e.exp_loc None (Lvar val_id) cases partial) + + (* Wrapper for class compilation *) (* @@ -1081,15 +1171,6 @@ (transl_let rec_flag pat_expr_list) body *) -(* Compile an exception definition *) - -let transl_exception id path decl = - let name = - match path with - None -> Ident.name id - | Some p -> Path.name p in - Lprim(Pmakeblock(0, Immutable), [Lconst(Const_base(Const_string name))]) - (* Error report *) open Format @@ -1106,3 +1187,12 @@ "Ancestor names can only be used to select inherited methods" | Unknown_builtin_primitive prim_name -> fprintf ppf "Unknown builtin primitive \"%s\"" prim_name + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer loc report_error err) + | _ -> + None + ) diff -Nru ocaml-4.01.0/bytecomp/translcore.mli ocaml-4.02.3/bytecomp/translcore.mli --- ocaml-4.01.0/bytecomp/translcore.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/translcore.mli 2013-11-13 14:55:13.000000000 +0100 @@ -17,16 +17,11 @@ open Typedtree open Lambda -val name_pattern: string -> (pattern * 'a) list -> Ident.t - val transl_exp: expression -> lambda val transl_apply: lambda -> (label * expression option * optional) list -> Location.t -> lambda -val transl_let: - rec_flag -> (pattern * expression) list -> lambda -> lambda +val transl_let: rec_flag -> value_binding list -> lambda -> lambda val transl_primitive: Location.t -> Primitive.description -> lambda -val transl_exception: - Ident.t -> Path.t option -> exception_declaration -> lambda val check_recursive_lambda: Ident.t list -> lambda -> bool diff -Nru ocaml-4.01.0/bytecomp/translmod.ml ocaml-4.02.3/bytecomp/translmod.ml --- ocaml-4.01.0/bytecomp/translmod.ml 2013-07-17 17:20:26.000000000 +0200 +++ ocaml-4.02.3/bytecomp/translmod.ml 2015-03-17 17:38:47.000000000 +0100 @@ -27,30 +27,101 @@ type error = Circular_dependency of Ident.t + exception Error of Location.t * error +(* Keep track of the root path (from the root of the namespace to the + currently compiled module expression). Useful for naming extensions. *) + +let global_path glob = Some(Pident glob) +let functor_path path param = + match path with + None -> None + | Some p -> Some(Papply(p, Pident param)) +let field_path path field = + match path with + None -> None + | Some p -> Some(Pdot(p, Ident.name field, Path.nopos)) + +(* Compile type extensions *) + +let prim_set_oo_id = + Pccall {Primitive.prim_name = "caml_set_oo_id"; prim_arity = 1; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false} + +let transl_extension_constructor env path ext = + let name = + match path with + None -> Ident.name ext.ext_id + | Some p -> Path.name p + in + match ext.ext_kind with + Text_decl(args, ret) -> + Lprim(prim_set_oo_id, + [Lprim(Pmakeblock(Obj.object_tag, Mutable), + [Lconst(Const_base(Const_string (name,None))); + Lconst(Const_base(Const_int 0))])]) + | Text_rebind(path, lid) -> + transl_path ~loc:ext.ext_loc env path + +let transl_type_extension env rootpath tyext body = + List.fold_right + (fun ext body -> + let lam = + transl_extension_constructor env (field_path rootpath ext.ext_id) ext + in + Llet(Strict, ext.ext_id, lam, body)) + tyext.tyext_constructors + body + (* Compile a coercion *) -let rec apply_coercion restr arg = +let rec apply_coercion strict restr arg = match restr with Tcoerce_none -> arg - | Tcoerce_structure pos_cc_list -> - name_lambda arg (fun id -> - Lprim(Pmakeblock(0, Immutable), - List.map (apply_coercion_field id) pos_cc_list)) + | Tcoerce_structure(pos_cc_list, id_pos_list) -> + name_lambda strict arg (fun id -> + let get_field pos = Lprim(Pfield pos,[Lvar id]) in + let lam = + Lprim(Pmakeblock(0, Immutable), + List.map (apply_coercion_field get_field) pos_cc_list) + in + wrap_id_pos_list id_pos_list get_field lam) | Tcoerce_functor(cc_arg, cc_res) -> let param = Ident.create "funarg" in - name_lambda arg (fun id -> + name_lambda strict arg (fun id -> Lfunction(Curried, [param], - apply_coercion cc_res - (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)], + apply_coercion Strict cc_res + (Lapply(Lvar id, [apply_coercion Alias cc_arg (Lvar param)], Location.none)))) | Tcoerce_primitive p -> transl_primitive Location.none p + | Tcoerce_alias (path, cc) -> + name_lambda strict arg + (fun id -> apply_coercion Alias cc (transl_normal_path path)) + +and apply_coercion_field get_field (pos, cc) = + apply_coercion Alias cc (get_field pos) + +and wrap_id_pos_list id_pos_list get_field lam = + let fv = free_variables lam in + (*Format.eprintf "%a@." Printlambda.lambda lam; + IdentSet.iter (fun id -> Format.eprintf "%a " Ident.print id) fv; + Format.eprintf "@.";*) + let (lam,s) = + List.fold_left (fun (lam,s) (id',pos,c) -> + if IdentSet.mem id' fv then + let id'' = Ident.create (Ident.name id') in + (Llet(Alias,id'', + apply_coercion Alias c (get_field pos),lam), + Ident.add id' (Lvar id'') s) + else (lam,s)) + (lam, Ident.empty) id_pos_list + in + if s == Ident.empty then lam else subst_lambda s lam -and apply_coercion_field id (pos, cc) = - apply_coercion cc (Lprim(Pfield pos, [Lvar id])) (* Compose two coercions apply_coercion c1 (apply_coercion c2 e) behaves like @@ -60,21 +131,42 @@ match (c1, c2) with (Tcoerce_none, c2) -> c2 | (c1, Tcoerce_none) -> c1 - | (Tcoerce_structure pc1, Tcoerce_structure pc2) -> + | (Tcoerce_structure (pc1, ids1), Tcoerce_structure (pc2, ids2)) -> let v2 = Array.of_list pc2 in + let ids1 = + List.map (fun (id,pos1,c1) -> + let (pos2,c2) = v2.(pos1) in (id, pos2, compose_coercions c1 c2)) + ids1 + in Tcoerce_structure (List.map (function (p1, Tcoerce_primitive p) -> (p1, Tcoerce_primitive p) | (p1, c1) -> let (p2, c2) = v2.(p1) in (p2, compose_coercions c1 c2)) - pc1) + pc1, + ids1 @ ids2) | (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) -> Tcoerce_functor(compose_coercions arg2 arg1, compose_coercions res1 res2) + | (c1, Tcoerce_alias (path, c2)) -> + Tcoerce_alias (path, compose_coercions c1 c2) | (_, _) -> fatal_error "Translmod.compose_coercions" +(* +let apply_coercion a b c = + Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b; + apply_coercion a b c + +let compose_coercions c1 c2 = + let c3 = compose_coercions c1 c2 in + let open Includemod in + Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@." + print_coercion c1 print_coercion c2 print_coercion c3; + c3 +*) + (* Record the primitive declarations occuring in the module compiled *) let primitive_declarations = ref ([] : Primitive.description list) @@ -83,24 +175,11 @@ primitive_declarations := p :: !primitive_declarations | _ -> () -(* Keep track of the root path (from the root of the namespace to the - currently compiled module expression). Useful for naming exceptions. *) - -let global_path glob = Some(Pident glob) -let functor_path path param = - match path with - None -> None - | Some p -> Some(Papply(p, Pident param)) -let field_path path field = - match path with - None -> None - | Some p -> Some(Pdot(p, Ident.name field, Path.nopos)) - (* Utilities for compiling "module rec" definitions *) let mod_prim name = try - transl_path + transl_normal_path (fst (Env.lookup_value (Ldot (Lident "CamlinternalMod", name)) Env.empty)) with Not_found -> @@ -109,7 +188,7 @@ let undefined_location loc = let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in Lconst(Const_block(0, - [Const_base(Const_string fname); + [Const_base(Const_string (fname, None)); Const_base(Const_int line); Const_base(Const_int char)])) @@ -118,6 +197,8 @@ match Mtype.scrape env mty with Mty_ident _ -> raise Not_found + | Mty_alias _ -> + Const_block (1, [Const_pointer 0]) | Mty_signature sg -> Const_block(0, [Const_block(0, init_shape_struct env sg)]) | Mty_functor(id, arg, res) -> @@ -135,12 +216,12 @@ | _ -> raise Not_found in init_v :: init_shape_struct env rem | Sig_type(id, tdecl, _) :: rem -> - init_shape_struct (Env.add_type id tdecl env) rem - | Sig_exception(id, edecl) :: rem -> + init_shape_struct (Env.add_type ~check:false id tdecl env) rem + | Sig_typext(id, ext, _) :: rem -> raise Not_found - | Sig_module(id, mty, _) :: rem -> - init_shape_mod env mty :: - init_shape_struct (Env.add_module id mty env) rem + | Sig_module(id, md, _) :: rem -> + init_shape_mod env md.md_type :: + init_shape_struct (Env.add_module_declaration id md env) rem | Sig_modtype(id, minfo) :: rem -> init_shape_struct (Env.add_modtype id minfo env) rem | Sig_class(id, cdecl, _) :: rem -> @@ -166,7 +247,7 @@ and rhs = Array.of_list (List.map (fun (_,_,_,rhs) -> rhs) bindings) in let fv = Array.map Lambda.free_variables rhs in let num_bindings = Array.length id in - let status = Array.create num_bindings Undefined in + let status = Array.make num_bindings Undefined in let res = ref [] in let rec emit_binding i = match status.(i) with @@ -222,22 +303,22 @@ let compile_recmodule compile_rhs bindings cont = eval_rec_bindings (reorder_rec_bindings - (List.map - (fun ( id, _, _, modl) -> - (id, modl.mod_loc, init_shape modl, compile_rhs id modl)) - bindings)) + (List.map + (fun {mb_id=id; mb_expr=modl; _} -> + (id, modl.mod_loc, init_shape modl, compile_rhs id modl)) + bindings)) cont (* Extract the list of "value" identifiers bound by a signature. "Value" identifiers are identifiers for signature components that - correspond to a run-time value: values, exceptions, modules, classes. + correspond to a run-time value: values, extensions, modules, classes. Note: manifest primitives do not correspond to a run-time value! *) let rec bound_value_identifiers = function [] -> [] | Sig_value(id, {val_kind = Val_reg}) :: rem -> id :: bound_value_identifiers rem - | Sig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem + | Sig_typext(id, ext, _) :: rem -> id :: bound_value_identifiers rem | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem | _ :: rem -> bound_value_identifiers rem @@ -245,9 +326,13 @@ (* Compile a module expression *) let rec transl_module cc rootpath mexp = + match mexp.mod_type with + Mty_alias _ -> apply_coercion Alias cc lambda_unit + | _ -> match mexp.mod_desc with Tmod_ident (path,_) -> - apply_coercion cc (transl_path path) + apply_coercion Strict cc + (transl_path ~loc:mexp.mod_loc mexp.mod_env path) | Tmod_structure str -> transl_struct [] cc rootpath str | Tmod_functor( param, _, mty, body) -> @@ -260,20 +345,21 @@ | Tcoerce_functor(ccarg, ccres) -> let param' = Ident.create "funarg" in Lfunction(Curried, [param'], - Llet(Alias, param, apply_coercion ccarg (Lvar param'), + Llet(Alias, param, + apply_coercion Alias ccarg (Lvar param'), transl_module ccres bodypath body)) | _ -> fatal_error "Translmod.transl_module") cc | Tmod_apply(funct, arg, ccarg) -> oo_wrap mexp.mod_env true - (apply_coercion cc) + (apply_coercion Strict cc) (Lapply(transl_module Tcoerce_none None funct, [transl_module ccarg None arg], mexp.mod_loc)) | Tmod_constraint(arg, mty, _, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg | Tmod_unpack(arg, _) -> - apply_coercion cc (Translcore.transl_exp arg) + apply_coercion Strict cc (Translcore.transl_exp arg) and transl_struct fields cc rootpath str = transl_structure fields cc rootpath str.str_items @@ -284,53 +370,66 @@ Tcoerce_none -> Lprim(Pmakeblock(0, Immutable), List.map (fun id -> Lvar id) (List.rev fields)) - | Tcoerce_structure pos_cc_list -> + | Tcoerce_structure(pos_cc_list, id_pos_list) -> + (* Do not ignore id_pos_list ! *) + (*Format.eprintf "%a@.@[" Includemod.print_coercion cc; + List.iter (fun l -> Format.eprintf "%a@ " Ident.print l) + fields; + Format.eprintf "@]@.";*) let v = Array.of_list (List.rev fields) in - Lprim(Pmakeblock(0, Immutable), + let get_field pos = Lvar v.(pos) + and ids = List.fold_right IdentSet.add fields IdentSet.empty in + let lam = + (Lprim(Pmakeblock(0, Immutable), List.map (fun (pos, cc) -> match cc with Tcoerce_primitive p -> transl_primitive Location.none p - | _ -> apply_coercion cc (Lvar v.(pos))) - pos_cc_list) + | _ -> apply_coercion Strict cc (get_field pos)) + pos_cc_list)) + and id_pos_list = + List.filter (fun (id,_,_) -> not (IdentSet.mem id ids)) id_pos_list + in + wrap_id_pos_list id_pos_list get_field lam | _ -> fatal_error "Translmod.transl_structure" end | item :: rem -> match item.str_desc with - | Tstr_eval expr -> + | Tstr_eval (expr, _) -> Lsequence(transl_exp expr, transl_structure fields cc rootpath rem) | Tstr_value(rec_flag, pat_expr_list) -> let ext_fields = rev_let_bound_idents pat_expr_list @ fields in transl_let rec_flag pat_expr_list (transl_structure ext_fields cc rootpath rem) - | Tstr_primitive(id, _, descr) -> + | Tstr_primitive descr -> record_primitive descr.val_val; transl_structure fields cc rootpath rem - | Tstr_type(decls) -> + | Tstr_type decls -> transl_structure fields cc rootpath rem - | Tstr_exception( id, _, decl) -> - Llet(Strict, id, transl_exception id (field_path rootpath id) decl, - transl_structure (id :: fields) cc rootpath rem) - | Tstr_exn_rebind( id, _, path, _) -> - Llet(Strict, id, transl_path path, + | Tstr_typext(tyext) -> + let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + transl_type_extension item.str_env rootpath tyext + (transl_structure (List.rev_append ids fields) cc rootpath rem) + | Tstr_exception ext -> + let id = ext.ext_id in + let path = field_path rootpath id in + Llet(Strict, id, transl_extension_constructor item.str_env path ext, transl_structure (id :: fields) cc rootpath rem) - | Tstr_module( id, _, modl) -> - Llet(Strict, id, - transl_module Tcoerce_none (field_path rootpath id) modl, + | Tstr_module mb -> + let id = mb.mb_id in + Llet(pure_module mb.mb_expr, id, + transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr, transl_structure (id :: fields) cc rootpath rem) | Tstr_recmodule bindings -> let ext_fields = - List.rev_append (List.map (fun (id, _,_,_) -> id) bindings) fields in + List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields + in compile_recmodule (fun id modl -> transl_module Tcoerce_none (field_path rootpath id) modl) bindings (transl_structure ext_fields cc rootpath rem) - | Tstr_modtype(id, _, decl) -> - transl_structure fields cc rootpath rem - | Tstr_open _ -> - transl_structure fields cc rootpath rem | Tstr_class cl_list -> let ids = List.map (fun (ci,_,_) -> ci.ci_id_class) cl_list in Lletrec(List.map @@ -339,11 +438,10 @@ let cl = ci.ci_expr in (id, transl_class ids id meths cl vf )) cl_list, - transl_structure (List.rev ids @ fields) cc rootpath rem) - | Tstr_class_type cl_list -> - transl_structure fields cc rootpath rem - | Tstr_include(modl, sg) -> - let ids = bound_value_identifiers sg in + transl_structure (List.rev_append ids fields) cc rootpath rem) + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in let mid = Ident.create "include" in let rec rebind_idents pos newfields = function [] -> @@ -351,9 +449,21 @@ | id :: ids -> Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]), rebind_idents (pos + 1) (id :: newfields) ids) in - Llet(Strict, mid, transl_module Tcoerce_none None modl, + Llet(pure_module modl, mid, transl_module Tcoerce_none None modl, rebind_idents 0 fields ids) + | Tstr_modtype _ + | Tstr_open _ + | Tstr_class_type _ + | Tstr_attribute _ -> + transl_structure fields cc rootpath rem + +and pure_module m = + match m.mod_desc with + Tmod_ident _ -> Alias + | Tmod_constraint (m,_,_,_) -> pure_module m + | _ -> Strict + (* Update forward declaration in Translcore *) let _ = Translcore.transl_module := transl_module @@ -376,22 +486,26 @@ [] -> [] | item :: rem -> match item.str_desc with - | Tstr_eval expr -> defined_idents rem + | Tstr_eval (expr, _) -> defined_idents rem | Tstr_value(rec_flag, pat_expr_list) -> let_bound_idents pat_expr_list @ defined_idents rem - | Tstr_primitive(id, _, descr) -> defined_idents rem + | Tstr_primitive desc -> defined_idents rem | Tstr_type decls -> defined_idents rem - | Tstr_exception(id, _, decl) -> id :: defined_idents rem - | Tstr_exn_rebind(id, _, path, _) -> id :: defined_idents rem - | Tstr_module(id, _, modl) -> id :: defined_idents rem + | Tstr_typext tyext -> + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + @ defined_idents rem + | Tstr_exception ext -> ext.ext_id :: defined_idents rem + | Tstr_module mb -> mb.mb_id :: defined_idents rem | Tstr_recmodule decls -> - List.map (fun (id, _, _, _) -> id) decls @ defined_idents rem - | Tstr_modtype(id, _, decl) -> defined_idents rem + List.map (fun mb -> mb.mb_id) decls @ defined_idents rem + | Tstr_modtype _ -> defined_idents rem | Tstr_open _ -> defined_idents rem | Tstr_class cl_list -> List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem | Tstr_class_type cl_list -> defined_idents rem - | Tstr_include(modl, sg) -> bound_value_identifiers sg @ defined_idents rem + | Tstr_include incl -> + bound_value_identifiers incl.incl_type @ defined_idents rem + | Tstr_attribute _ -> defined_idents rem (* second level idents (module M = struct ... let id = ... end), and all sub-levels idents *) @@ -399,44 +513,49 @@ [] -> [] | item :: rem -> match item.str_desc with - | Tstr_eval expr -> more_idents rem + | Tstr_eval (expr, _attrs) -> more_idents rem | Tstr_value(rec_flag, pat_expr_list) -> more_idents rem - | Tstr_primitive(id, _, descr) -> more_idents rem + | Tstr_primitive _ -> more_idents rem | Tstr_type decls -> more_idents rem - | Tstr_exception(id, _, decl) -> more_idents rem - | Tstr_exn_rebind(id, _, path, _) -> more_idents rem + | Tstr_typext tyext -> more_idents rem + | Tstr_exception _ -> more_idents rem | Tstr_recmodule decls -> more_idents rem - | Tstr_modtype(id, _, decl) -> more_idents rem + | Tstr_modtype _ -> more_idents rem | Tstr_open _ -> more_idents rem | Tstr_class cl_list -> more_idents rem | Tstr_class_type cl_list -> more_idents rem - | Tstr_include(modl, _) -> more_idents rem - | Tstr_module(id, _, { mod_desc = Tmod_structure str }) -> - all_idents str.str_items @ more_idents rem - | Tstr_module(id, _, _) -> more_idents rem + | Tstr_include _ -> more_idents rem + | Tstr_module {mb_expr={mod_desc = Tmod_structure str}} -> + all_idents str.str_items @ more_idents rem + | Tstr_module _ -> more_idents rem + | Tstr_attribute _ -> more_idents rem and all_idents = function [] -> [] | item :: rem -> match item.str_desc with - | Tstr_eval expr -> all_idents rem + | Tstr_eval (expr, _attrs) -> all_idents rem | Tstr_value(rec_flag, pat_expr_list) -> let_bound_idents pat_expr_list @ all_idents rem - | Tstr_primitive(id, _, descr) -> all_idents rem + | Tstr_primitive _ -> all_idents rem | Tstr_type decls -> all_idents rem - | Tstr_exception(id, _, decl) -> id :: all_idents rem - | Tstr_exn_rebind(id, _, path, _) -> id :: all_idents rem + | Tstr_typext tyext -> + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + @ all_idents rem + | Tstr_exception ext -> ext.ext_id :: all_idents rem | Tstr_recmodule decls -> - List.map (fun (id, _, _, _) -> id) decls @ all_idents rem - | Tstr_modtype(id, _, decl) -> all_idents rem + List.map (fun mb -> mb.mb_id) decls @ all_idents rem + | Tstr_modtype _ -> all_idents rem | Tstr_open _ -> all_idents rem | Tstr_class cl_list -> List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ all_idents rem | Tstr_class_type cl_list -> all_idents rem - | Tstr_include(modl, sg) -> bound_value_identifiers sg @ all_idents rem - | Tstr_module(id, _, { mod_desc = Tmod_structure str }) -> - id :: all_idents str.str_items @ all_idents rem - | Tstr_module(id, _, _) -> id :: all_idents rem + | Tstr_include incl -> + bound_value_identifiers incl.incl_type @ all_idents rem + | Tstr_module {mb_id;mb_expr={mod_desc = Tmod_structure str}} -> + mb_id :: all_idents str.str_items @ all_idents rem + | Tstr_module mb -> mb.mb_id :: all_idents rem + | Tstr_attribute _ -> all_idents rem (* A variant of transl_structure used to compile toplevel structure definitions @@ -466,7 +585,7 @@ lambda_unit | item :: rem -> match item.str_desc with - | Tstr_eval expr -> + | Tstr_eval (expr, _attrs) -> Lsequence(subst_lambda subst (transl_exp expr), transl_store rootpath subst rem) | Tstr_value(rec_flag, pat_expr_list) -> @@ -474,20 +593,25 @@ let lam = transl_let rec_flag pat_expr_list (store_idents ids) in Lsequence(subst_lambda subst lam, transl_store rootpath (add_idents false ids subst) rem) - | Tstr_primitive(id, _, descr) -> + | Tstr_primitive descr -> record_primitive descr.val_val; transl_store rootpath subst rem - | Tstr_type(decls) -> + | Tstr_type decls -> transl_store rootpath subst rem - | Tstr_exception( id, _, decl) -> - let lam = transl_exception id (field_path rootpath id) decl in - Lsequence(Llet(Strict, id, lam, store_ident id), - transl_store rootpath (add_ident false id subst) rem) - | Tstr_exn_rebind( id, _, path, _) -> - let lam = subst_lambda subst (transl_path path) in - Lsequence(Llet(Strict, id, lam, store_ident id), + | Tstr_typext(tyext) -> + let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + let lam = + transl_type_extension item.str_env rootpath tyext (store_idents ids) + in + Lsequence(subst_lambda subst lam, + transl_store rootpath (add_idents false ids subst) rem) + | Tstr_exception ext -> + let id = ext.ext_id in + let path = field_path rootpath id in + let lam = transl_extension_constructor item.str_env path ext in + Lsequence(Llet(Strict, id, subst_lambda subst lam, store_ident id), transl_store rootpath (add_ident false id subst) rem) - | Tstr_module(id, _, { mod_desc = Tmod_structure str }) -> + | Tstr_module{mb_id=id; mb_expr={mod_desc = Tmod_structure str}} -> let lam = transl_store (field_path rootpath id) subst str.str_items in (* Careful: see next case *) let subst = !transl_store_subst in @@ -500,9 +624,8 @@ Lsequence(store_ident id, transl_store rootpath (add_ident true id subst) rem))) - | Tstr_module( id, _, modl) -> - let lam = - transl_module Tcoerce_none (field_path rootpath id) modl in + | Tstr_module{mb_id=id; mb_expr=modl} -> + let lam = transl_module Tcoerce_none (field_path rootpath id) modl in (* Careful: the module value stored in the global may be different from the local module value, in case a coercion is applied. If so, keep using the local module value (id) in the remainder of @@ -513,7 +636,7 @@ Lsequence(store_ident id, transl_store rootpath (add_ident true id subst) rem)) | Tstr_recmodule bindings -> - let ids = List.map fst4 bindings in + let ids = List.map (fun mb -> mb.mb_id) bindings in compile_recmodule (fun id modl -> subst_lambda subst @@ -522,10 +645,6 @@ bindings (Lsequence(store_idents ids, transl_store rootpath (add_idents true ids subst) rem)) - | Tstr_modtype(id, _, decl) -> - transl_store rootpath subst rem - | Tstr_open _ -> - transl_store rootpath subst rem | Tstr_class cl_list -> let ids = List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list in let lam = @@ -538,10 +657,9 @@ store_idents ids) in Lsequence(subst_lambda subst lam, transl_store rootpath (add_idents false ids subst) rem) - | Tstr_class_type cl_list -> - transl_store rootpath subst rem - | Tstr_include(modl, sg) -> - let ids = bound_value_identifiers sg in + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in let mid = Ident.create "include" in let rec store_idents pos = function [] -> transl_store rootpath (add_idents true ids subst) rem @@ -551,11 +669,16 @@ Llet(Strict, mid, subst_lambda subst (transl_module Tcoerce_none None modl), store_idents 0 ids) + | Tstr_modtype _ + | Tstr_open _ + | Tstr_class_type _ + | Tstr_attribute _ -> + transl_store rootpath subst rem and store_ident id = try let (pos, cc) = Ident.find_same id map in - let init_val = apply_coercion cc (Lvar id) in + let init_val = apply_coercion Alias cc (Lvar id) in Lprim(Psetfield(pos, false), [Lprim(Pgetglobal glob, []); init_val]) with Not_found -> fatal_error("Translmod.store_ident: " ^ Ident.unique_name id) @@ -608,7 +731,8 @@ match restr with Tcoerce_none -> natural_map 0 Ident.empty [] idlist - | Tcoerce_structure pos_cc_list -> + | Tcoerce_structure (pos_cc_list, _id_pos_list) -> + (* ignore _id_pos_list as the ids are already bound *) let idarray = Array.of_list idlist in let rec export_map pos map prims undef = function [] -> @@ -635,7 +759,7 @@ let (map, prims, size) = build_ident_map restr (defined_idents str) (more_idents str) in let f = function - | [ { str_desc = Tstr_eval expr } ] when topl -> + | [ { str_desc = Tstr_eval (expr, _attrs) } ] when topl -> assert (size = 0); subst_lambda !transl_store_subst (transl_exp expr) | str -> transl_store_structure module_id map prims str in @@ -671,13 +795,13 @@ let toploop_getvalue id = Lapply(Lprim(Pfield toploop_getvalue_pos, [Lprim(Pgetglobal toploop_ident, [])]), - [Lconst(Const_base(Const_string (toplevel_name id)))], + [Lconst(Const_base(Const_string (toplevel_name id, None)))], Location.none) let toploop_setvalue id lam = Lapply(Lprim(Pfield toploop_setvalue_pos, [Lprim(Pgetglobal toploop_ident, [])]), - [Lconst(Const_base(Const_string (toplevel_name id))); lam], + [Lconst(Const_base(Const_string (toplevel_name id, None))); lam], Location.none) let toploop_setvalue_id id = toploop_setvalue id (Lvar id) @@ -688,36 +812,33 @@ let transl_toplevel_item item = match item.str_desc with - Tstr_eval expr -> + Tstr_eval (expr, _attrs) -> transl_exp expr | Tstr_value(rec_flag, pat_expr_list) -> let idents = let_bound_idents pat_expr_list in transl_let rec_flag pat_expr_list (make_sequence toploop_setvalue_id idents) - | Tstr_primitive(id, _, descr) -> - lambda_unit - | Tstr_type(decls) -> - lambda_unit - | Tstr_exception(id, _, decl) -> - toploop_setvalue id (transl_exception id None decl) - | Tstr_exn_rebind(id, _, path, _) -> - toploop_setvalue id (transl_path path) - | Tstr_module(id, _, modl) -> + | Tstr_typext(tyext) -> + let idents = + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + in + transl_type_extension item.str_env None tyext + (make_sequence toploop_setvalue_id idents) + | Tstr_exception ext -> + toploop_setvalue ext.ext_id + (transl_extension_constructor item.str_env None ext) + | Tstr_module {mb_id=id; mb_expr=modl} -> (* we need to use the unique name for the module because of issues with "open" (PR#1672) *) set_toplevel_unique_name id; - toploop_setvalue id - (transl_module Tcoerce_none (Some(Pident id)) modl) + let lam = transl_module Tcoerce_none (Some(Pident id)) modl in + toploop_setvalue id lam | Tstr_recmodule bindings -> - let idents = List.map fst4 bindings in + let idents = List.map (fun mb -> mb.mb_id) bindings in compile_recmodule (fun id modl -> transl_module Tcoerce_none (Some(Pident id)) modl) bindings (make_sequence toploop_setvalue_id idents) - | Tstr_modtype(id, _, decl) -> - lambda_unit - | Tstr_open _ -> - lambda_unit | Tstr_class cl_list -> (* we need to use unique names for the classes because there might be a value named identically *) @@ -732,10 +853,9 @@ make_sequence (fun (ci, _, _) -> toploop_setvalue_id ci.ci_id_class) cl_list) - | Tstr_class_type cl_list -> - lambda_unit - | Tstr_include(modl, sg) -> - let ids = bound_value_identifiers sg in + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in let mid = Ident.create "include" in let rec set_idents pos = function [] -> @@ -744,6 +864,13 @@ Lsequence(toploop_setvalue id (Lprim(Pfield pos, [Lvar mid])), set_idents (pos + 1) ids) in Llet(Strict, mid, transl_module Tcoerce_none None modl, set_idents 0 ids) + | Tstr_modtype _ + | Tstr_open _ + | Tstr_primitive _ + | Tstr_type _ + | Tstr_class_type _ + | Tstr_attribute _ -> + lambda_unit let transl_toplevel_item_and_close itm = close_toplevel_term (transl_label_init (transl_toplevel_item itm)) @@ -760,17 +887,23 @@ let transl_package component_names target_name coercion = let components = + Lprim(Pmakeblock(0, Immutable), List.map get_component component_names) in + Lprim(Psetglobal target_name, [apply_coercion Strict coercion components]) + (* + let components = match coercion with Tcoerce_none -> List.map get_component component_names - | Tcoerce_structure pos_cc_list -> + | Tcoerce_structure (pos_cc_list, id_pos_list) -> + (* ignore id_pos_list as the ids are already bound *) let g = Array.of_list component_names in List.map - (fun (pos, cc) -> apply_coercion cc (get_component g.(pos))) + (fun (pos, cc) -> apply_coercion Strict cc (get_component g.(pos))) pos_cc_list | _ -> assert false in Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)]) + *) let transl_store_package component_names target_name coercion = let rec make_sequence fn pos arg = @@ -786,15 +919,30 @@ [Lprim(Pgetglobal target_name, []); get_component id])) 0 component_names) - | Tcoerce_structure pos_cc_list -> + | Tcoerce_structure (pos_cc_list, id_pos_list) -> + let components = + Lprim(Pmakeblock(0, Immutable), List.map get_component component_names) + in + let blk = Ident.create "block" in + (List.length pos_cc_list, + Llet (Strict, blk, apply_coercion Strict coercion components, + make_sequence + (fun pos id -> + Lprim(Psetfield(pos, false), + [Lprim(Pgetglobal target_name, []); + Lprim(Pfield pos, [Lvar blk])])) + 0 pos_cc_list)) + (* + (* ignore id_pos_list as the ids are already bound *) let id = Array.of_list component_names in (List.length pos_cc_list, make_sequence (fun dst (src, cc) -> Lprim(Psetfield(dst, false), [Lprim(Pgetglobal target_name, []); - apply_coercion cc (get_component id.(src))])) + apply_coercion Strict cc (get_component id.(src))])) 0 pos_cc_list) + *) | _ -> assert false (* Error report *) @@ -807,3 +955,18 @@ "@[Cannot safely evaluate the definition@ \ of the recursively-defined module %a@]" Printtyp.ident id + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer loc report_error err) + | _ -> + None + ) + +let reset () = + primitive_declarations := []; + transl_store_subst := Ident.empty; + toploop_ident.Ident.flags <- 0; + aliased_idents := Ident.empty diff -Nru ocaml-4.01.0/bytecomp/translmod.mli ocaml-4.02.3/bytecomp/translmod.mli --- ocaml-4.01.0/bytecomp/translmod.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/translmod.mli 2014-05-09 14:01:21.000000000 +0200 @@ -37,3 +37,5 @@ exception Error of Location.t * error val report_error: Format.formatter -> error -> unit + +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/translobj.ml ocaml-4.02.3/bytecomp/translobj.ml --- ocaml-4.01.0/bytecomp/translobj.ml 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/translobj.ml 2014-05-09 14:01:21.000000000 +0200 @@ -20,7 +20,7 @@ let oo_prim name = try - transl_path + transl_normal_path (fst (Env.lookup_value (Ldot (Lident "CamlinternalOO", name)) Env.empty)) with Not_found -> fatal_error ("Primitive " ^ name ^ " not found.") @@ -86,19 +86,26 @@ (* Insert labels *) -let string s = Lconst (Const_base (Const_string s)) +let string s = Lconst (Const_base (Const_string (s, None))) let int n = Lconst (Const_base (Const_int n)) let prim_makearray = { prim_name = "caml_make_vect"; prim_arity = 2; prim_alloc = true; prim_native_name = ""; prim_native_float = false } +(* Also use it for required globals *) let transl_label_init expr = let expr = Hashtbl.fold (fun c id expr -> Llet(Alias, id, Lconst c, expr)) consts expr in + let expr = + List.fold_right + (fun id expr -> Lsequence(Lprim(Pgetglobal id, []), expr)) + (Env.get_required_globals ()) expr + in + Env.reset_required_globals (); reset_labels (); expr @@ -155,3 +162,14 @@ wrapping := false; top_env := Env.empty; raise exn + +let reset () = + Hashtbl.clear consts; + cache_required := false; + method_cache := lambda_unit; + method_count := 0; + method_table := []; + wrapping := false; + top_env := Env.empty; + classes := []; + method_ids := IdentSet.empty diff -Nru ocaml-4.01.0/bytecomp/translobj.mli ocaml-4.02.3/bytecomp/translobj.mli --- ocaml-4.01.0/bytecomp/translobj.mli 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/bytecomp/translobj.mli 2014-05-09 14:01:21.000000000 +0200 @@ -26,3 +26,5 @@ val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda val oo_add_class: Ident.t -> Env.t * bool + +val reset: unit -> unit diff -Nru ocaml-4.01.0/bytecomp/typeopt.ml ocaml-4.02.3/bytecomp/typeopt.ml --- ocaml-4.01.0/bytecomp/typeopt.ml 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/bytecomp/typeopt.ml 2013-09-27 12:54:55.000000000 +0200 @@ -34,7 +34,7 @@ match Env.find_type p exp.exp_env with | {type_kind = Type_variant []} -> true (* type exn *) | {type_kind = Type_variant cstrs} -> - List.exists (fun (name, args,_) -> args <> []) cstrs + List.exists (fun c -> c.Types.cd_args <> []) cstrs | _ -> true with Not_found -> true (* This can happen due to e.g. missing -I options, @@ -64,7 +64,7 @@ {type_kind = Type_abstract} -> Pgenarray | {type_kind = Type_variant cstrs} - when List.for_all (fun (name, args,_) -> args = []) cstrs -> + when List.for_all (fun c -> c.Types.cd_args = []) cstrs -> Pintarray | {type_kind = _} -> Paddrarray diff -Nru ocaml-4.01.0/byterun/alloc.c ocaml-4.02.3/byterun/alloc.c --- ocaml-4.01.0/byterun/alloc.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/alloc.c 2015-07-20 16:04:29.000000000 +0200 @@ -17,12 +17,12 @@ */ #include -#include "alloc.h" -#include "custom.h" -#include "major_gc.h" -#include "memory.h" -#include "mlvalues.h" -#include "stacks.h" +#include "caml/alloc.h" +#include "caml/custom.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/stacks.h" #define Setup_for_gc #define Restore_after_gc @@ -39,11 +39,13 @@ }else if (wosize <= Max_young_wosize){ Alloc_small (result, wosize, tag); if (tag < No_scan_tag){ - for (i = 0; i < wosize; i++) Field (result, i) = 0; + for (i = 0; i < wosize; i++) Field (result, i) = Val_unit; } }else{ result = caml_alloc_shr (wosize, tag); - if (tag < No_scan_tag) memset (Bp_val (result), 0, Bsize_wsize (wosize)); + if (tag < No_scan_tag){ + for (i = 0; i < wosize; i++) Field (result, i) = Val_unit; + } result = caml_check_urgent_gc (result); } return result; @@ -151,6 +153,12 @@ return caml_alloc (wosize, 0); } +CAMLprim value caml_alloc_dummy_function(value size,value arity) +{ + /* the arity argument is used by the js_of_ocaml runtime */ + return caml_alloc_dummy(size); +} + CAMLprim value caml_alloc_dummy_float (value size) { mlsize_t wosize = Int_val(size) * Double_wosize; @@ -182,3 +190,7 @@ } return Val_unit; } + + + + diff -Nru ocaml-4.01.0/byterun/alloc.h ocaml-4.02.3/byterun/alloc.h --- ocaml-4.01.0/byterun/alloc.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/alloc.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,53 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_ALLOC_H -#define CAML_ALLOC_H - - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "misc.h" -#include "mlvalues.h" - -#ifdef __cplusplus -extern "C" { -#endif - -CAMLextern value caml_alloc (mlsize_t, tag_t); -CAMLextern value caml_alloc_small (mlsize_t, tag_t); -CAMLextern value caml_alloc_tuple (mlsize_t); -CAMLextern value caml_alloc_string (mlsize_t); /* size in bytes */ -CAMLextern value caml_copy_string (char const *); -CAMLextern value caml_copy_string_array (char const **); -CAMLextern value caml_copy_double (double); -CAMLextern value caml_copy_int32 (int32); /* defined in [ints.c] */ -CAMLextern value caml_copy_int64 (int64); /* defined in [ints.c] */ -CAMLextern value caml_copy_nativeint (intnat); /* defined in [ints.c] */ -CAMLextern value caml_alloc_array (value (*funct) (char const *), - char const ** array); - -typedef void (*final_fun)(value); -CAMLextern value caml_alloc_final (mlsize_t, /*size in words*/ - final_fun, /*finalization function*/ - mlsize_t, /*resources consumed*/ - mlsize_t /*max resources*/); - -CAMLextern int caml_convert_flag_list (value, int *); - -#ifdef __cplusplus -} -#endif - -#endif /* CAML_ALLOC_H */ diff -Nru ocaml-4.01.0/byterun/array.c ocaml-4.02.3/byterun/array.c --- ocaml-4.01.0/byterun/array.c 2012-12-06 16:39:30.000000000 +0100 +++ ocaml-4.02.3/byterun/array.c 2015-04-12 11:03:39.000000000 +0200 @@ -14,11 +14,11 @@ /* Operations on arrays */ #include -#include "alloc.h" -#include "fail.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" CAMLexport mlsize_t caml_array_length(value array) { @@ -135,6 +135,27 @@ return caml_array_unsafe_set_addr(array, index, newval); } +CAMLprim value caml_make_float_vect(value len) +{ + mlsize_t wosize = Long_val(len) * Double_wosize; + value result; + if (wosize == 0) + return Atom(0); + else if (wosize <= Max_young_wosize){ +#define Setup_for_gc +#define Restore_after_gc + Alloc_small (result, wosize, Double_array_tag); +#undef Setup_for_gc +#undef Restore_after_gc + }else if (wosize > Max_wosize) + caml_invalid_argument("Array.make_float"); + else { + result = caml_alloc_shr (wosize, Double_array_tag); + result = caml_check_urgent_gc (result); + } + return result; +} + CAMLprim value caml_make_vect(value len, value init) { CAMLparam2 (len, init); @@ -193,9 +214,13 @@ || Tag_val(v) != Double_tag) { CAMLreturn (init); } else { - Assert(size < Max_young_wosize); wsize = size * Double_wosize; - res = caml_alloc_small(wsize, Double_array_tag); + if (wsize <= Max_young_wosize) { + res = caml_alloc_small(wsize, Double_array_tag); + } else { + res = caml_alloc_shr(wsize, Double_array_tag); + res = caml_check_urgent_gc(res); + } for (i = 0; i < size; i++) { Store_double_field(res, i, Double_val(Field(init, i))); } diff -Nru ocaml-4.01.0/byterun/backtrace.c ocaml-4.02.3/byterun/backtrace.c --- ocaml-4.01.0/byterun/backtrace.c 2013-08-02 15:54:22.000000000 +0200 +++ ocaml-4.02.3/byterun/backtrace.c 2015-04-12 11:03:39.000000000 +0200 @@ -18,23 +18,24 @@ #include #include -#include "config.h" +#include "caml/config.h" #ifdef HAS_UNISTD #include #endif -#include "mlvalues.h" -#include "alloc.h" -#include "io.h" -#include "instruct.h" -#include "intext.h" -#include "exec.h" -#include "fix_code.h" -#include "memory.h" -#include "startup.h" -#include "stacks.h" -#include "sys.h" -#include "backtrace.h" +#include "caml/mlvalues.h" +#include "caml/alloc.h" +#include "caml/io.h" +#include "caml/instruct.h" +#include "caml/intext.h" +#include "caml/exec.h" +#include "caml/fix_code.h" +#include "caml/memory.h" +#include "caml/startup.h" +#include "caml/stacks.h" +#include "caml/sys.h" +#include "caml/backtrace.h" +#include "caml/fail.h" CAMLexport int caml_backtrace_active = 0; CAMLexport int caml_backtrace_pos = 0; @@ -93,15 +94,16 @@ /* Store the return addresses contained in the given stack fragment into the backtrace array */ -void caml_stash_backtrace(value exn, code_t pc, value * sp) +void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise) { code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size); if (pc != NULL) pc = pc - 1; - if (exn != caml_backtrace_last_exn) { + if (exn != caml_backtrace_last_exn || !reraise) { caml_backtrace_pos = 0; caml_backtrace_last_exn = exn; } if (caml_backtrace_buffer == NULL) { + Assert(caml_backtrace_pos == 0); caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); if (caml_backtrace_buffer == NULL) return; } @@ -119,18 +121,29 @@ } } +/* In order to prevent the GC from walking through the debug + information (which have no headers), we transform code pointers to + 31/63 bits ocaml integers by shifting them by 1 to the right. We do + not lose information as code pointers are aligned. + + In particular, we do not need to use [caml_initialize] when setting + an array element with such a value. +*/ +#define Val_Codet(p) Val_long((uintnat)p>>1) +#define Codet_Val(v) ((code_t)(Long_val(v)<<1)) + /* returns the next frame pointer (or NULL if none is available); - updates *sp to point to the following one, and *trapsp to the next + updates *sp to point to the following one, and *trsp to the next trap frame, which we will skip when we reach it */ -code_t caml_next_frame_pointer(value ** sp, value ** trapsp) +code_t caml_next_frame_pointer(value ** sp, value ** trsp) { code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size); while (*sp < caml_stack_high) { code_t *p = (code_t*) (*sp)++; - if(&Trap_pc(*trapsp) == p) { - *trapsp = Trap_link(*trapsp); + if(&Trap_pc(*trsp) == p) { + *trsp = Trap_link(*trsp); continue; } if (*p >= caml_start_code && *p < end_code) return *p; @@ -157,55 +170,71 @@ /* first compute the size of the trace */ { value * sp = caml_extern_sp; - value * trapsp = caml_trapsp; + value * trsp = caml_trapsp; for (trace_size = 0; trace_size < max_frames; trace_size++) { - code_t p = caml_next_frame_pointer(&sp, &trapsp); + code_t p = caml_next_frame_pointer(&sp, &trsp); if (p == NULL) break; } } - trace = caml_alloc(trace_size, Abstract_tag); + trace = caml_alloc(trace_size, 0); /* then collect the trace */ { value * sp = caml_extern_sp; - value * trapsp = caml_trapsp; + value * trsp = caml_trapsp; uintnat trace_pos; for (trace_pos = 0; trace_pos < trace_size; trace_pos++) { - code_t p = caml_next_frame_pointer(&sp, &trapsp); + code_t p = caml_next_frame_pointer(&sp, &trsp); Assert(p != NULL); - /* The assignment below is safe without [caml_initialize], even - if the trace is large and allocated on the old heap, because - we assign values that are outside the OCaml heap. */ - Assert(!(Is_block((value) p) && Is_in_heap((value) p))); - Field(trace, trace_pos) = (value) p; + Field(trace, trace_pos) = Val_Codet(p); } } CAMLreturn(trace); } -/* Read the debugging info contained in the current bytecode executable. - Return an OCaml array of OCaml lists of debug_event records in "events", - or Val_false on failure. */ +/* Read the debugging info contained in the current bytecode executable. */ #ifndef O_BINARY #define O_BINARY 0 #endif +struct ev_info { + code_t ev_pc; + char * ev_filename; + int ev_lnum; + int ev_startchr; + int ev_endchr; +}; + +static int cmp_ev_info(const void *a, const void *b) { + code_t pc_a = ((const struct ev_info*)a)->ev_pc; + code_t pc_b = ((const struct ev_info*)b)->ev_pc; + if (pc_a > pc_b) return 1; + if (pc_a < pc_b) return -1; + return 0; +} + static char *read_debug_info_error = ""; -static value read_debug_info(void) +static uintnat n_events; +static struct ev_info *events = NULL; +static void read_debug_info(void) { CAMLparam0(); - CAMLlocal1(events); + CAMLlocal1(events_heap); char * exec_name; int fd; struct exec_trailer trail; struct channel * chan; uint32 num_events, orig, i; - value evl, l; + intnat j; + value evl, l, ev_start; + + if(events != NULL) + CAMLreturn0; if (caml_cds_file != NULL) { exec_name = caml_cds_file; @@ -215,54 +244,103 @@ fd = caml_attempt_open(&exec_name, &trail, 1); if (fd < 0){ read_debug_info_error = "executable program file not found"; - CAMLreturn(Val_false); + CAMLreturn0; } caml_read_section_descriptors(fd, &trail); if (caml_seek_optional_section(fd, &trail, "DBUG") == -1) { close(fd); read_debug_info_error = "program not linked with -g"; - CAMLreturn(Val_false); + CAMLreturn0; } chan = caml_open_descriptor_in(fd); num_events = caml_getword(chan); - events = caml_alloc(num_events, 0); + n_events = 0; + events_heap = caml_alloc(num_events, 0); for (i = 0; i < num_events; i++) { orig = caml_getword(chan); evl = caml_input_val(chan); + caml_input_val(chan); // Skip the list of absolute directory names /* Relocate events in event list */ for (l = evl; l != Val_int(0); l = Field(l, 1)) { value ev = Field(l, 0); Field(ev, EV_POS) = Val_long(Long_val(Field(ev, EV_POS)) + orig); + n_events++; } /* Record event list */ - Store_field(events, i, evl); + Store_field(events_heap, i, evl); } caml_close_channel(chan); - CAMLreturn(events); -} -/* Search the event for the given PC. Return Val_false if not found. */ + events = (struct ev_info*)malloc(n_events * sizeof(struct ev_info)); + if(events == NULL) { + read_debug_info_error = "out of memory"; + CAMLreturn0; + } -static value event_for_location(value events, code_t pc) -{ - mlsize_t i; - value pos, l, ev, ev_pos, best_ev; + j = 0; + for (i = 0; i < num_events; i++) { + for (l = Field(events_heap, i); l != Val_int(0); l = Field(l, 1)) { + uintnat fnsz; + value ev = Field(l, 0); - best_ev = 0; - Assert(pc >= caml_start_code && pc < caml_start_code + caml_code_size); - pos = Val_long((char *) pc - (char *) caml_start_code); - for (i = 0; i < Wosize_val(events); i++) { - for (l = Field(events, i); l != Val_int(0); l = Field(l, 1)) { - ev = Field(l, 0); - ev_pos = Field(ev, EV_POS); - if (ev_pos == pos) return ev; - /* ocamlc sometimes moves an event past a following PUSH instruction; - allow mismatch by 1 instruction. */ - if (ev_pos == pos + 8) best_ev = ev; + events[j].ev_pc = + (code_t)((char*)caml_start_code + Long_val(Field(ev, EV_POS))); + + ev_start = Field (Field (ev, EV_LOC), LOC_START); + + fnsz = caml_string_length(Field (ev_start, POS_FNAME))+1; + events[j].ev_filename = (char*)malloc(fnsz); + if(events[j].ev_filename == NULL) { + for(j--; j >= 0; j--) + free(events[j].ev_filename); + free(events); + events = NULL; + read_debug_info_error = "out of memory"; + CAMLreturn0; + } + memcpy(events[j].ev_filename, String_val (Field (ev_start, POS_FNAME)), + fnsz); + + events[j].ev_lnum = Int_val (Field (ev_start, POS_LNUM)); + events[j].ev_startchr = + Int_val (Field (ev_start, POS_CNUM)) + - Int_val (Field (ev_start, POS_BOL)); + events[j].ev_endchr = + Int_val (Field (Field (Field (ev, EV_LOC), LOC_END), POS_CNUM)) + - Int_val (Field (ev_start, POS_BOL)); + + j++; } } - if (best_ev != 0) return best_ev; - return Val_false; + + Assert(j == n_events); + + qsort(events, n_events, sizeof(struct ev_info), cmp_ev_info); + + CAMLreturn0; +} + +/* Search the event index for the given PC. Return -1 if not found. */ + +static intnat event_for_location(code_t pc) +{ + uintnat low = 0, high = n_events; + Assert(pc >= caml_start_code && pc < caml_start_code + caml_code_size); + Assert(events != NULL); + while(low+1 < high) { + uintnat m = (low+high)/2; + if(pc < events[m].ev_pc) high = m; + else low = m; + } + if(events[low].ev_pc == pc) + return low; + /* ocamlc sometimes moves an event past a following PUSH instruction; + allow mismatch by 1 instruction. */ + if(events[low].ev_pc == pc + 1) + return low; + if(low+1 < n_events && events[low+1].ev_pc == pc + 1) + return low+1; + return -1; } /* Extract location information for the given PC */ @@ -276,27 +354,21 @@ int loc_endchr; }; -static void extract_location_info(value events, code_t pc, +static void extract_location_info(code_t pc, /*out*/ struct loc_info * li) { - value ev, ev_start; - - ev = event_for_location(events, pc); - li->loc_is_raise = caml_is_instruction(*pc, RAISE); - if (ev == Val_false) { + intnat ev = event_for_location(pc); + li->loc_is_raise = caml_is_instruction(*pc, RAISE) || + caml_is_instruction(*pc, RERAISE); + if (ev == -1) { li->loc_valid = 0; return; } li->loc_valid = 1; - ev_start = Field (Field (ev, EV_LOC), LOC_START); - li->loc_filename = String_val (Field (ev_start, POS_FNAME)); - li->loc_lnum = Int_val (Field (ev_start, POS_LNUM)); - li->loc_startchr = - Int_val (Field (ev_start, POS_CNUM)) - - Int_val (Field (ev_start, POS_BOL)); - li->loc_endchr = - Int_val (Field (Field (Field (ev, EV_LOC), LOC_END), POS_CNUM)) - - Int_val (Field (ev_start, POS_BOL)); + li->loc_filename = events[ev].ev_filename; + li->loc_lnum = events[ev].ev_lnum; + li->loc_startchr = events[ev].ev_startchr; + li->loc_endchr = events[ev].ev_endchr; } /* Print location information -- same behavior as in Printexc */ @@ -333,55 +405,47 @@ CAMLexport void caml_print_exception_backtrace(void) { - value events; int i; struct loc_info li; - events = read_debug_info(); - if (events == Val_false) { + read_debug_info(); + if (events == NULL) { fprintf(stderr, "(Cannot print stack backtrace: %s)\n", read_debug_info_error); return; } for (i = 0; i < caml_backtrace_pos; i++) { - extract_location_info(events, caml_backtrace_buffer[i], &li); + extract_location_info(caml_backtrace_buffer[i], &li); print_location(&li, i); } } /* Convert the backtrace to a data structure usable from OCaml */ -CAMLprim value caml_convert_raw_backtrace(value backtrace) -{ - CAMLparam1(backtrace); - CAMLlocal5(events, res, arr, p, fname); - int i; +CAMLprim value caml_convert_raw_backtrace_slot(value backtrace_slot) { + CAMLparam1(backtrace_slot); + CAMLlocal2(p, fname); struct loc_info li; - events = read_debug_info(); - if (events == Val_false) { - res = Val_int(0); /* None */ + read_debug_info(); + if (events == NULL) + caml_failwith(read_debug_info_error); + + extract_location_info(Codet_Val(backtrace_slot), &li); + + if (li.loc_valid) { + fname = caml_copy_string(li.loc_filename); + p = caml_alloc_small(5, 0); + Field(p, 0) = Val_bool(li.loc_is_raise); + Field(p, 1) = fname; + Field(p, 2) = Val_int(li.loc_lnum); + Field(p, 3) = Val_int(li.loc_startchr); + Field(p, 4) = Val_int(li.loc_endchr); } else { - arr = caml_alloc(Wosize_val(backtrace), 0); - for (i = 0; i < Wosize_val(backtrace); i++) { - extract_location_info(events, (code_t)Field(backtrace, i), &li); - if (li.loc_valid) { - fname = caml_copy_string(li.loc_filename); - p = caml_alloc_small(5, 0); - Field(p, 0) = Val_bool(li.loc_is_raise); - Field(p, 1) = fname; - Field(p, 2) = Val_int(li.loc_lnum); - Field(p, 3) = Val_int(li.loc_startchr); - Field(p, 4) = Val_int(li.loc_endchr); - } else { - p = caml_alloc_small(1, 1); - Field(p, 0) = Val_bool(li.loc_is_raise); - } - caml_modify(&Field(arr, i), p); - } - res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ + p = caml_alloc_small(1, 1); + Field(p, 0) = Val_bool(li.loc_is_raise); } - CAMLreturn(res); + CAMLreturn(p); } /* Get a copy of the latest backtrace */ @@ -390,20 +454,49 @@ { CAMLparam0(); CAMLlocal1(res); - res = caml_alloc(caml_backtrace_pos, Abstract_tag); - if(caml_backtrace_buffer != NULL) - memcpy(&Field(res, 0), caml_backtrace_buffer, - caml_backtrace_pos * sizeof(code_t)); + + res = caml_alloc(caml_backtrace_pos, 0); + if(caml_backtrace_buffer != NULL) { + intnat i; + for(i = 0; i < caml_backtrace_pos; i++) + Field(res, i) = Val_Codet(caml_backtrace_buffer[i]); + } CAMLreturn(res); } -/* the function below is deprecated: see asmrun/backtrace.c */ +/* the function below is deprecated: we previously returned directly + the OCaml-usable representation, instead of the raw backtrace as an + abstract type, but this has a large performance overhead if you + store a lot of backtraces and print only some of them. + + It is not used by the Printexc library anymore, or anywhere else in + the compiler, but we have kept it in case some user still depends + on it as an external. +*/ CAMLprim value caml_get_exception_backtrace(value unit) { CAMLparam0(); - CAMLlocal2(raw, res); - raw = caml_get_exception_raw_backtrace(unit); - res = caml_convert_raw_backtrace(raw); + CAMLlocal4(arr, raw_slot, slot, res); + + read_debug_info(); + if (events == NULL) { + res = Val_int(0); /* None */ + } else { + arr = caml_alloc(caml_backtrace_pos, 0); + if(caml_backtrace_buffer == NULL) { + Assert(caml_backtrace_pos == 0); + } else { + intnat i; + for(i = 0; i < caml_backtrace_pos; i++) { + raw_slot = Val_Codet(caml_backtrace_buffer[i]); + /* caml_convert_raw_backtrace_slot will not fail with + caml_failwith as we checked (events != NULL) already */ + slot = caml_convert_raw_backtrace_slot(raw_slot); + caml_modify(&Field(arr, i), slot); + } + } + res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ + } CAMLreturn(res); } diff -Nru ocaml-4.01.0/byterun/backtrace.h ocaml-4.02.3/byterun/backtrace.h --- ocaml-4.01.0/byterun/backtrace.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/backtrace.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,31 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2001 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_BACKTRACE_H -#define CAML_BACKTRACE_H - -#include "mlvalues.h" - -CAMLextern int caml_backtrace_active; -CAMLextern int caml_backtrace_pos; -CAMLextern code_t * caml_backtrace_buffer; -CAMLextern value caml_backtrace_last_exn; -CAMLextern char * caml_cds_file; - -CAMLprim value caml_record_backtrace(value vflag); -#ifndef NATIVE_CODE -extern void caml_stash_backtrace(value exn, code_t pc, value * sp); -#endif -CAMLextern void caml_print_exception_backtrace(void); - -#endif /* CAML_BACKTRACE_H */ diff -Nru ocaml-4.01.0/byterun/callback.c ocaml-4.02.3/byterun/callback.c --- ocaml-4.01.0/byterun/callback.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/callback.c 2015-04-12 11:03:39.000000000 +0200 @@ -14,19 +14,19 @@ /* Callbacks from C to OCaml */ #include -#include "callback.h" -#include "fail.h" -#include "memory.h" -#include "mlvalues.h" +#include "caml/callback.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" #ifndef NATIVE_CODE /* Bytecode callbacks */ -#include "interp.h" -#include "instruct.h" -#include "fix_code.h" -#include "stacks.h" +#include "caml/interp.h" +#include "caml/instruct.h" +#include "caml/fix_code.h" +#include "caml/stacks.h" CAMLexport int caml_callback_depth = 0; @@ -216,6 +216,7 @@ { struct named_value * nv; char * name = String_val(vname); + size_t namelen = strlen(name); unsigned int h = hash_value_name(name); for (nv = named_value_table[h]; nv != NULL; nv = nv->next) { @@ -225,8 +226,8 @@ } } nv = (struct named_value *) - caml_stat_alloc(sizeof(struct named_value) + strlen(name)); - strcpy(nv->name, name); + caml_stat_alloc(sizeof(struct named_value) + namelen); + memcpy(nv->name, name, namelen + 1); nv->val = val; nv->next = named_value_table[h]; named_value_table[h] = nv; @@ -244,3 +245,14 @@ } return NULL; } + +CAMLexport void caml_iterate_named_values(caml_named_action f) +{ + int i; + for(i = 0; i < Named_value_size; i++){ + struct named_value * nv; + for (nv = named_value_table[i]; nv != NULL; nv = nv->next) { + f( &nv->val, nv->name ); + } + } +} diff -Nru ocaml-4.01.0/byterun/callback.h ocaml-4.02.3/byterun/callback.h --- ocaml-4.01.0/byterun/callback.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/callback.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,55 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Callbacks from C to OCaml */ - -#ifndef CAML_CALLBACK_H -#define CAML_CALLBACK_H - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "mlvalues.h" - -#ifdef __cplusplus -extern "C" { -#endif - -CAMLextern value caml_callback (value closure, value arg); -CAMLextern value caml_callback2 (value closure, value arg1, value arg2); -CAMLextern value caml_callback3 (value closure, value arg1, value arg2, - value arg3); -CAMLextern value caml_callbackN (value closure, int narg, value args[]); - -CAMLextern value caml_callback_exn (value closure, value arg); -CAMLextern value caml_callback2_exn (value closure, value arg1, value arg2); -CAMLextern value caml_callback3_exn (value closure, - value arg1, value arg2, value arg3); -CAMLextern value caml_callbackN_exn (value closure, int narg, value args[]); - -#define Make_exception_result(v) ((v) | 2) -#define Is_exception_result(v) (((v) & 3) == 2) -#define Extract_exception(v) ((v) & ~3) - -CAMLextern value * caml_named_value (char const * name); - -CAMLextern void caml_main (char ** argv); -CAMLextern void caml_startup (char ** argv); - -CAMLextern int caml_callback_depth; - -#ifdef __cplusplus -} -#endif - -#endif diff -Nru ocaml-4.01.0/byterun/caml/address_class.h ocaml-4.02.3/byterun/caml/address_class.h --- ocaml-4.01.0/byterun/caml/address_class.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/address_class.h 2015-06-09 18:31:52.000000000 +0200 @@ -0,0 +1,82 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Classification of addresses for GC and runtime purposes. */ + +#ifndef CAML_ADDRESS_CLASS_H +#define CAML_ADDRESS_CLASS_H + +#include "misc.h" +#include "mlvalues.h" + +/* Use the following macros to test an address for the different classes + it might belong to. */ + +#define Is_young(val) \ + (Assert (Is_block (val)), \ + (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start) + +#define Is_in_heap(a) (Classify_addr(a) & In_heap) + +#define Is_in_heap_or_young(a) (Classify_addr(a) & (In_heap | In_young)) + +#define Is_in_value_area(a) \ + (Classify_addr(a) & (In_heap | In_young | In_static_data)) + +#define Is_in_code_area(pc) \ + ( ((char *)(pc) >= caml_code_area_start && \ + (char *)(pc) <= caml_code_area_end) \ + || (Classify_addr(pc) & In_code_area) ) + +#define Is_in_static_data(a) (Classify_addr(a) & In_static_data) + +/***********************************************************************/ +/* The rest of this file is private and may change without notice. */ + +extern char *caml_young_start, *caml_young_end; +extern char * caml_code_area_start, * caml_code_area_end; + +#define Not_in_heap 0 +#define In_heap 1 +#define In_young 2 +#define In_static_data 4 +#define In_code_area 8 + +#ifdef ARCH_SIXTYFOUR + +/* 64 bits: Represent page table as a sparse hash table */ +int caml_page_table_lookup(void * addr); +#define Classify_addr(a) (caml_page_table_lookup((void *)(a))) + +#else + +/* 32 bits: Represent page table as a 2-level array */ +#define Pagetable2_log 11 +#define Pagetable2_size (1 << Pagetable2_log) +#define Pagetable1_log (Page_log + Pagetable2_log) +#define Pagetable1_size (1 << (32 - Pagetable1_log)) +CAMLextern unsigned char * caml_page_table[Pagetable1_size]; + +#define Pagetable_index1(a) (((uintnat)(a)) >> Pagetable1_log) +#define Pagetable_index2(a) \ + ((((uintnat)(a)) >> Page_log) & (Pagetable2_size - 1)) +#define Classify_addr(a) \ + caml_page_table[Pagetable_index1(a)][Pagetable_index2(a)] + +#endif + +int caml_page_table_add(int kind, void * start, void * end); +int caml_page_table_remove(int kind, void * start, void * end); +int caml_page_table_initialize(mlsize_t bytesize); + +#endif /* CAML_ADDRESS_CLASS_H */ diff -Nru ocaml-4.01.0/byterun/caml/alloc.h ocaml-4.02.3/byterun/caml/alloc.h --- ocaml-4.01.0/byterun/caml/alloc.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/alloc.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,54 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_ALLOC_H +#define CAML_ALLOC_H + + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "misc.h" +#include "mlvalues.h" + +#ifdef __cplusplus +extern "C" { +#endif + +CAMLextern value caml_alloc (mlsize_t, tag_t); +CAMLextern value caml_alloc_small (mlsize_t, tag_t); +CAMLextern value caml_alloc_tuple (mlsize_t); +CAMLextern value caml_alloc_string (mlsize_t); /* size in bytes */ +CAMLextern value caml_copy_string (char const *); +CAMLextern value caml_copy_string_array (char const **); +CAMLextern value caml_copy_double (double); +CAMLextern value caml_copy_int32 (int32); /* defined in [ints.c] */ +CAMLextern value caml_copy_int64 (int64); /* defined in [ints.c] */ +CAMLextern value caml_copy_nativeint (intnat); /* defined in [ints.c] */ +CAMLextern value caml_alloc_array (value (*funct) (char const *), + char const ** array); +CAMLextern value caml_alloc_sprintf(const char * format, ...); + +typedef void (*final_fun)(value); +CAMLextern value caml_alloc_final (mlsize_t, /*size in words*/ + final_fun, /*finalization function*/ + mlsize_t, /*resources consumed*/ + mlsize_t /*max resources*/); + +CAMLextern int caml_convert_flag_list (value, int *); + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_ALLOC_H */ diff -Nru ocaml-4.01.0/byterun/caml/backtrace.h ocaml-4.02.3/byterun/caml/backtrace.h --- ocaml-4.01.0/byterun/caml/backtrace.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/backtrace.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,31 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2001 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_BACKTRACE_H +#define CAML_BACKTRACE_H + +#include "mlvalues.h" + +CAMLextern int caml_backtrace_active; +CAMLextern int caml_backtrace_pos; +CAMLextern code_t * caml_backtrace_buffer; +CAMLextern value caml_backtrace_last_exn; +CAMLextern char * caml_cds_file; + +CAMLprim value caml_record_backtrace(value vflag); +#ifndef NATIVE_CODE +extern void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise); +#endif +CAMLextern void caml_print_exception_backtrace(void); + +#endif /* CAML_BACKTRACE_H */ diff -Nru ocaml-4.01.0/byterun/caml/callback.h ocaml-4.02.3/byterun/caml/callback.h --- ocaml-4.01.0/byterun/caml/callback.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/callback.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,57 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Callbacks from C to OCaml */ + +#ifndef CAML_CALLBACK_H +#define CAML_CALLBACK_H + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "mlvalues.h" + +#ifdef __cplusplus +extern "C" { +#endif + +CAMLextern value caml_callback (value closure, value arg); +CAMLextern value caml_callback2 (value closure, value arg1, value arg2); +CAMLextern value caml_callback3 (value closure, value arg1, value arg2, + value arg3); +CAMLextern value caml_callbackN (value closure, int narg, value args[]); + +CAMLextern value caml_callback_exn (value closure, value arg); +CAMLextern value caml_callback2_exn (value closure, value arg1, value arg2); +CAMLextern value caml_callback3_exn (value closure, + value arg1, value arg2, value arg3); +CAMLextern value caml_callbackN_exn (value closure, int narg, value args[]); + +#define Make_exception_result(v) ((v) | 2) +#define Is_exception_result(v) (((v) & 3) == 2) +#define Extract_exception(v) ((v) & ~3) + +CAMLextern value * caml_named_value (char const * name); +typedef void (*caml_named_action) (value*, char *); +CAMLextern void caml_iterate_named_values(caml_named_action f); + +CAMLextern void caml_main (char ** argv); +CAMLextern void caml_startup (char ** argv); + +CAMLextern int caml_callback_depth; + +#ifdef __cplusplus +} +#endif + +#endif diff -Nru ocaml-4.01.0/byterun/caml/compact.h ocaml-4.02.3/byterun/caml/compact.h --- ocaml-4.01.0/byterun/caml/compact.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/compact.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,25 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_COMPACT_H +#define CAML_COMPACT_H + + +#include "config.h" +#include "misc.h" + +extern void caml_compact_heap (void); +extern void caml_compact_heap_maybe (void); + + +#endif /* CAML_COMPACT_H */ diff -Nru ocaml-4.01.0/byterun/caml/compare.h ocaml-4.02.3/byterun/caml/compare.h --- ocaml-4.01.0/byterun/caml/compare.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/compare.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,19 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, Projet Moscova, INRIA Rocquencourt */ +/* */ +/* Copyright 2003 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_COMPARE_H +#define CAML_COMPARE_H + +CAMLextern int caml_compare_unordered; + +#endif /* CAML_COMPARE_H */ diff -Nru ocaml-4.01.0/byterun/caml/compatibility.h ocaml-4.02.3/byterun/caml/compatibility.h --- ocaml-4.01.0/byterun/caml/compatibility.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/compatibility.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,369 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ +/* */ +/* Copyright 2003 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* definitions for compatibility with old identifiers */ + +#ifndef CAML_COMPATIBILITY_H +#define CAML_COMPATIBILITY_H + +#ifndef CAML_NAME_SPACE + +/* + #define --> CAMLextern (defined with CAMLexport or CAMLprim) + (rien) --> CAMLprim + g --> global C identifier + x --> special case + + SP* signals the special cases: + - when the identifier was not simply prefixed with [caml_] + - when the [caml_] version was already used for something else, and + was renamed out of the way (watch out for [caml_alloc] and + [caml_array_bound_error] in *.s) +*/ + +/* a faire: + - ui_* (reverifier que win32.c n'en depend pas) +*/ + + +/* **** alloc.c */ +#define alloc caml_alloc /*SP*/ +#define alloc_small caml_alloc_small +#define alloc_tuple caml_alloc_tuple +#define alloc_string caml_alloc_string +#define alloc_final caml_alloc_final +#define copy_string caml_copy_string +#define alloc_array caml_alloc_array +#define copy_string_array caml_copy_string_array +#define convert_flag_list caml_convert_flag_list + +/* **** array.c */ + +/* **** backtrace.c */ +#define backtrace_active caml_backtrace_active +#define backtrace_pos caml_backtrace_pos +#define backtrace_buffer caml_backtrace_buffer +#define backtrace_last_exn caml_backtrace_last_exn +#define print_exception_backtrace caml_print_exception_backtrace + +/* **** callback.c */ +#define callback_depth caml_callback_depth +#define callbackN_exn caml_callbackN_exn +#define callback_exn caml_callback_exn +#define callback2_exn caml_callback2_exn +#define callback3_exn caml_callback3_exn +#define callback caml_callback +#define callback2 caml_callback2 +#define callback3 caml_callback3 +#define callbackN caml_callbackN + +/* **** compact.c */ + +/* **** compare.c */ +#define compare_unordered caml_compare_unordered + +/* **** custom.c */ +#define alloc_custom caml_alloc_custom +#define register_custom_operations caml_register_custom_operations + +/* **** debugger.c */ + +/* **** dynlink.c */ + +/* **** extern.c */ +#define output_val caml_output_val +#define output_value_to_malloc caml_output_value_to_malloc +#define output_value_to_block caml_output_value_to_block +#define serialize_int_1 caml_serialize_int_1 +#define serialize_int_2 caml_serialize_int_2 +#define serialize_int_4 caml_serialize_int_4 +#define serialize_int_8 caml_serialize_int_8 +#define serialize_float_4 caml_serialize_float_4 +#define serialize_float_8 caml_serialize_float_8 +#define serialize_block_1 caml_serialize_block_1 +#define serialize_block_2 caml_serialize_block_2 +#define serialize_block_4 caml_serialize_block_4 +#define serialize_block_8 caml_serialize_block_8 +#define serialize_block_float_8 caml_serialize_block_float_8 + +/* **** fail.c */ +#define external_raise caml_external_raise +#define mlraise caml_raise /*SP*/ +#define raise_constant caml_raise_constant +#define raise_with_arg caml_raise_with_arg +#define raise_with_string caml_raise_with_string +#define failwith caml_failwith +#define invalid_argument caml_invalid_argument +#define array_bound_error caml_array_bound_error /*SP*/ +#define raise_out_of_memory caml_raise_out_of_memory +#define raise_stack_overflow caml_raise_stack_overflow +#define raise_sys_error caml_raise_sys_error +#define raise_end_of_file caml_raise_end_of_file +#define raise_zero_divide caml_raise_zero_divide +#define raise_not_found caml_raise_not_found +#define raise_sys_blocked_io caml_raise_sys_blocked_io +/* **** asmrun/fail.c */ +/* **** asmrun/.s */ + +/* **** finalise.c */ + +/* **** fix_code.c */ + +/* **** floats.c */ +/*#define Double_val caml_Double_val done in mlvalues.h as needed */ +/*#define Store_double_val caml_Store_double_val done in mlvalues.h as needed */ +#define copy_double caml_copy_double + +/* **** freelist.c */ + +/* **** gc_ctrl.c */ + +/* **** globroots.c */ +#define register_global_root caml_register_global_root +#define remove_global_root caml_remove_global_root + +/* **** hash.c */ +#define hash_variant caml_hash_variant + +/* **** instrtrace.c */ + +/* **** intern.c */ +#define input_val caml_input_val +#define input_val_from_string caml_input_val_from_string +#define input_value_from_malloc caml_input_value_from_malloc +#define input_value_from_block caml_input_value_from_block +#define deserialize_uint_1 caml_deserialize_uint_1 +#define deserialize_sint_1 caml_deserialize_sint_1 +#define deserialize_uint_2 caml_deserialize_uint_2 +#define deserialize_sint_2 caml_deserialize_sint_2 +#define deserialize_uint_4 caml_deserialize_uint_4 +#define deserialize_sint_4 caml_deserialize_sint_4 +#define deserialize_uint_8 caml_deserialize_uint_8 +#define deserialize_sint_8 caml_deserialize_sint_8 +#define deserialize_float_4 caml_deserialize_float_4 +#define deserialize_float_8 caml_deserialize_float_8 +#define deserialize_block_1 caml_deserialize_block_1 +#define deserialize_block_2 caml_deserialize_block_2 +#define deserialize_block_4 caml_deserialize_block_4 +#define deserialize_block_8 caml_deserialize_block_8 +#define deserialize_block_float_8 caml_deserialize_block_float_8 +#define deserialize_error caml_deserialize_error + +/* **** interp.c */ + +/* **** ints.c */ +#define int32_ops caml_int32_ops +#define copy_int32 caml_copy_int32 +/*#define Int64_val caml_Int64_val *** done in mlvalues.h as needed */ +#define int64_ops caml_int64_ops +#define copy_int64 caml_copy_int64 +#define nativeint_ops caml_nativeint_ops +#define copy_nativeint caml_copy_nativeint + +/* **** io.c */ +#define channel_mutex_free caml_channel_mutex_free +#define channel_mutex_lock caml_channel_mutex_lock +#define channel_mutex_unlock caml_channel_mutex_unlock +#define channel_mutex_unlock_exn caml_channel_mutex_unlock_exn +#define all_opened_channels caml_all_opened_channels +#define open_descriptor_in caml_open_descriptor_in /*SP*/ +#define open_descriptor_out caml_open_descriptor_out /*SP*/ +#define close_channel caml_close_channel /*SP*/ +#define channel_size caml_channel_size /*SP*/ +#define channel_binary_mode caml_channel_binary_mode +#define flush_partial caml_flush_partial /*SP*/ +#define flush caml_flush /*SP*/ +#define putword caml_putword +#define putblock caml_putblock +#define really_putblock caml_really_putblock +#define seek_out caml_seek_out /*SP*/ +#define pos_out caml_pos_out /*SP*/ +#define do_read caml_do_read +#define refill caml_refill +#define getword caml_getword +#define getblock caml_getblock +#define really_getblock caml_really_getblock +#define seek_in caml_seek_in /*SP*/ +#define pos_in caml_pos_in /*SP*/ +#define input_scan_line caml_input_scan_line /*SP*/ +#define finalize_channel caml_finalize_channel +#define alloc_channel caml_alloc_channel +/*#define Val_file_offset caml_Val_file_offset *** done in io.h as needed */ +/*#define File_offset_val caml_File_offset_val *** done in io.h as needed */ + +/* **** lexing.c */ + +/* **** main.c */ +/* *** no change */ + +/* **** major_gc.c */ +#define heap_start caml_heap_start +#define page_table caml_page_table + +/* **** md5.c */ +#define md5_string caml_md5_string +#define md5_chan caml_md5_chan +#define MD5Init caml_MD5Init +#define MD5Update caml_MD5Update +#define MD5Final caml_MD5Final +#define MD5Transform caml_MD5Transform + +/* **** memory.c */ +#define alloc_shr caml_alloc_shr +#define initialize caml_initialize +#define modify caml_modify +#define stat_alloc caml_stat_alloc +#define stat_free caml_stat_free +#define stat_resize caml_stat_resize + +/* **** meta.c */ + +/* **** minor_gc.c */ +#define young_start caml_young_start +#define young_end caml_young_end +#define young_ptr caml_young_ptr +#define young_limit caml_young_limit +#define ref_table caml_ref_table +#define minor_collection caml_minor_collection +#define check_urgent_gc caml_check_urgent_gc + +/* **** misc.c */ + +/* **** obj.c */ + +/* **** parsing.c */ + +/* **** prims.c */ + +/* **** printexc.c */ +#define format_caml_exception caml_format_exception /*SP*/ + +/* **** roots.c */ +#define local_roots caml_local_roots +#define scan_roots_hook caml_scan_roots_hook +#define do_local_roots caml_do_local_roots + +/* **** signals.c */ +#define pending_signals caml_pending_signals +#define something_to_do caml_something_to_do +#define enter_blocking_section_hook caml_enter_blocking_section_hook +#define leave_blocking_section_hook caml_leave_blocking_section_hook +#define try_leave_blocking_section_hook caml_try_leave_blocking_section_hook +#define async_action_hook caml_async_action_hook +#define enter_blocking_section caml_enter_blocking_section +#define leave_blocking_section caml_leave_blocking_section +#define convert_signal_number caml_convert_signal_number +/* **** asmrun/signals.c */ +#define garbage_collection caml_garbage_collection + +/* **** stacks.c */ +#define stack_low caml_stack_low +#define stack_high caml_stack_high +#define stack_threshold caml_stack_threshold +#define extern_sp caml_extern_sp +#define trapsp caml_trapsp +#define trap_barrier caml_trap_barrier + +/* **** startup.c */ +#define atom_table caml_atom_table +/* **** asmrun/startup.c */ +#define static_data_start caml_static_data_start +#define static_data_end caml_static_data_end + +/* **** str.c */ +#define string_length caml_string_length + +/* **** sys.c */ +#define sys_error caml_sys_error +#define sys_exit caml_sys_exit + +/* **** terminfo.c */ + +/* **** unix.c & win32.c */ +#define search_exe_in_path caml_search_exe_in_path + +/* **** weak.c */ + +/* **** asmcomp/asmlink.ml */ + +/* **** asmcomp/cmmgen.ml */ + +/* **** asmcomp/asmlink.ml, asmcomp/cmmgen.ml, asmcomp/compilenv.ml */ + +/* ************************************************************* */ + +/* **** otherlibs/bigarray */ +#define int8 caml_ba_int8 +#define uint8 caml_ba_uint8 +#define int16 caml_ba_int16 +#define uint16 caml_ba_uint16 +#define MAX_NUM_DIMS CAML_BA_MAX_NUM_DIMS +#define caml_bigarray_kind caml_ba_kind +#define BIGARRAY_FLOAT32 CAML_BA_FLOAT32 +#define BIGARRAY_FLOAT64 CAML_BA_FLOAT64 +#define BIGARRAY_SINT8 CAML_BA_SINT8 +#define BIGARRAY_UINT8 CAML_BA_UINT8 +#define BIGARRAY_SINT16 CAML_BA_SINT16 +#define BIGARRAY_UINT16 CAML_BA_UINT16 +#define BIGARRAY_INT32 CAML_BA_INT32 +#define BIGARRAY_INT64 CAML_BA_INT64 +#define BIGARRAY_CAML_INT CAML_BA_CAML_INT +#define BIGARRAY_NATIVE_INT CAML_BA_NATIVE_INT +#define BIGARRAY_COMPLEX32 CAML_BA_COMPLEX32 +#define BIGARRAY_COMPLEX64 CAML_BA_COMPLEX64 +#define BIGARRAY_KIND_MASK CAML_BA_KIND_MASK +#define caml_bigarray_layout caml_ba_layout +#define BIGARRAY_C_LAYOUT CAML_BA_C_LAYOUT +#define BIGARRAY_FORTRAN_LAYOUT CAML_BA_FORTRAN_LAYOUT +#define BIGARRAY_LAYOUT_MASK CAML_BA_LAYOUT_MASK +#define caml_bigarray_managed caml_ba_managed +#define BIGARRAY_EXTERNAL CAML_BA_EXTERNAL +#define BIGARRAY_MANAGED CAML_BA_MANAGED +#define BIGARRAY_MAPPED_FILE CAML_BA_MAPPED_FILE +#define BIGARRAY_MANAGED_MASK CAML_BA_MANAGED_MASK +#define caml_bigarray_proxy caml_ba_proxy +#define caml_bigarray caml_ba_array +#define Bigarray_val Caml_ba_array_val +#define Data_bigarray_val Caml_ba_data_val +#define alloc_bigarray caml_ba_alloc +#define alloc_bigarray_dims caml_ba_alloc_dims +#define bigarray_map_file caml_ba_map_file +#define bigarray_unmap_file caml_ba_unmap_file +#define bigarray_element_size caml_ba_element_size +#define bigarray_byte_size caml_ba_byte_size +#define bigarray_deserialize caml_ba_deserialize +#define MAX_BIGARRAY_MEMORY CAML_BA_MAX_MEMORY +#define bigarray_create caml_ba_create +#define bigarray_get_N caml_ba_get_N +#define bigarray_get_1 caml_ba_get_1 +#define bigarray_get_2 caml_ba_get_2 +#define bigarray_get_3 caml_ba_get_3 +#define bigarray_get_generic caml_ba_get_generic +#define bigarray_set_1 caml_ba_set_1 +#define bigarray_set_2 caml_ba_set_2 +#define bigarray_set_3 caml_ba_set_3 +#define bigarray_set_N caml_ba_set_N +#define bigarray_set_generic caml_ba_set_generic +#define bigarray_num_dims caml_ba_num_dims +#define bigarray_dim caml_ba_dim +#define bigarray_kind caml_ba_kind +#define bigarray_layout caml_ba_layout +#define bigarray_slice caml_ba_slice +#define bigarray_sub caml_ba_sub +#define bigarray_blit caml_ba_blit +#define bigarray_fill caml_ba_fill +#define bigarray_reshape caml_ba_reshape +#define bigarray_init caml_ba_init + +#endif /* CAML_NAME_SPACE */ +#endif /* CAML_COMPATIBILITY_H */ diff -Nru ocaml-4.01.0/byterun/caml/config.h ocaml-4.02.3/byterun/caml/config.h --- ocaml-4.01.0/byterun/caml/config.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/config.h 2015-04-12 11:03:39.000000000 +0200 @@ -0,0 +1,172 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_CONFIG_H +#define CAML_CONFIG_H + +/* */ +/* */ +/* */ +#include "../../config/m.h" +#include "../../config/s.h" +/* */ + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif + +/* Types for 32-bit integers, 64-bit integers, + native integers (as wide as a pointer type) */ + +#if SIZEOF_INT == 4 +typedef int int32; +typedef unsigned int uint32; +#define ARCH_INT32_PRINTF_FORMAT "" +#elif SIZEOF_LONG == 4 +typedef long int32; +typedef unsigned long uint32; +#define ARCH_INT32_PRINTF_FORMAT "l" +#elif SIZEOF_SHORT == 4 +typedef short int32; +typedef unsigned short uint32; +#define ARCH_INT32_PRINTF_FORMAT "" +#else +#error "No 32-bit integer type available" +#endif + +#ifndef ARCH_INT64_TYPE +#if SIZEOF_LONGLONG == 8 +#define ARCH_INT64_TYPE long long +#define ARCH_UINT64_TYPE unsigned long long +#define ARCH_INT64_PRINTF_FORMAT "ll" +#elif SIZEOF_LONG == 8 +#define ARCH_INT64_TYPE long +#define ARCH_UINT64_TYPE unsigned long +#define ARCH_INT64_PRINTF_FORMAT "l" +#else +#error "No 64-bit integer type available" +#endif +#endif + +typedef ARCH_INT64_TYPE int64; +typedef ARCH_UINT64_TYPE uint64; + +#if SIZEOF_PTR == SIZEOF_LONG +/* Standard models: ILP32 or I32LP64 */ +typedef long intnat; +typedef unsigned long uintnat; +#define ARCH_INTNAT_PRINTF_FORMAT "l" +#elif SIZEOF_PTR == SIZEOF_INT +/* Hypothetical IP32L64 model */ +typedef int intnat; +typedef unsigned int uintnat; +#define ARCH_INTNAT_PRINTF_FORMAT "" +#elif SIZEOF_PTR == 8 +/* Win64 model: IL32LLP64 */ +typedef int64 intnat; +typedef uint64 uintnat; +#define ARCH_INTNAT_PRINTF_FORMAT ARCH_INT64_PRINTF_FORMAT +#else +#error "No integer type available to represent pointers" +#endif + +/* Endianness of floats */ + +/* ARCH_FLOAT_ENDIANNESS encodes the byte order of doubles as follows: + the value [0xabcdefgh] means that the least significant byte of the + float is at byte offset [a], the next lsb at [b], ..., and the + most significant byte at [h]. */ + +#if defined(__arm__) && !defined(__ARM_EABI__) +#define ARCH_FLOAT_ENDIANNESS 0x45670123 +#elif defined(ARCH_BIG_ENDIAN) +#define ARCH_FLOAT_ENDIANNESS 0x76543210 +#else +#define ARCH_FLOAT_ENDIANNESS 0x01234567 +#endif + +/* We use threaded code interpretation if the compiler provides labels + as first-class values (GCC 2.x). */ + +#if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG) \ + && !defined (SHRINKED_GNUC) && !defined(CAML_JIT) +#define THREADED_CODE +#endif + + +/* Do not change this definition. */ +#define Page_size (1 << Page_log) + +/* Memory model parameters */ + +/* The size of a page for memory management (in bytes) is [1 << Page_log]. + It must be a multiple of [sizeof (value)] and >= 8 and <= 20. */ +#define Page_log 12 /* A page is 4 kilobytes. */ + +/* Initial size of stack (bytes). */ +#define Stack_size (4096 * sizeof(value)) + +/* Minimum free size of stack (bytes); below that, it is reallocated. */ +#define Stack_threshold (256 * sizeof(value)) + +/* Default maximum size of the stack (words). */ +#define Max_stack_def (1024 * 1024) + + +/* Maximum size of a block allocated in the young generation (words). */ +/* Must be > 4 */ +#define Max_young_wosize 256 + + +/* Minimum size of the minor zone (words). + This must be at least [Max_young_wosize + 1]. */ +#define Minor_heap_min 4096 + +/* Maximum size of the minor zone (words). + Must be greater than or equal to [Minor_heap_min]. +*/ +#define Minor_heap_max (1 << 28) + +/* Default size of the minor zone. (words) */ +#define Minor_heap_def 262144 + + +/* Minimum size increment when growing the heap (words). + Must be a multiple of [Page_size / sizeof (value)]. */ +#define Heap_chunk_min (15 * Page_size) + +/* Default size increment when growing the heap. + If this is <= 1000, it's a percentage of the current heap size. + If it is > 1000, it's a number of words. */ +#define Heap_chunk_def 15 + +/* Default initial size of the major heap (words); + Must be a multiple of [Page_size / sizeof (value)]. */ +#define Init_heap_def (31 * Page_size) +/* (about 512 kB for a 32-bit platform, 1 MB for a 64-bit platform.) */ + + +/* Default speed setting for the major GC. The heap will grow until + the dead objects and the free list represent this percentage of the + total size of live objects. */ +#define Percent_free_def 80 + +/* Default setting for the compacter: 500% + (i.e. trigger the compacter when 5/6 of the heap is free or garbage) + This can be set quite high because the overhead is over-estimated + when fragmentation occurs. + */ +#define Max_percent_free_def 500 + + +#endif /* CAML_CONFIG_H */ diff -Nru ocaml-4.01.0/byterun/caml/custom.h ocaml-4.02.3/byterun/caml/custom.h --- ocaml-4.01.0/byterun/caml/custom.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/custom.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,71 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ +/* */ +/* Copyright 2000 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_CUSTOM_H +#define CAML_CUSTOM_H + + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "mlvalues.h" + +struct custom_operations { + char *identifier; + void (*finalize)(value v); + int (*compare)(value v1, value v2); + intnat (*hash)(value v); + void (*serialize)(value v, + /*out*/ uintnat * wsize_32 /*size in bytes*/, + /*out*/ uintnat * wsize_64 /*size in bytes*/); + uintnat (*deserialize)(void * dst); + int (*compare_ext)(value v1, value v2); +}; + +#define custom_finalize_default NULL +#define custom_compare_default NULL +#define custom_hash_default NULL +#define custom_serialize_default NULL +#define custom_deserialize_default NULL +#define custom_compare_ext_default NULL + +#define Custom_ops_val(v) (*((struct custom_operations **) (v))) + +#ifdef __cplusplus +extern "C" { +#endif + + +CAMLextern value caml_alloc_custom(struct custom_operations * ops, + uintnat size, /*size in bytes*/ + mlsize_t mem, /*resources consumed*/ + mlsize_t max /*max resources*/); + +CAMLextern void caml_register_custom_operations(struct custom_operations * ops); + +CAMLextern int caml_compare_unordered; + /* Used by custom comparison to report unordered NaN-like cases. */ + +/* */ +extern struct custom_operations * caml_find_custom_operations(char * ident); +extern struct custom_operations * + caml_final_custom_operations(void (*fn)(value)); + +extern void caml_init_custom_operations(void); +/* */ + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_CUSTOM_H */ diff -Nru ocaml-4.01.0/byterun/caml/debugger.h ocaml-4.02.3/byterun/caml/debugger.h --- ocaml-4.01.0/byterun/caml/debugger.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/debugger.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,111 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Interface with the debugger */ + +#ifndef CAML_DEBUGGER_H +#define CAML_DEBUGGER_H + +#include "misc.h" +#include "mlvalues.h" + +CAMLextern int caml_debugger_in_use; +CAMLextern int caml_debugger_fork_mode; /* non-zero for parent */ +extern uintnat caml_event_count; + +enum event_kind { + EVENT_COUNT, BREAKPOINT, PROGRAM_START, PROGRAM_EXIT, + TRAP_BARRIER, UNCAUGHT_EXC +}; + +void caml_debugger_init (void); +void caml_debugger (enum event_kind event); +void caml_debugger_cleanup_fork (void); + +/* Communication protocol */ + +/* Requests from the debugger to the runtime system */ + +enum debugger_request { + REQ_SET_EVENT = 'e', /* uint32 pos */ + /* Set an event on the instruction at position pos */ + REQ_SET_BREAKPOINT = 'B', /* uint32 pos, (char k) */ + /* Set a breakpoint at position pos */ + /* In profiling mode, the breakpoint kind is set to k */ + REQ_RESET_INSTR = 'i', /* uint32 pos */ + /* Clear an event or breapoint at position pos, restores initial instr. */ + REQ_CHECKPOINT = 'c', /* no args */ + /* Checkpoint the runtime system by forking a child process. + Reply is pid of child process or -1 if checkpoint failed. */ + REQ_GO = 'g', /* uint32 n */ + /* Run the program for n events. + Reply is one of debugger_reply described below. */ + REQ_STOP = 's', /* no args */ + /* Terminate the runtime system */ + REQ_WAIT = 'w', /* no args */ + /* Reap one dead child (a discarded checkpoint). */ + REQ_INITIAL_FRAME = '0', /* no args */ + /* Set current frame to bottom frame (the one currently executing). + Reply is stack offset and current pc. */ + REQ_GET_FRAME = 'f', /* no args */ + /* Return current frame location (stack offset + current pc). */ + REQ_SET_FRAME = 'S', /* uint32 stack_offset */ + /* Set current frame to given stack offset. No reply. */ + REQ_UP_FRAME = 'U', /* uint32 n */ + /* Move one frame up. Argument n is size of current frame (in words). + Reply is stack offset and current pc, or -1 if top of stack reached. */ + REQ_SET_TRAP_BARRIER = 'b', /* uint32 offset */ + /* Set the trap barrier at the given offset. */ + REQ_GET_LOCAL = 'L', /* uint32 slot_number */ + /* Return the local variable at the given slot in the current frame. + Reply is one value. */ + REQ_GET_ENVIRONMENT = 'E', /* uint32 slot_number */ + /* Return the local variable at the given slot in the heap environment + of the current frame. Reply is one value. */ + REQ_GET_GLOBAL = 'G', /* uint32 global_number */ + /* Return the specified global variable. Reply is one value. */ + REQ_GET_ACCU = 'A', /* no args */ + /* Return the current contents of the accumulator. Reply is one value. */ + REQ_GET_HEADER = 'H', /* mlvalue v */ + /* As REQ_GET_OBJ, but sends only the header. */ + REQ_GET_FIELD = 'F', /* mlvalue v, uint32 fieldnum */ + /* As REQ_GET_OBJ, but sends only one field. */ + REQ_MARSHAL_OBJ = 'M', /* mlvalue v */ + /* Send a copy of the data structure rooted at v, using the same + format as [caml_output_value]. */ + REQ_GET_CLOSURE_CODE = 'C', /* mlvalue v */ + /* Send the code address of the given closure. + Reply is one uint32. */ + REQ_SET_FORK_MODE = 'K' /* uint32 m */ + /* Set whether to follow the child (m=0) or the parent on fork. */ +}; + +/* Replies to a REQ_GO request. All replies are followed by three uint32: + - the value of the event counter + - the position of the stack + - the current pc. */ + +enum debugger_reply { + REP_EVENT = 'e', + /* Event counter reached 0. */ + REP_BREAKPOINT = 'b', + /* Breakpoint hit. */ + REP_EXITED = 'x', + /* Program exited by calling exit or reaching the end of the source. */ + REP_TRAP = 's', + /* Trap barrier crossed. */ + REP_UNCAUGHT_EXC = 'u' + /* Program exited due to a stray exception. */ +}; + +#endif /* CAML_DEBUGGER_H */ diff -Nru ocaml-4.01.0/byterun/caml/dynlink.h ocaml-4.02.3/byterun/caml/dynlink.h --- ocaml-4.01.0/byterun/caml/dynlink.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/dynlink.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,36 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2000 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Dynamic loading of C primitives. */ + +#ifndef CAML_DYNLINK_H +#define CAML_DYNLINK_H + +#include "misc.h" + +/* Build the table of primitives, given a search path, a list + of shared libraries, and a list of primitive names + (all three 0-separated in char arrays). + Abort the runtime system on error. */ +extern void caml_build_primitive_table(char * lib_path, + char * libs, + char * req_prims); + +/* The search path for shared libraries */ +extern struct ext_table caml_shared_libs_path; + +/* Build the table of primitives as a copy of the builtin primitive table. + Used for executables generated by ocamlc -output-obj. */ +extern void caml_build_primitive_table_builtin(void); + +#endif /* CAML_DYNLINK_H */ diff -Nru ocaml-4.01.0/byterun/caml/exec.h ocaml-4.02.3/byterun/caml/exec.h --- ocaml-4.01.0/byterun/caml/exec.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/exec.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,60 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* exec.h : format of executable bytecode files */ + +#ifndef CAML_EXEC_H +#define CAML_EXEC_H + +/* Executable bytecode files are composed of a number of sections, + identified by 4-character names. A table of contents at the + end of the file lists the section names along with their sizes, + in the order in which they appear in the file: + + offset 0 ---> initial junk + data for section 1 + data for section 2 + ... + data for section N + table of contents: + descriptor for section 1 + ... + descriptor for section N + trailer + end of file ---> +*/ + +/* Structure of t.o.c. entries + Numerical quantities are 32-bit unsigned integers, big endian */ + +struct section_descriptor { + char name[4]; /* Section name */ + uint32 len; /* Length of data in bytes */ +}; + +/* Structure of the trailer. */ + +struct exec_trailer { + uint32 num_sections; /* Number of sections */ + char magic[12]; /* The magic number */ + struct section_descriptor * section; /* Not part of file */ +}; + +#define TRAILER_SIZE (4+12) + +/* Magic number for this release */ + +#define EXEC_MAGIC "Caml1999X011" + + +#endif /* CAML_EXEC_H */ diff -Nru ocaml-4.01.0/byterun/caml/fail.h ocaml-4.02.3/byterun/caml/fail.h --- ocaml-4.01.0/byterun/caml/fail.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/fail.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,84 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_FAIL_H +#define CAML_FAIL_H + +/* */ +#include +/* */ + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "misc.h" +#include "mlvalues.h" + +/* */ +#define OUT_OF_MEMORY_EXN 0 /* "Out_of_memory" */ +#define SYS_ERROR_EXN 1 /* "Sys_error" */ +#define FAILURE_EXN 2 /* "Failure" */ +#define INVALID_EXN 3 /* "Invalid_argument" */ +#define END_OF_FILE_EXN 4 /* "End_of_file" */ +#define ZERO_DIVIDE_EXN 5 /* "Division_by_zero" */ +#define NOT_FOUND_EXN 6 /* "Not_found" */ +#define MATCH_FAILURE_EXN 7 /* "Match_failure" */ +#define STACK_OVERFLOW_EXN 8 /* "Stack_overflow" */ +#define SYS_BLOCKED_IO 9 /* "Sys_blocked_io" */ +#define ASSERT_FAILURE_EXN 10 /* "Assert_failure" */ +#define UNDEFINED_RECURSIVE_MODULE_EXN 11 /* "Undefined_recursive_module" */ + +#ifdef POSIX_SIGNALS +struct longjmp_buffer { + sigjmp_buf buf; +}; +#else +struct longjmp_buffer { + jmp_buf buf; +}; +#define sigsetjmp(buf,save) setjmp(buf) +#define siglongjmp(buf,val) longjmp(buf,val) +#endif + +CAMLextern struct longjmp_buffer * caml_external_raise; +extern value caml_exn_bucket; +int caml_is_special_exception(value exn); + +/* */ + +#ifdef __cplusplus +extern "C" { +#endif + +CAMLextern void caml_raise (value bucket) Noreturn; +CAMLextern void caml_raise_constant (value tag) Noreturn; +CAMLextern void caml_raise_with_arg (value tag, value arg) Noreturn; +CAMLextern void caml_raise_with_args (value tag, int nargs, value arg[]) + Noreturn; +CAMLextern void caml_raise_with_string (value tag, char const * msg) Noreturn; +CAMLextern void caml_failwith (char const *) Noreturn; +CAMLextern void caml_invalid_argument (char const *) Noreturn; +CAMLextern void caml_raise_out_of_memory (void) Noreturn; +CAMLextern void caml_raise_stack_overflow (void) Noreturn; +CAMLextern void caml_raise_sys_error (value) Noreturn; +CAMLextern void caml_raise_end_of_file (void) Noreturn; +CAMLextern void caml_raise_zero_divide (void) Noreturn; +CAMLextern void caml_raise_not_found (void) Noreturn; +CAMLextern void caml_array_bound_error (void) Noreturn; +CAMLextern void caml_raise_sys_blocked_io (void) Noreturn; + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_FAIL_H */ diff -Nru ocaml-4.01.0/byterun/caml/finalise.h ocaml-4.02.3/byterun/caml/finalise.h --- ocaml-4.01.0/byterun/caml/finalise.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/finalise.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,27 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ +/* */ +/* Copyright 2000 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_FINALISE_H +#define CAML_FINALISE_H + +#include "roots.h" + +void caml_final_update (void); +void caml_final_do_calls (void); +void caml_final_do_strong_roots (scanning_action f); +void caml_final_do_weak_roots (scanning_action f); +void caml_final_do_young_roots (scanning_action f); +void caml_final_empty_young (void); +value caml_final_register (value f, value v); + +#endif /* CAML_FINALISE_H */ diff -Nru ocaml-4.01.0/byterun/caml/fix_code.h ocaml-4.02.3/byterun/caml/fix_code.h --- ocaml-4.01.0/byterun/caml/fix_code.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/fix_code.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,40 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Handling of blocks of bytecode (endianness switch, threading). */ + +#ifndef CAML_FIX_CODE_H +#define CAML_FIX_CODE_H + + +#include "config.h" +#include "misc.h" +#include "mlvalues.h" + +extern code_t caml_start_code; +extern asize_t caml_code_size; +extern unsigned char * caml_saved_code; + +void caml_init_code_fragments(); +void caml_load_code (int fd, asize_t len); +void caml_fixup_endianness (code_t code, asize_t len); +void caml_set_instruction (code_t pos, opcode_t instr); +int caml_is_instruction (opcode_t instr1, opcode_t instr2); + +#ifdef THREADED_CODE +extern char ** caml_instr_table; +extern char * caml_instr_base; +void caml_thread_code (code_t code, asize_t len); +#endif + +#endif /* CAML_FIX_CODE_H */ diff -Nru ocaml-4.01.0/byterun/caml/freelist.h ocaml-4.02.3/byterun/caml/freelist.h --- ocaml-4.01.0/byterun/caml/freelist.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/freelist.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,34 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Free lists of heap blocks. */ + +#ifndef CAML_FREELIST_H +#define CAML_FREELIST_H + + +#include "misc.h" +#include "mlvalues.h" + +extern asize_t caml_fl_cur_size; /* size in words */ + +char *caml_fl_allocate (mlsize_t); +void caml_fl_init_merge (void); +void caml_fl_reset (void); +char *caml_fl_merge_block (char *); +void caml_fl_add_blocks (char *); +void caml_make_free_blocks (value *, mlsize_t, int, int); +void caml_set_allocation_policy (uintnat); + + +#endif /* CAML_FREELIST_H */ diff -Nru ocaml-4.01.0/byterun/caml/gc_ctrl.h ocaml-4.02.3/byterun/caml/gc_ctrl.h --- ocaml-4.01.0/byterun/caml/gc_ctrl.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/gc_ctrl.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,42 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_GC_CTRL_H +#define CAML_GC_CTRL_H + +#include "misc.h" + +extern double + caml_stat_minor_words, + caml_stat_promoted_words, + caml_stat_major_words; + +extern intnat + caml_stat_minor_collections, + caml_stat_major_collections, + caml_stat_heap_size, + caml_stat_top_heap_size, + caml_stat_compactions, + caml_stat_heap_chunks; + +uintnat caml_normalize_heap_increment (uintnat); + +void caml_init_gc (uintnat, uintnat, uintnat, + uintnat, uintnat); + + +#ifdef DEBUG +void caml_heap_check (void); +#endif + +#endif /* CAML_GC_CTRL_H */ diff -Nru ocaml-4.01.0/byterun/caml/gc.h ocaml-4.02.3/byterun/caml/gc.h --- ocaml-4.01.0/byterun/caml/gc.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/gc.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,56 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_GC_H +#define CAML_GC_H + + +#include "mlvalues.h" + +#define Caml_white (0 << 8) +#define Caml_gray (1 << 8) +#define Caml_blue (2 << 8) +#define Caml_black (3 << 8) + +#define Color_hd(hd) ((color_t) ((hd) & Caml_black)) +#define Color_hp(hp) (Color_hd (Hd_hp (hp))) +#define Color_val(val) (Color_hd (Hd_val (val))) + +#define Is_white_hd(hd) (Color_hd (hd) == Caml_white) +#define Is_gray_hd(hd) (Color_hd (hd) == Caml_gray) +#define Is_blue_hd(hd) (Color_hd (hd) == Caml_blue) +#define Is_black_hd(hd) (Color_hd (hd) == Caml_black) + +#define Whitehd_hd(hd) (((hd) & ~Caml_black)/*| Caml_white*/) +#define Grayhd_hd(hd) (((hd) & ~Caml_black) | Caml_gray) +#define Blackhd_hd(hd) (((hd)/*& ~Caml_black*/)| Caml_black) +#define Bluehd_hd(hd) (((hd) & ~Caml_black) | Caml_blue) + +/* This depends on the layout of the header. See [mlvalues.h]. */ +#define Make_header(wosize, tag, color) \ + (/*Assert ((wosize) <= Max_wosize),*/ \ + ((header_t) (((header_t) (wosize) << 10) \ + + (color) \ + + (tag_t) (tag))) \ + ) + +#define Is_white_val(val) (Color_val(val) == Caml_white) +#define Is_gray_val(val) (Color_val(val) == Caml_gray) +#define Is_blue_val(val) (Color_val(val) == Caml_blue) +#define Is_black_val(val) (Color_val(val) == Caml_black) + +/* For extern.c */ +#define Colornum_hd(hd) ((color_t) (((hd) >> 8) & 3)) +#define Coloredhd_hd(hd,colnum) (((hd) & ~Caml_black) | ((colnum) << 8)) + +#endif /* CAML_GC_H */ diff -Nru ocaml-4.01.0/byterun/caml/globroots.h ocaml-4.02.3/byterun/caml/globroots.h --- ocaml-4.01.0/byterun/caml/globroots.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/globroots.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,25 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2001 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Registration of global memory roots */ + +#ifndef CAML_GLOBROOTS_H +#define CAML_GLOBROOTS_H + +#include "mlvalues.h" +#include "roots.h" + +void caml_scan_global_roots(scanning_action f); +void caml_scan_global_young_roots(scanning_action f); + +#endif /* CAML_GLOBROOTS_H */ diff -Nru ocaml-4.01.0/byterun/caml/hash.h ocaml-4.02.3/byterun/caml/hash.h --- ocaml-4.01.0/byterun/caml/hash.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/hash.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,36 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ +/* */ +/* Copyright 2011 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Auxiliary functions for custom hash functions */ + +#ifndef CAML_HASH_H +#define CAML_HASH_H + +#include "mlvalues.h" + +#ifdef __cplusplus +extern "C" { +#endif + +CAMLextern uint32 caml_hash_mix_uint32(uint32 h, uint32 d); +CAMLextern uint32 caml_hash_mix_intnat(uint32 h, intnat d); +CAMLextern uint32 caml_hash_mix_int64(uint32 h, int64 d); +CAMLextern uint32 caml_hash_mix_double(uint32 h, double d); +CAMLextern uint32 caml_hash_mix_float(uint32 h, float d); +CAMLextern uint32 caml_hash_mix_string(uint32 h, value s); + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_HASH_H */ diff -Nru ocaml-4.01.0/byterun/caml/instrtrace.h ocaml-4.02.3/byterun/caml/instrtrace.h --- ocaml-4.01.0/byterun/caml/instrtrace.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/instrtrace.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,30 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Trace the instructions executed */ + +#ifndef _instrtrace_ +#define _instrtrace_ + + +#include "mlvalues.h" +#include "misc.h" + +extern int caml_trace_flag; +extern intnat caml_icount; +void caml_stop_here (void); +void caml_disasm_instr (code_t pc); +void caml_trace_value_file (value v, code_t prog, int proglen, FILE * f); +void caml_trace_accu_sp_file(value accu, value * sp, code_t prog, int proglen, + FILE * f); +#endif diff -Nru ocaml-4.01.0/byterun/caml/instruct.h ocaml-4.02.3/byterun/caml/instruct.h --- ocaml-4.01.0/byterun/caml/instruct.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/instruct.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,62 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* The instruction set. */ + +#ifndef CAML_INSTRUCT_H +#define CAML_INSTRUCT_H + +enum instructions { + ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, + ACC, PUSH, + PUSHACC0, PUSHACC1, PUSHACC2, PUSHACC3, + PUSHACC4, PUSHACC5, PUSHACC6, PUSHACC7, + PUSHACC, POP, ASSIGN, + ENVACC1, ENVACC2, ENVACC3, ENVACC4, ENVACC, + PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC4, PUSHENVACC, + PUSH_RETADDR, APPLY, APPLY1, APPLY2, APPLY3, + APPTERM, APPTERM1, APPTERM2, APPTERM3, + RETURN, RESTART, GRAB, + CLOSURE, CLOSUREREC, + OFFSETCLOSUREM2, OFFSETCLOSURE0, OFFSETCLOSURE2, OFFSETCLOSURE, + PUSHOFFSETCLOSUREM2, PUSHOFFSETCLOSURE0, + PUSHOFFSETCLOSURE2, PUSHOFFSETCLOSURE, + GETGLOBAL, PUSHGETGLOBAL, GETGLOBALFIELD, PUSHGETGLOBALFIELD, SETGLOBAL, + ATOM0, ATOM, PUSHATOM0, PUSHATOM, + MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, MAKEFLOATBLOCK, + GETFIELD0, GETFIELD1, GETFIELD2, GETFIELD3, GETFIELD, GETFLOATFIELD, + SETFIELD0, SETFIELD1, SETFIELD2, SETFIELD3, SETFIELD, SETFLOATFIELD, + VECTLENGTH, GETVECTITEM, SETVECTITEM, + GETSTRINGCHAR, SETSTRINGCHAR, + BRANCH, BRANCHIF, BRANCHIFNOT, SWITCH, BOOLNOT, + PUSHTRAP, POPTRAP, RAISE, + CHECK_SIGNALS, + C_CALL1, C_CALL2, C_CALL3, C_CALL4, C_CALL5, C_CALLN, + CONST0, CONST1, CONST2, CONST3, CONSTINT, + PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT, + NEGINT, ADDINT, SUBINT, MULINT, DIVINT, MODINT, + ANDINT, ORINT, XORINT, LSLINT, LSRINT, ASRINT, + EQ, NEQ, LTINT, LEINT, GTINT, GEINT, + OFFSETINT, OFFSETREF, ISINT, + GETMETHOD, + BEQ, BNEQ, BLTINT, BLEINT, BGTINT, BGEINT, + ULTINT, UGEINT, + BULTINT, BUGEINT, + GETPUBMET, GETDYNMET, + STOP, + EVENT, BREAK, + RERAISE, RAISE_NOTRACE, +FIRST_UNIMPLEMENTED_OP}; + + +#endif /* CAML_INSTRUCT_H */ diff -Nru ocaml-4.01.0/byterun/caml/int64_emul.h ocaml-4.02.3/byterun/caml/int64_emul.h --- ocaml-4.01.0/byterun/caml/int64_emul.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/int64_emul.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,287 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2002 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Software emulation of 64-bit integer arithmetic, for C compilers + that do not support it. */ + +#ifndef CAML_INT64_EMUL_H +#define CAML_INT64_EMUL_H + +#include + +#ifdef ARCH_BIG_ENDIAN +#define I64_literal(hi,lo) { hi, lo } +#else +#define I64_literal(hi,lo) { lo, hi } +#endif + +#define I64_split(x,hi,lo) (hi = (x).h, lo = (x).l) + +/* Unsigned comparison */ +static int I64_ucompare(uint64 x, uint64 y) +{ + if (x.h > y.h) return 1; + if (x.h < y.h) return -1; + if (x.l > y.l) return 1; + if (x.l < y.l) return -1; + return 0; +} + +#define I64_ult(x, y) (I64_ucompare(x, y) < 0) + +/* Signed comparison */ +static int I64_compare(int64 x, int64 y) +{ + if ((int32)x.h > (int32)y.h) return 1; + if ((int32)x.h < (int32)y.h) return -1; + if (x.l > y.l) return 1; + if (x.l < y.l) return -1; + return 0; +} + +/* Negation */ +static int64 I64_neg(int64 x) +{ + int64 res; + res.l = -x.l; + res.h = ~x.h; + if (res.l == 0) res.h++; + return res; +} + +/* Addition */ +static int64 I64_add(int64 x, int64 y) +{ + int64 res; + res.l = x.l + y.l; + res.h = x.h + y.h; + if (res.l < x.l) res.h++; + return res; +} + +/* Subtraction */ +static int64 I64_sub(int64 x, int64 y) +{ + int64 res; + res.l = x.l - y.l; + res.h = x.h - y.h; + if (x.l < y.l) res.h--; + return res; +} + +/* Multiplication */ +static int64 I64_mul(int64 x, int64 y) +{ + int64 res; + uint32 prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF); + uint32 prod10 = (x.l >> 16) * (y.l & 0xFFFF); + uint32 prod01 = (x.l & 0xFFFF) * (y.l >> 16); + uint32 prod11 = (x.l >> 16) * (y.l >> 16); + res.l = prod00; + res.h = prod11 + (prod01 >> 16) + (prod10 >> 16); + prod01 = prod01 << 16; res.l += prod01; if (res.l < prod01) res.h++; + prod10 = prod10 << 16; res.l += prod10; if (res.l < prod10) res.h++; + res.h += x.l * y.h + x.h * y.l; + return res; +} + +#define I64_is_zero(x) (((x).l | (x).h) == 0) +#define I64_is_negative(x) ((int32) (x).h < 0) +#define I64_is_min_int(x) ((x).l == 0 && (x).h == 0x80000000U) +#define I64_is_minus_one(x) (((x).l & (x).h) == 0xFFFFFFFFU) + +/* Bitwise operations */ +static int64 I64_and(int64 x, int64 y) +{ + int64 res; + res.l = x.l & y.l; + res.h = x.h & y.h; + return res; +} + +static int64 I64_or(int64 x, int64 y) +{ + int64 res; + res.l = x.l | y.l; + res.h = x.h | y.h; + return res; +} + +static int64 I64_xor(int64 x, int64 y) +{ + int64 res; + res.l = x.l ^ y.l; + res.h = x.h ^ y.h; + return res; +} + +/* Shifts */ +static int64 I64_lsl(int64 x, int s) +{ + int64 res; + s = s & 63; + if (s == 0) return x; + if (s < 32) { + res.l = x.l << s; + res.h = (x.h << s) | (x.l >> (32 - s)); + } else { + res.l = 0; + res.h = x.l << (s - 32); + } + return res; +} + +static int64 I64_lsr(int64 x, int s) +{ + int64 res; + s = s & 63; + if (s == 0) return x; + if (s < 32) { + res.l = (x.l >> s) | (x.h << (32 - s)); + res.h = x.h >> s; + } else { + res.l = x.h >> (s - 32); + res.h = 0; + } + return res; +} + +static int64 I64_asr(int64 x, int s) +{ + int64 res; + s = s & 63; + if (s == 0) return x; + if (s < 32) { + res.l = (x.l >> s) | (x.h << (32 - s)); + res.h = (int32) x.h >> s; + } else { + res.l = (int32) x.h >> (s - 32); + res.h = (int32) x.h >> 31; + } + return res; +} + +/* Division and modulus */ + +#define I64_SHL1(x) x.h = (x.h << 1) | (x.l >> 31); x.l <<= 1 +#define I64_SHR1(x) x.l = (x.l >> 1) | (x.h << 31); x.h >>= 1 + +static void I64_udivmod(uint64 modulus, uint64 divisor, + uint64 * quo, uint64 * mod) +{ + int64 quotient, mask; + int cmp; + + quotient.h = 0; quotient.l = 0; + mask.h = 0; mask.l = 1; + while ((int32) divisor.h >= 0) { + cmp = I64_ucompare(divisor, modulus); + I64_SHL1(divisor); + I64_SHL1(mask); + if (cmp >= 0) break; + } + while (mask.l | mask.h) { + if (I64_ucompare(modulus, divisor) >= 0) { + quotient.h |= mask.h; quotient.l |= mask.l; + modulus = I64_sub(modulus, divisor); + } + I64_SHR1(mask); + I64_SHR1(divisor); + } + *quo = quotient; + *mod = modulus; +} + +static int64 I64_div(int64 x, int64 y) +{ + int64 q, r; + int32 sign; + + sign = x.h ^ y.h; + if ((int32) x.h < 0) x = I64_neg(x); + if ((int32) y.h < 0) y = I64_neg(y); + I64_udivmod(x, y, &q, &r); + if (sign < 0) q = I64_neg(q); + return q; +} + +static int64 I64_mod(int64 x, int64 y) +{ + int64 q, r; + int32 sign; + + sign = x.h; + if ((int32) x.h < 0) x = I64_neg(x); + if ((int32) y.h < 0) y = I64_neg(y); + I64_udivmod(x, y, &q, &r); + if (sign < 0) r = I64_neg(r); + return r; +} + +/* Coercions */ + +static int64 I64_of_int32(int32 x) +{ + int64 res; + res.l = x; + res.h = x >> 31; + return res; +} + +#define I64_to_int32(x) ((int32) (x).l) + +/* Note: we assume sizeof(intnat) = 4 here, which is true otherwise + autoconfiguration would have selected native 64-bit integers */ +#define I64_of_intnat I64_of_int32 +#define I64_to_intnat I64_to_int32 + +static double I64_to_double(int64 x) +{ + double res; + int32 sign = x.h; + if (sign < 0) x = I64_neg(x); + res = ldexp((double) x.h, 32) + x.l; + if (sign < 0) res = -res; + return res; +} + +static int64 I64_of_double(double f) +{ + int64 res; + double frac, integ; + int neg; + + neg = (f < 0); + f = fabs(f); + frac = modf(ldexp(f, -32), &integ); + res.h = (uint32) integ; + res.l = (uint32) ldexp(frac, 32); + if (neg) res = I64_neg(res); + return res; +} + +static int64 I64_bswap(int64 x) +{ + int64 res; + res.h = (((x.l & 0x000000FF) << 24) | + ((x.l & 0x0000FF00) << 8) | + ((x.l & 0x00FF0000) >> 8) | + ((x.l & 0xFF000000) >> 24)); + res.l = (((x.h & 0x000000FF) << 24) | + ((x.h & 0x0000FF00) << 8) | + ((x.h & 0x00FF0000) >> 8) | + ((x.h & 0xFF000000) >> 24)); + return res; +} + +#endif /* CAML_INT64_EMUL_H */ diff -Nru ocaml-4.01.0/byterun/caml/int64_format.h ocaml-4.02.3/byterun/caml/int64_format.h --- ocaml-4.01.0/byterun/caml/int64_format.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/int64_format.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,105 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2002 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* printf-like formatting of 64-bit integers, in case the C library + printf() function does not support them. */ + +#ifndef CAML_INT64_FORMAT_H +#define CAML_INT64_FORMAT_H + +static void I64_format(char * buffer, char * fmt, int64 x) +{ + static char conv_lower[] = "0123456789abcdef"; + static char conv_upper[] = "0123456789ABCDEF"; + char rawbuffer[24]; + char justify, signstyle, filler, alternate, signedconv; + int base, width, sign, i, rawlen; + char * cvtbl; + char * p, * r; + int64 wbase, digit; + + /* Parsing of format */ + justify = '+'; + signstyle = '-'; + filler = ' '; + alternate = 0; + base = 0; + signedconv = 0; + width = 0; + cvtbl = conv_lower; + for (p = fmt; *p != 0; p++) { + switch (*p) { + case '-': + justify = '-'; break; + case '+': case ' ': + signstyle = *p; break; + case '0': + filler = '0'; break; + case '#': + alternate = 1; break; + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + width = atoi(p); + while (p[1] >= '0' && p[1] <= '9') p++; + break; + case 'd': case 'i': + signedconv = 1; /* fallthrough */ + case 'u': + base = 10; break; + case 'x': + base = 16; break; + case 'X': + base = 16; cvtbl = conv_upper; break; + case 'o': + base = 8; break; + } + } + if (base == 0) { buffer[0] = 0; return; } + /* Do the conversion */ + sign = 1; + if (signedconv && I64_is_negative(x)) { sign = -1; x = I64_neg(x); } + r = rawbuffer + sizeof(rawbuffer); + wbase = I64_of_int32(base); + do { + I64_udivmod(x, wbase, &x, &digit); + *--r = cvtbl[I64_to_int32(digit)]; + } while (! I64_is_zero(x)); + rawlen = rawbuffer + sizeof(rawbuffer) - r; + /* Adjust rawlen to reflect additional chars (sign, etc) */ + if (signedconv && (sign < 0 || signstyle != '-')) rawlen++; + if (alternate) { + if (base == 8) rawlen += 1; + if (base == 16) rawlen += 2; + } + /* Do the formatting */ + p = buffer; + if (justify == '+' && filler == ' ') { + for (i = rawlen; i < width; i++) *p++ = ' '; + } + if (signedconv) { + if (sign < 0) *p++ = '-'; + else if (signstyle != '-') *p++ = signstyle; + } + if (alternate && base == 8) *p++ = '0'; + if (alternate && base == 16) { *p++ = '0'; *p++ = 'x'; } + if (justify == '+' && filler == '0') { + for (i = rawlen; i < width; i++) *p++ = '0'; + } + while (r < rawbuffer + sizeof(rawbuffer)) *p++ = *r++; + if (justify == '-') { + for (i = rawlen; i < width; i++) *p++ = ' '; + } + *p = 0; +} + +#endif /* CAML_INT64_FORMAT_H */ diff -Nru ocaml-4.01.0/byterun/caml/int64_native.h ocaml-4.02.3/byterun/caml/int64_native.h --- ocaml-4.01.0/byterun/caml/int64_native.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/int64_native.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,61 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2002 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Wrapper macros around native 64-bit integer arithmetic, + so that it has the same interface as the software emulation + provided in int64_emul.h */ + +#ifndef CAML_INT64_NATIVE_H +#define CAML_INT64_NATIVE_H + +#define I64_literal(hi,lo) ((int64)(hi) << 32 | (lo)) +#define I64_split(x,hi,lo) (hi = (uint32)((x)>>32), lo = (uint32)(x)) +#define I64_compare(x,y) (((x) > (y)) - ((x) < (y))) +#define I64_ult(x,y) ((uint64)(x) < (uint64)(y)) +#define I64_neg(x) (-(x)) +#define I64_add(x,y) ((x) + (y)) +#define I64_sub(x,y) ((x) - (y)) +#define I64_mul(x,y) ((x) * (y)) +#define I64_is_zero(x) ((x) == 0) +#define I64_is_negative(x) ((x) < 0) +#define I64_is_min_int(x) ((x) == ((int64)1 << 63)) +#define I64_is_minus_one(x) ((x) == -1) + +#define I64_div(x,y) ((x) / (y)) +#define I64_mod(x,y) ((x) % (y)) +#define I64_udivmod(x,y,quo,rem) \ + (*(rem) = (uint64)(x) % (uint64)(y), \ + *(quo) = (uint64)(x) / (uint64)(y)) +#define I64_and(x,y) ((x) & (y)) +#define I64_or(x,y) ((x) | (y)) +#define I64_xor(x,y) ((x) ^ (y)) +#define I64_lsl(x,y) ((x) << (y)) +#define I64_asr(x,y) ((x) >> (y)) +#define I64_lsr(x,y) ((uint64)(x) >> (y)) +#define I64_to_intnat(x) ((intnat) (x)) +#define I64_of_intnat(x) ((intnat) (x)) +#define I64_to_int32(x) ((int32) (x)) +#define I64_of_int32(x) ((int64) (x)) +#define I64_to_double(x) ((double)(x)) +#define I64_of_double(x) ((int64)(x)) + +#define I64_bswap(x) ((((x) & 0x00000000000000FFULL) << 56) | \ + (((x) & 0x000000000000FF00ULL) << 40) | \ + (((x) & 0x0000000000FF0000ULL) << 24) | \ + (((x) & 0x00000000FF000000ULL) << 8) | \ + (((x) & 0x000000FF00000000ULL) >> 8) | \ + (((x) & 0x0000FF0000000000ULL) >> 24) | \ + (((x) & 0x00FF000000000000ULL) >> 40) | \ + (((x) & 0xFF00000000000000ULL) >> 56)) + +#endif /* CAML_INT64_NATIVE_H */ diff -Nru ocaml-4.01.0/byterun/caml/interp.h ocaml-4.02.3/byterun/caml/interp.h --- ocaml-4.01.0/byterun/caml/interp.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/interp.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,31 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* The bytecode interpreter */ + +#ifndef CAML_INTERP_H +#define CAML_INTERP_H + +#include "misc.h" +#include "mlvalues.h" + +/* interpret a bytecode */ +value caml_interprete (code_t prog, asize_t prog_size); + +/* tell the runtime that a bytecode program might be needed */ +void caml_prepare_bytecode(code_t prog, asize_t prog_size); + +/* tell the runtime that a bytecode program is no more needed */ +void caml_release_bytecode(code_t prog, asize_t prog_size); + +#endif /* CAML_INTERP_H */ diff -Nru ocaml-4.01.0/byterun/caml/intext.h ocaml-4.02.3/byterun/caml/intext.h --- ocaml-4.01.0/byterun/caml/intext.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/intext.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,168 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Structured input/output */ + +#ifndef CAML_INTEXT_H +#define CAML_INTEXT_H + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "misc.h" +#include "mlvalues.h" + +/* */ +#include "io.h" + +/* Magic number */ + +#define Intext_magic_number 0x8495A6BE + +/* Codes for the compact format */ + +#define PREFIX_SMALL_BLOCK 0x80 +#define PREFIX_SMALL_INT 0x40 +#define PREFIX_SMALL_STRING 0x20 +#define CODE_INT8 0x0 +#define CODE_INT16 0x1 +#define CODE_INT32 0x2 +#define CODE_INT64 0x3 +#define CODE_SHARED8 0x4 +#define CODE_SHARED16 0x5 +#define CODE_SHARED32 0x6 +#define CODE_BLOCK32 0x8 +#define CODE_BLOCK64 0x13 +#define CODE_STRING8 0x9 +#define CODE_STRING32 0xA +#define CODE_DOUBLE_BIG 0xB +#define CODE_DOUBLE_LITTLE 0xC +#define CODE_DOUBLE_ARRAY8_BIG 0xD +#define CODE_DOUBLE_ARRAY8_LITTLE 0xE +#define CODE_DOUBLE_ARRAY32_BIG 0xF +#define CODE_DOUBLE_ARRAY32_LITTLE 0x7 +#define CODE_CODEPOINTER 0x10 +#define CODE_INFIXPOINTER 0x11 +#define CODE_CUSTOM 0x12 + +#if ARCH_FLOAT_ENDIANNESS == 0x76543210 +#define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG +#define CODE_DOUBLE_ARRAY8_NATIVE CODE_DOUBLE_ARRAY8_BIG +#define CODE_DOUBLE_ARRAY32_NATIVE CODE_DOUBLE_ARRAY32_BIG +#else +#define CODE_DOUBLE_NATIVE CODE_DOUBLE_LITTLE +#define CODE_DOUBLE_ARRAY8_NATIVE CODE_DOUBLE_ARRAY8_LITTLE +#define CODE_DOUBLE_ARRAY32_NATIVE CODE_DOUBLE_ARRAY32_LITTLE +#endif + +/* Size-ing data structures for extern. Chosen so that + sizeof(struct trail_block) and sizeof(struct output_block) + are slightly below 8Kb. */ + +#define ENTRIES_PER_TRAIL_BLOCK 1025 +#define SIZE_EXTERN_OUTPUT_BLOCK 8100 + +/* The entry points */ + +void caml_output_val (struct channel * chan, value v, value flags); + /* Output [v] with flags [flags] on the channel [chan]. */ + +/* */ + +#ifdef __cplusplus +extern "C" { +#endif + +CAMLextern void caml_output_value_to_malloc(value v, value flags, + /*out*/ char ** buf, + /*out*/ intnat * len); + /* Output [v] with flags [flags] to a memory buffer allocated with + malloc. On return, [*buf] points to the buffer and [*len] + contains the number of bytes in buffer. */ +CAMLextern intnat caml_output_value_to_block(value v, value flags, + char * data, intnat len); + /* Output [v] with flags [flags] to a user-provided memory buffer. + [data] points to the start of this buffer, and [len] is its size + in bytes. Return the number of bytes actually written in buffer. + Raise [Failure] if buffer is too short. */ + +/* */ +value caml_input_val (struct channel * chan); + /* Read a structured value from the channel [chan]. */ +/* */ + +CAMLextern value caml_input_val_from_string (value str, intnat ofs); + /* Read a structured value from the OCaml string [str], starting + at offset [ofs]. */ +CAMLextern value caml_input_value_from_malloc(char * data, intnat ofs); + /* Read a structured value from a malloced buffer. [data] points + to the beginning of the buffer, and [ofs] is the offset of the + beginning of the externed data in this buffer. The buffer is + deallocated with [free] on return, or if an exception is raised. */ +CAMLextern value caml_input_value_from_block(char * data, intnat len); + /* Read a structured value from a user-provided buffer. [data] points + to the beginning of the externed data in this buffer, + and [len] is the length in bytes of valid data in this buffer. + The buffer is never deallocated by this routine. */ + +/* Functions for writing user-defined marshallers */ + +CAMLextern void caml_serialize_int_1(int i); +CAMLextern void caml_serialize_int_2(int i); +CAMLextern void caml_serialize_int_4(int32 i); +CAMLextern void caml_serialize_int_8(int64 i); +CAMLextern void caml_serialize_float_4(float f); +CAMLextern void caml_serialize_float_8(double f); +CAMLextern void caml_serialize_block_1(void * data, intnat len); +CAMLextern void caml_serialize_block_2(void * data, intnat len); +CAMLextern void caml_serialize_block_4(void * data, intnat len); +CAMLextern void caml_serialize_block_8(void * data, intnat len); +CAMLextern void caml_serialize_block_float_8(void * data, intnat len); + +CAMLextern int caml_deserialize_uint_1(void); +CAMLextern int caml_deserialize_sint_1(void); +CAMLextern int caml_deserialize_uint_2(void); +CAMLextern int caml_deserialize_sint_2(void); +CAMLextern uint32 caml_deserialize_uint_4(void); +CAMLextern int32 caml_deserialize_sint_4(void); +CAMLextern uint64 caml_deserialize_uint_8(void); +CAMLextern int64 caml_deserialize_sint_8(void); +CAMLextern float caml_deserialize_float_4(void); +CAMLextern double caml_deserialize_float_8(void); +CAMLextern void caml_deserialize_block_1(void * data, intnat len); +CAMLextern void caml_deserialize_block_2(void * data, intnat len); +CAMLextern void caml_deserialize_block_4(void * data, intnat len); +CAMLextern void caml_deserialize_block_8(void * data, intnat len); +CAMLextern void caml_deserialize_block_float_8(void * data, intnat len); +CAMLextern void caml_deserialize_error(char * msg); + +/* */ + +/* Auxiliary stuff for sending code pointers */ + +struct code_fragment { + char * code_start; + char * code_end; + unsigned char digest[16]; + char digest_computed; +}; + +struct ext_table caml_code_fragments_table; + +/* */ + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_INTEXT_H */ diff -Nru ocaml-4.01.0/byterun/caml/io.h ocaml-4.02.3/byterun/caml/io.h --- ocaml-4.01.0/byterun/caml/io.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/io.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,115 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Buffered input/output */ + +#ifndef CAML_IO_H +#define CAML_IO_H + +#include "misc.h" +#include "mlvalues.h" + +#ifndef IO_BUFFER_SIZE +#define IO_BUFFER_SIZE 65536 +#endif + +#if defined(_WIN32) +typedef __int64 file_offset; +#elif defined(HAS_OFF_T) +#include +typedef off_t file_offset; +#else +typedef long file_offset; +#endif + +struct channel { + int fd; /* Unix file descriptor */ + file_offset offset; /* Absolute position of fd in the file */ + char * end; /* Physical end of the buffer */ + char * curr; /* Current position in the buffer */ + char * max; /* Logical end of the buffer (for input) */ + void * mutex; /* Placeholder for mutex (for systhreads) */ + struct channel * next, * prev;/* Double chaining of channels (flush_all) */ + int revealed; /* For Cash only */ + int old_revealed; /* For Cash only */ + int refcount; /* For flush_all and for Cash */ + int flags; /* Bitfield */ + char buff[IO_BUFFER_SIZE]; /* The buffer itself */ +}; + +enum { + CHANNEL_FLAG_FROM_SOCKET = 1 /* For Windows */ +}; + +/* For an output channel: + [offset] is the absolute position of the beginning of the buffer [buff]. + For an input channel: + [offset] is the absolute position of the logical end of the buffer, [max]. +*/ + +/* Functions and macros that can be called from C. Take arguments of + type struct channel *. No locking is performed. */ + +#define putch(channel, ch) do{ \ + if ((channel)->curr >= (channel)->end) caml_flush_partial(channel); \ + *((channel)->curr)++ = (ch); \ +}while(0) + +#define getch(channel) \ + ((channel)->curr >= (channel)->max \ + ? caml_refill(channel) \ + : (unsigned char) *((channel)->curr)++) + +CAMLextern struct channel * caml_open_descriptor_in (int); +CAMLextern struct channel * caml_open_descriptor_out (int); +CAMLextern void caml_close_channel (struct channel *); +CAMLextern int caml_channel_binary_mode (struct channel *); +CAMLextern value caml_alloc_channel(struct channel *chan); + +CAMLextern int caml_flush_partial (struct channel *); +CAMLextern void caml_flush (struct channel *); +CAMLextern void caml_putword (struct channel *, uint32); +CAMLextern int caml_putblock (struct channel *, char *, intnat); +CAMLextern void caml_really_putblock (struct channel *, char *, intnat); + +CAMLextern unsigned char caml_refill (struct channel *); +CAMLextern uint32 caml_getword (struct channel *); +CAMLextern int caml_getblock (struct channel *, char *, intnat); +CAMLextern int caml_really_getblock (struct channel *, char *, intnat); + +/* Extract a struct channel * from the heap object representing it */ + +#define Channel(v) (*((struct channel **) (Data_custom_val(v)))) + +/* The locking machinery */ + +CAMLextern void (*caml_channel_mutex_free) (struct channel *); +CAMLextern void (*caml_channel_mutex_lock) (struct channel *); +CAMLextern void (*caml_channel_mutex_unlock) (struct channel *); +CAMLextern void (*caml_channel_mutex_unlock_exn) (void); + +CAMLextern struct channel * caml_all_opened_channels; + +#define Lock(channel) \ + if (caml_channel_mutex_lock != NULL) (*caml_channel_mutex_lock)(channel) +#define Unlock(channel) \ + if (caml_channel_mutex_unlock != NULL) (*caml_channel_mutex_unlock)(channel) +#define Unlock_exn() \ + if (caml_channel_mutex_unlock_exn != NULL) (*caml_channel_mutex_unlock_exn)() + +/* Conversion between file_offset and int64 */ + +#define Val_file_offset(fofs) caml_copy_int64(fofs) +#define File_offset_val(v) ((file_offset) Int64_val(v)) + +#endif /* CAML_IO_H */ diff -Nru ocaml-4.01.0/byterun/caml/major_gc.h ocaml-4.02.3/byterun/caml/major_gc.h --- ocaml-4.01.0/byterun/caml/major_gc.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/major_gc.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,60 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_MAJOR_GC_H +#define CAML_MAJOR_GC_H + + +#include "freelist.h" +#include "misc.h" + +typedef struct { + void *block; /* address of the malloced block this chunk live in */ + asize_t alloc; /* in bytes, used for compaction */ + asize_t size; /* in bytes */ + char *next; +} heap_chunk_head; + +#define Chunk_size(c) (((heap_chunk_head *) (c)) [-1]).size +#define Chunk_alloc(c) (((heap_chunk_head *) (c)) [-1]).alloc +#define Chunk_next(c) (((heap_chunk_head *) (c)) [-1]).next +#define Chunk_block(c) (((heap_chunk_head *) (c)) [-1]).block + +extern int caml_gc_phase; +extern int caml_gc_subphase; +extern uintnat caml_allocated_words; +extern double caml_extra_heap_resources; +extern uintnat caml_dependent_size, caml_dependent_allocated; +extern uintnat caml_fl_size_at_phase_change; + +#define Phase_mark 0 +#define Phase_sweep 1 +#define Phase_idle 2 +#define Subphase_main 10 +#define Subphase_weak1 11 +#define Subphase_weak2 12 +#define Subphase_final 13 + +CAMLextern char *caml_heap_start; +extern uintnat total_heap_size; +extern char *caml_gc_sweep_hp; + +void caml_init_major_heap (asize_t); /* size in bytes */ +asize_t caml_round_heap_chunk_size (asize_t); /* size in bytes */ +void caml_darken (value, value *); +intnat caml_major_collection_slice (intnat); +void major_collection (void); +void caml_finish_major_cycle (void); + + +#endif /* CAML_MAJOR_GC_H */ diff -Nru ocaml-4.01.0/byterun/caml/md5.h ocaml-4.02.3/byterun/caml/md5.h --- ocaml-4.01.0/byterun/caml/md5.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/md5.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,41 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1999 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* MD5 message digest */ + +#ifndef CAML_MD5_H +#define CAML_MD5_H + + +#include "mlvalues.h" +#include "io.h" + +CAMLextern value caml_md5_string (value str, value ofs, value len); +CAMLextern value caml_md5_chan (value vchan, value len); +CAMLextern void caml_md5_block(unsigned char digest[16], + void * data, uintnat len); + +struct MD5Context { + uint32 buf[4]; + uint32 bits[2]; + unsigned char in[64]; +}; + +CAMLextern void caml_MD5Init (struct MD5Context *context); +CAMLextern void caml_MD5Update (struct MD5Context *context, unsigned char *buf, + uintnat len); +CAMLextern void caml_MD5Final (unsigned char *digest, struct MD5Context *ctx); +CAMLextern void caml_MD5Transform (uint32 *buf, uint32 *in); + + +#endif /* CAML_MD5_H */ diff -Nru ocaml-4.01.0/byterun/caml/memory.h ocaml-4.02.3/byterun/caml/memory.h --- ocaml-4.01.0/byterun/caml/memory.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/memory.h 2015-06-04 21:59:00.000000000 +0200 @@ -0,0 +1,409 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Allocation macros and functions */ + +#ifndef CAML_MEMORY_H +#define CAML_MEMORY_H + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "config.h" +/* */ +#include "gc.h" +#include "major_gc.h" +#include "minor_gc.h" +/* */ +#include "misc.h" +#include "mlvalues.h" + +#ifdef __cplusplus +extern "C" { +#endif + + +CAMLextern value caml_alloc_shr (mlsize_t, tag_t); +CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t); +CAMLextern void caml_alloc_dependent_memory (mlsize_t); +CAMLextern void caml_free_dependent_memory (mlsize_t); +CAMLextern void caml_modify (value *, value); +CAMLextern void caml_initialize (value *, value); +CAMLextern value caml_check_urgent_gc (value); +CAMLextern void * caml_stat_alloc (asize_t); /* Size in bytes. */ +CAMLextern void caml_stat_free (void *); +CAMLextern void * caml_stat_resize (void *, asize_t); /* Size in bytes. */ +char *caml_alloc_for_heap (asize_t request); /* Size in bytes. */ +void caml_free_for_heap (char *mem); +int caml_add_to_heap (char *mem); +color_t caml_allocation_color (void *hp); + +/* void caml_shrink_heap (char *); Only used in compact.c */ + +/* */ + +#ifdef DEBUG +#define DEBUG_clear(result, wosize) do{ \ + uintnat caml__DEBUG_i; \ + for (caml__DEBUG_i = 0; caml__DEBUG_i < (wosize); ++ caml__DEBUG_i){ \ + Field ((result), caml__DEBUG_i) = Debug_uninit_minor; \ + } \ +}while(0) +#else +#define DEBUG_clear(result, wosize) +#endif + +#define Alloc_small(result, wosize, tag) do{ CAMLassert ((wosize) >= 1); \ + CAMLassert ((tag_t) (tag) < 256); \ + CAMLassert ((wosize) <= Max_young_wosize); \ + caml_young_ptr -= Bhsize_wosize (wosize); \ + if (caml_young_ptr < caml_young_start){ \ + caml_young_ptr += Bhsize_wosize (wosize); \ + Setup_for_gc; \ + caml_minor_collection (); \ + Restore_after_gc; \ + caml_young_ptr -= Bhsize_wosize (wosize); \ + } \ + Hd_hp (caml_young_ptr) = Make_header ((wosize), (tag), Caml_black); \ + (result) = Val_hp (caml_young_ptr); \ + DEBUG_clear ((result), (wosize)); \ +}while(0) + +/* Deprecated alias for [caml_modify] */ + +#define Modify(fp,val) caml_modify((fp), (val)) + +/* */ + +struct caml__roots_block { + struct caml__roots_block *next; + intnat ntables; + intnat nitems; + value *tables [5]; +}; + +CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ + +/* The following macros are used to declare C local variables and + function parameters of type [value]. + + The function body must start with one of the [CAMLparam] macros. + If the function has no parameter of type [value], use [CAMLparam0]. + If the function has 1 to 5 [value] parameters, use the corresponding + [CAMLparam] with the parameters as arguments. + If the function has more than 5 [value] parameters, use [CAMLparam5] + for the first 5 parameters, and one or more calls to the [CAMLxparam] + macros for the others. + If the function takes an array of [value]s as argument, use + [CAMLparamN] to declare it (or [CAMLxparamN] if you already have a + call to [CAMLparam] for some other arguments). + + If you need local variables of type [value], declare them with one + or more calls to the [CAMLlocal] macros at the beginning of the + function, after the call to CAMLparam. Use [CAMLlocalN] (at the + beginning of the function) to declare an array of [value]s. + + Your function may raise an exception or return a [value] with the + [CAMLreturn] macro. Its argument is simply the [value] returned by + your function. Do NOT directly return a [value] with the [return] + keyword. If your function returns void, use [CAMLreturn0]. + + All the identifiers beginning with "caml__" are reserved by OCaml. + Do not use them for anything (local or global variables, struct or + union tags, macros, etc.) +*/ + +#define CAMLparam0() \ + struct caml__roots_block *caml__frame = caml_local_roots + +#define CAMLparam1(x) \ + CAMLparam0 (); \ + CAMLxparam1 (x) + +#define CAMLparam2(x, y) \ + CAMLparam0 (); \ + CAMLxparam2 (x, y) + +#define CAMLparam3(x, y, z) \ + CAMLparam0 (); \ + CAMLxparam3 (x, y, z) + +#define CAMLparam4(x, y, z, t) \ + CAMLparam0 (); \ + CAMLxparam4 (x, y, z, t) + +#define CAMLparam5(x, y, z, t, u) \ + CAMLparam0 (); \ + CAMLxparam5 (x, y, z, t, u) + +#define CAMLparamN(x, size) \ + CAMLparam0 (); \ + CAMLxparamN (x, (size)) + + +#if defined(__GNUC__) && (__GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ > 7)) + #define CAMLunused __attribute__ ((unused)) +#else + #define CAMLunused +#endif + +#define CAMLxparam1(x) \ + struct caml__roots_block caml__roots_##x; \ + CAMLunused int caml__dummy_##x = ( \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = 1), \ + (caml__roots_##x.ntables = 1), \ + (caml__roots_##x.tables [0] = &x), \ + 0) + +#define CAMLxparam2(x, y) \ + struct caml__roots_block caml__roots_##x; \ + CAMLunused int caml__dummy_##x = ( \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = 1), \ + (caml__roots_##x.ntables = 2), \ + (caml__roots_##x.tables [0] = &x), \ + (caml__roots_##x.tables [1] = &y), \ + 0) + +#define CAMLxparam3(x, y, z) \ + struct caml__roots_block caml__roots_##x; \ + CAMLunused int caml__dummy_##x = ( \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = 1), \ + (caml__roots_##x.ntables = 3), \ + (caml__roots_##x.tables [0] = &x), \ + (caml__roots_##x.tables [1] = &y), \ + (caml__roots_##x.tables [2] = &z), \ + 0) + +#define CAMLxparam4(x, y, z, t) \ + struct caml__roots_block caml__roots_##x; \ + CAMLunused int caml__dummy_##x = ( \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = 1), \ + (caml__roots_##x.ntables = 4), \ + (caml__roots_##x.tables [0] = &x), \ + (caml__roots_##x.tables [1] = &y), \ + (caml__roots_##x.tables [2] = &z), \ + (caml__roots_##x.tables [3] = &t), \ + 0) + +#define CAMLxparam5(x, y, z, t, u) \ + struct caml__roots_block caml__roots_##x; \ + CAMLunused int caml__dummy_##x = ( \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = 1), \ + (caml__roots_##x.ntables = 5), \ + (caml__roots_##x.tables [0] = &x), \ + (caml__roots_##x.tables [1] = &y), \ + (caml__roots_##x.tables [2] = &z), \ + (caml__roots_##x.tables [3] = &t), \ + (caml__roots_##x.tables [4] = &u), \ + 0) + +#define CAMLxparamN(x, size) \ + struct caml__roots_block caml__roots_##x; \ + CAMLunused int caml__dummy_##x = ( \ + (caml__roots_##x.next = caml_local_roots), \ + (caml_local_roots = &caml__roots_##x), \ + (caml__roots_##x.nitems = (size)), \ + (caml__roots_##x.ntables = 1), \ + (caml__roots_##x.tables[0] = &(x[0])), \ + 0) + +#define CAMLlocal1(x) \ + value x = Val_unit; \ + CAMLxparam1 (x) + +#define CAMLlocal2(x, y) \ + value x = Val_unit, y = Val_unit; \ + CAMLxparam2 (x, y) + +#define CAMLlocal3(x, y, z) \ + value x = Val_unit, y = Val_unit, z = Val_unit; \ + CAMLxparam3 (x, y, z) + +#define CAMLlocal4(x, y, z, t) \ + value x = Val_unit, y = Val_unit, z = Val_unit, t = Val_unit; \ + CAMLxparam4 (x, y, z, t) + +#define CAMLlocal5(x, y, z, t, u) \ + value x = Val_unit, y = Val_unit, z = Val_unit, t = Val_unit, u = Val_unit; \ + CAMLxparam5 (x, y, z, t, u) + +#define CAMLlocalN(x, size) \ + value x [(size)]; \ + int caml__i_##x; \ + for (caml__i_##x = 0; caml__i_##x < size; caml__i_##x ++) { \ + x[caml__i_##x] = Val_unit; \ + } \ + CAMLxparamN (x, (size)) + + +#define CAMLreturn0 do{ \ + caml_local_roots = caml__frame; \ + return; \ +}while (0) + +#define CAMLreturnT(type, result) do{ \ + type caml__temp_result = (result); \ + caml_local_roots = caml__frame; \ + return (caml__temp_result); \ +}while(0) + +#define CAMLreturn(result) CAMLreturnT(value, result) + +#define CAMLnoreturn ((void) caml__frame) + + +/* convenience macro */ +#define Store_field(block, offset, val) do{ \ + mlsize_t caml__temp_offset = (offset); \ + value caml__temp_val = (val); \ + caml_modify (&Field ((block), caml__temp_offset), caml__temp_val); \ +}while(0) + +/* + NOTE: [Begin_roots] and [End_roots] are superseded by [CAMLparam]*, + [CAMLxparam]*, [CAMLlocal]*, [CAMLreturn]. + + [Begin_roots] and [End_roots] are used for C variables that are GC roots. + It must contain all values in C local variables and function parameters + at the time the minor GC is called. + Usage: + After initialising your local variables to legal OCaml values, but before + calling allocation functions, insert [Begin_roots_n(v1, ... vn)], where + v1 ... vn are your variables of type [value] that you want to be updated + across allocations. + At the end, insert [End_roots()]. + + Note that [Begin_roots] opens a new block, and [End_roots] closes it. + Thus they must occur in matching pairs at the same brace nesting level. + + You can use [Val_unit] as a dummy initial value for your variables. +*/ + +#define Begin_root Begin_roots1 + +#define Begin_roots1(r0) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = caml_local_roots; \ + caml_local_roots = &caml__roots_block; \ + caml__roots_block.nitems = 1; \ + caml__roots_block.ntables = 1; \ + caml__roots_block.tables[0] = &(r0); + +#define Begin_roots2(r0, r1) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = caml_local_roots; \ + caml_local_roots = &caml__roots_block; \ + caml__roots_block.nitems = 1; \ + caml__roots_block.ntables = 2; \ + caml__roots_block.tables[0] = &(r0); \ + caml__roots_block.tables[1] = &(r1); + +#define Begin_roots3(r0, r1, r2) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = caml_local_roots; \ + caml_local_roots = &caml__roots_block; \ + caml__roots_block.nitems = 1; \ + caml__roots_block.ntables = 3; \ + caml__roots_block.tables[0] = &(r0); \ + caml__roots_block.tables[1] = &(r1); \ + caml__roots_block.tables[2] = &(r2); + +#define Begin_roots4(r0, r1, r2, r3) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = caml_local_roots; \ + caml_local_roots = &caml__roots_block; \ + caml__roots_block.nitems = 1; \ + caml__roots_block.ntables = 4; \ + caml__roots_block.tables[0] = &(r0); \ + caml__roots_block.tables[1] = &(r1); \ + caml__roots_block.tables[2] = &(r2); \ + caml__roots_block.tables[3] = &(r3); + +#define Begin_roots5(r0, r1, r2, r3, r4) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = caml_local_roots; \ + caml_local_roots = &caml__roots_block; \ + caml__roots_block.nitems = 1; \ + caml__roots_block.ntables = 5; \ + caml__roots_block.tables[0] = &(r0); \ + caml__roots_block.tables[1] = &(r1); \ + caml__roots_block.tables[2] = &(r2); \ + caml__roots_block.tables[3] = &(r3); \ + caml__roots_block.tables[4] = &(r4); + +#define Begin_roots_block(table, size) { \ + struct caml__roots_block caml__roots_block; \ + caml__roots_block.next = caml_local_roots; \ + caml_local_roots = &caml__roots_block; \ + caml__roots_block.nitems = (size); \ + caml__roots_block.ntables = 1; \ + caml__roots_block.tables[0] = (table); + +#define End_roots() caml_local_roots = caml__roots_block.next; } + + +/* [caml_register_global_root] registers a global C variable as a memory root + for the duration of the program, or until [caml_remove_global_root] is + called. */ + +CAMLextern void caml_register_global_root (value *); + +/* [caml_remove_global_root] removes a memory root registered on a global C + variable with [caml_register_global_root]. */ + +CAMLextern void caml_remove_global_root (value *); + +/* [caml_register_generational_global_root] registers a global C + variable as a memory root for the duration of the program, or until + [caml_remove_generational_global_root] is called. + The program guarantees that the value contained in this variable + will not be assigned directly. If the program needs to change + the value of this variable, it must do so by calling + [caml_modify_generational_global_root]. The [value *] pointer + passed to [caml_register_generational_global_root] must contain + a valid OCaml value before the call. + In return for these constraints, scanning of memory roots during + minor collection is made more efficient. */ + +CAMLextern void caml_register_generational_global_root (value *); + +/* [caml_remove_generational_global_root] removes a memory root + registered on a global C variable with + [caml_register_generational_global_root]. */ + +CAMLextern void caml_remove_generational_global_root (value *); + +/* [caml_modify_generational_global_root(r, newval)] + modifies the value contained in [r], storing [newval] inside. + In other words, the assignment [*r = newval] is performed, + but in a way that is compatible with the optimized scanning of + generational global roots. [r] must be a global memory root + previously registered with [caml_register_generational_global_root]. */ + +CAMLextern void caml_modify_generational_global_root(value *r, value newval); + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_MEMORY_H */ diff -Nru ocaml-4.01.0/byterun/caml/minor_gc.h ocaml-4.02.3/byterun/caml/minor_gc.h --- ocaml-4.01.0/byterun/caml/minor_gc.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/minor_gc.h 2015-06-04 21:59:00.000000000 +0200 @@ -0,0 +1,52 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_MINOR_GC_H +#define CAML_MINOR_GC_H + + +#include "address_class.h" + +CAMLextern char *caml_young_start, *caml_young_ptr; +CAMLextern char *caml_young_end, *caml_young_limit; +extern asize_t caml_minor_heap_size; +extern int caml_in_minor_collection; + +struct caml_ref_table { + value **base; + value **end; + value **threshold; + value **ptr; + value **limit; + asize_t size; + asize_t reserve; +}; +CAMLextern struct caml_ref_table caml_ref_table, caml_weak_ref_table; + +extern void caml_set_minor_heap_size (asize_t); /* size in bytes */ +extern void caml_empty_minor_heap (void); +CAMLextern void caml_minor_collection (void); +CAMLextern void garbage_collection (void); /* def in asmrun/signals.c */ +extern void caml_realloc_ref_table (struct caml_ref_table *); +extern void caml_alloc_table (struct caml_ref_table *, asize_t, asize_t); +extern void caml_oldify_one (value, value *); +extern void caml_oldify_mopup (void); + +#define Oldify(p) do{ \ + value __oldify__v__ = *p; \ + if (Is_block (__oldify__v__) && Is_young (__oldify__v__)){ \ + caml_oldify_one (__oldify__v__, (p)); \ + } \ + }while(0) + +#endif /* CAML_MINOR_GC_H */ diff -Nru ocaml-4.01.0/byterun/caml/misc.h ocaml-4.02.3/byterun/caml/misc.h --- ocaml-4.01.0/byterun/caml/misc.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/misc.h 2015-07-20 16:46:48.000000000 +0200 @@ -0,0 +1,172 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Miscellaneous macros and variables. */ + +#ifndef CAML_MISC_H +#define CAML_MISC_H + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "config.h" + +/* Standard definitions */ + +#include +#include + +/* Basic types and constants */ + +typedef size_t asize_t; + +#ifndef NULL +#define NULL 0 +#endif + +/* */ +typedef char * addr; +/* */ + +#ifdef __GNUC__ + /* Works only in GCC 2.5 and later */ + #define Noreturn __attribute__ ((noreturn)) +#else + #define Noreturn +#endif + +/* Export control (to mark primitives and to handle Windows DLL) */ + +#define CAMLexport +#define CAMLprim +#define CAMLextern extern + +/* Weak function definitions that can be overriden by external libs */ +/* Conservatively restricted to ELF and MacOSX platforms */ +#if defined(__GNUC__) && (defined (__ELF__) || defined(__APPLE__)) +#define CAMLweakdef __attribute__((weak)) +#else +#define CAMLweakdef +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +/* GC timing hooks. These can be assigned by the user. + [caml_minor_gc_begin_hook] must not allocate nor change any heap value. + The others can allocate and even call back to OCaml code. +*/ +typedef void (*caml_timing_hook) (void); +extern caml_timing_hook caml_major_slice_begin_hook, caml_major_slice_end_hook; +extern caml_timing_hook caml_minor_gc_begin_hook, caml_minor_gc_end_hook; +extern caml_timing_hook caml_finalise_begin_hook, caml_finalise_end_hook; + +/* Assertions */ + +#ifdef DEBUG +#define CAMLassert(x) \ + ((x) ? (void) 0 : caml_failed_assert ( #x , __FILE__, __LINE__)) +CAMLextern int caml_failed_assert (char *, char *, int); +#else +#define CAMLassert(x) ((void) 0) +#endif + +CAMLextern void caml_fatal_error (char *msg) Noreturn; +CAMLextern void caml_fatal_error_arg (char *fmt, char *arg) Noreturn; +CAMLextern void caml_fatal_error_arg2 (char *fmt1, char *arg1, + char *fmt2, char *arg2) Noreturn; + +/* Safe string operations */ + +CAMLextern char * caml_strdup(const char * s); +CAMLextern char * caml_strconcat(int n, ...); /* n args of const char * type */ + +/* */ + +/* Data structures */ + +struct ext_table { + int size; + int capacity; + void ** contents; +}; + +extern void caml_ext_table_init(struct ext_table * tbl, int init_capa); +extern int caml_ext_table_add(struct ext_table * tbl, void * data); +extern void caml_ext_table_free(struct ext_table * tbl, int free_entries); + +/* GC flags and messages */ + +extern uintnat caml_verb_gc; +void caml_gc_message (int, char *, uintnat); + +/* Memory routines */ + +char *caml_aligned_malloc (asize_t, int, void **); + +#ifdef DEBUG +#ifdef ARCH_SIXTYFOUR +#define Debug_tag(x) (0xD700D7D7D700D6D7ul \ + | ((uintnat) (x) << 16) \ + | ((uintnat) (x) << 48)) +#else +#define Debug_tag(x) (0xD700D6D7ul | ((uintnat) (x) << 16)) +#endif /* ARCH_SIXTYFOUR */ + +/* + 00 -> free words in minor heap + 01 -> fields of free list blocks in major heap + 03 -> heap chunks deallocated by heap shrinking + 04 -> fields deallocated by [caml_obj_truncate] + 10 -> uninitialised fields of minor objects + 11 -> uninitialised fields of major objects + 15 -> uninitialised words of [caml_aligned_malloc] blocks + 85 -> filler bytes of [caml_aligned_malloc] + + special case (byte by byte): + D7 -> uninitialised words of [caml_stat_alloc] blocks +*/ +#define Debug_free_minor Debug_tag (0x00) +#define Debug_free_major Debug_tag (0x01) +#define Debug_free_shrink Debug_tag (0x03) +#define Debug_free_truncate Debug_tag (0x04) +#define Debug_uninit_minor Debug_tag (0x10) +#define Debug_uninit_major Debug_tag (0x11) +#define Debug_uninit_align Debug_tag (0x15) +#define Debug_filler_align Debug_tag (0x85) + +#define Debug_uninit_stat 0xD7 + +extern void caml_set_fields (char *, unsigned long, unsigned long); +#endif /* DEBUG */ + + +#ifndef CAML_AVOID_CONFLICTS +#define Assert CAMLassert +#endif + +/* snprintf emulation for Win32 */ + +#ifdef _WIN32 +extern int caml_snprintf(char * buf, size_t size, const char * format, ...); +#define snprintf caml_snprintf +#endif + +/* */ + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_MISC_H */ diff -Nru ocaml-4.01.0/byterun/caml/mlvalues.h ocaml-4.02.3/byterun/caml/mlvalues.h --- ocaml-4.01.0/byterun/caml/mlvalues.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/mlvalues.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,305 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_MLVALUES_H +#define CAML_MLVALUES_H + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "config.h" +#include "misc.h" + +#ifdef __cplusplus +extern "C" { +#endif + +/* Definitions + + word: Four bytes on 32 and 16 bit architectures, + eight bytes on 64 bit architectures. + long: A C integer having the same number of bytes as a word. + val: The ML representation of something. A long or a block or a pointer + outside the heap. If it is a block, it is the (encoded) address + of an object. If it is a long, it is encoded as well. + block: Something allocated. It always has a header and some + fields or some number of bytes (a multiple of the word size). + field: A word-sized val which is part of a block. + bp: Pointer to the first byte of a block. (a char *) + op: Pointer to the first field of a block. (a value *) + hp: Pointer to the header of a block. (a char *) + int32: Four bytes on all architectures. + int64: Eight bytes on all architectures. + + Remark: A block size is always a multiple of the word size, and at least + one word plus the header. + + bosize: Size (in bytes) of the "bytes" part. + wosize: Size (in words) of the "fields" part. + bhsize: Size (in bytes) of the block with its header. + whsize: Size (in words) of the block with its header. + + hd: A header. + tag: The value of the tag field of the header. + color: The value of the color field of the header. + This is for use only by the GC. +*/ + +typedef intnat value; +typedef uintnat header_t; +typedef uintnat mlsize_t; +typedef unsigned int tag_t; /* Actually, an unsigned char */ +typedef uintnat color_t; +typedef uintnat mark_t; + +/* Longs vs blocks. */ +#define Is_long(x) (((x) & 1) != 0) +#define Is_block(x) (((x) & 1) == 0) + +/* Conversion macro names are always of the form "to_from". */ +/* Example: Val_long as in "Val from long" or "Val of long". */ +#define Val_long(x) (((intnat)(x) << 1) + 1) +#define Long_val(x) ((x) >> 1) +#define Max_long (((intnat)1 << (8 * sizeof(value) - 2)) - 1) +#define Min_long (-((intnat)1 << (8 * sizeof(value) - 2))) +#define Val_int(x) Val_long(x) +#define Int_val(x) ((int) Long_val(x)) +#define Unsigned_long_val(x) ((uintnat)(x) >> 1) +#define Unsigned_int_val(x) ((int) Unsigned_long_val(x)) + +/* Structure of the header: + +For 16-bit and 32-bit architectures: + +--------+-------+-----+ + | wosize | color | tag | + +--------+-------+-----+ +bits 31 10 9 8 7 0 + +For 64-bit architectures: + + +--------+-------+-----+ + | wosize | color | tag | + +--------+-------+-----+ +bits 63 10 9 8 7 0 + +*/ + +#define Tag_hd(hd) ((tag_t) ((hd) & 0xFF)) +#define Wosize_hd(hd) ((mlsize_t) ((hd) >> 10)) + +#define Hd_val(val) (((header_t *) (val)) [-1]) /* Also an l-value. */ +#define Hd_op(op) (Hd_val (op)) /* Also an l-value. */ +#define Hd_bp(bp) (Hd_val (bp)) /* Also an l-value. */ +#define Hd_hp(hp) (* ((header_t *) (hp))) /* Also an l-value. */ +#define Hp_val(val) ((char *) (((header_t *) (val)) - 1)) +#define Hp_op(op) (Hp_val (op)) +#define Hp_bp(bp) (Hp_val (bp)) +#define Val_op(op) ((value) (op)) +#define Val_hp(hp) ((value) (((header_t *) (hp)) + 1)) +#define Op_hp(hp) ((value *) Val_hp (hp)) +#define Bp_hp(hp) ((char *) Val_hp (hp)) + +#define Num_tags (1 << 8) +#ifdef ARCH_SIXTYFOUR +#define Max_wosize (((intnat)1 << 54) - 1) +#else +#define Max_wosize ((1 << 22) - 1) +#endif + +#define Wosize_val(val) (Wosize_hd (Hd_val (val))) +#define Wosize_op(op) (Wosize_val (op)) +#define Wosize_bp(bp) (Wosize_val (bp)) +#define Wosize_hp(hp) (Wosize_hd (Hd_hp (hp))) +#define Whsize_wosize(sz) ((sz) + 1) +#define Wosize_whsize(sz) ((sz) - 1) +#define Wosize_bhsize(sz) ((sz) / sizeof (value) - 1) +#define Bsize_wsize(sz) ((sz) * sizeof (value)) +#define Wsize_bsize(sz) ((sz) / sizeof (value)) +#define Bhsize_wosize(sz) (Bsize_wsize (Whsize_wosize (sz))) +#define Bhsize_bosize(sz) ((sz) + sizeof (header_t)) +#define Bosize_val(val) (Bsize_wsize (Wosize_val (val))) +#define Bosize_op(op) (Bosize_val (Val_op (op))) +#define Bosize_bp(bp) (Bosize_val (Val_bp (bp))) +#define Bosize_hd(hd) (Bsize_wsize (Wosize_hd (hd))) +#define Whsize_hp(hp) (Whsize_wosize (Wosize_hp (hp))) +#define Whsize_val(val) (Whsize_hp (Hp_val (val))) +#define Whsize_bp(bp) (Whsize_val (Val_bp (bp))) +#define Whsize_hd(hd) (Whsize_wosize (Wosize_hd (hd))) +#define Bhsize_hp(hp) (Bsize_wsize (Whsize_hp (hp))) +#define Bhsize_hd(hd) (Bsize_wsize (Whsize_hd (hd))) + +#ifdef ARCH_BIG_ENDIAN +#define Tag_val(val) (((unsigned char *) (val)) [-1]) + /* Also an l-value. */ +#define Tag_hp(hp) (((unsigned char *) (hp)) [sizeof(value)-1]) + /* Also an l-value. */ +#else +#define Tag_val(val) (((unsigned char *) (val)) [-sizeof(value)]) + /* Also an l-value. */ +#define Tag_hp(hp) (((unsigned char *) (hp)) [0]) + /* Also an l-value. */ +#endif + +/* The lowest tag for blocks containing no value. */ +#define No_scan_tag 251 + + +/* 1- If tag < No_scan_tag : a tuple of fields. */ + +/* Pointer to the first field. */ +#define Op_val(x) ((value *) (x)) +/* Fields are numbered from 0. */ +#define Field(x, i) (((value *)(x)) [i]) /* Also an l-value. */ + +typedef int32 opcode_t; +typedef opcode_t * code_t; + +/* NOTE: [Forward_tag] and [Infix_tag] must be just under + [No_scan_tag], with [Infix_tag] the lower one. + See [caml_oldify_one] in minor_gc.c for more details. + + NOTE: Update stdlib/obj.ml whenever you change the tags. + */ + +/* Forward_tag: forwarding pointer that the GC may silently shortcut. + See stdlib/lazy.ml. */ +#define Forward_tag 250 +#define Forward_val(v) Field(v, 0) + +/* If tag == Infix_tag : an infix header inside a closure */ +/* Infix_tag must be odd so that the infix header is scanned as an integer */ +/* Infix_tag must be 1 modulo 4 and infix headers can only occur in blocks + with tag Closure_tag (see compact.c). */ + +#define Infix_tag 249 +#define Infix_offset_hd(hd) (Bosize_hd(hd)) +#define Infix_offset_val(v) Infix_offset_hd(Hd_val(v)) + +/* Another special case: objects */ +#define Object_tag 248 +#define Class_val(val) Field((val), 0) +#define Oid_val(val) Long_val(Field((val), 1)) +CAMLextern value caml_get_public_method (value obj, value tag); +/* Called as: + caml_callback(caml_get_public_method(obj, caml_hash_variant(name)), obj) */ +/* caml_get_public_method returns 0 if tag not in the table. + Note however that tags being hashed, same tag does not necessarily mean + same method name. */ + +/* Special case of tuples of fields: closures */ +#define Closure_tag 247 +#define Code_val(val) (((code_t *) (val)) [0]) /* Also an l-value. */ + +/* This tag is used (with Forward_tag) to implement lazy values. + See major_gc.c and stdlib/lazy.ml. */ +#define Lazy_tag 246 + +/* Another special case: variants */ +CAMLextern value caml_hash_variant(char const * tag); + +/* 2- If tag >= No_scan_tag : a sequence of bytes. */ + +/* Pointer to the first byte */ +#define Bp_val(v) ((char *) (v)) +#define Val_bp(p) ((value) (p)) +/* Bytes are numbered from 0. */ +#define Byte(x, i) (((char *) (x)) [i]) /* Also an l-value. */ +#define Byte_u(x, i) (((unsigned char *) (x)) [i]) /* Also an l-value. */ + +/* Abstract things. Their contents is not traced by the GC; therefore they + must not contain any [value]. +*/ +#define Abstract_tag 251 + +/* Strings. */ +#define String_tag 252 +#define String_val(x) ((char *) Bp_val(x)) +CAMLextern mlsize_t caml_string_length (value); /* size in bytes */ + +/* Floating-point numbers. */ +#define Double_tag 253 +#define Double_wosize ((sizeof(double) / sizeof(value))) +#ifndef ARCH_ALIGN_DOUBLE +#define Double_val(v) (* (double *)(v)) +#define Store_double_val(v,d) (* (double *)(v) = (d)) +#else +CAMLextern double caml_Double_val (value); +CAMLextern void caml_Store_double_val (value,double); +#define Double_val(v) caml_Double_val(v) +#define Store_double_val(v,d) caml_Store_double_val(v,d) +#endif + +/* Arrays of floating-point numbers. */ +#define Double_array_tag 254 +#define Double_field(v,i) Double_val((value)((double *)(v) + (i))) +#define Store_double_field(v,i,d) do{ \ + mlsize_t caml__temp_i = (i); \ + double caml__temp_d = (d); \ + Store_double_val((value)((double *) (v) + caml__temp_i), caml__temp_d); \ +}while(0) +CAMLextern mlsize_t caml_array_length (value); /* size in items */ +CAMLextern int caml_is_double_array (value); /* 0 is false, 1 is true */ + + +/* Custom blocks. They contain a pointer to a "method suite" + of functions (for finalization, comparison, hashing, etc) + followed by raw data. The contents of custom blocks is not traced by + the GC; therefore, they must not contain any [value]. + See [custom.h] for operations on method suites. */ +#define Custom_tag 255 +#define Data_custom_val(v) ((void *) &Field((v), 1)) +struct custom_operations; /* defined in [custom.h] */ + +/* Int32.t, Int64.t and Nativeint.t are represented as custom blocks. */ + +#define Int32_val(v) (*((int32 *) Data_custom_val(v))) +#define Nativeint_val(v) (*((intnat *) Data_custom_val(v))) +#ifndef ARCH_ALIGN_INT64 +#define Int64_val(v) (*((int64 *) Data_custom_val(v))) +#else +CAMLextern int64 caml_Int64_val(value v); +#define Int64_val(v) caml_Int64_val(v) +#endif + +/* 3- Atoms are 0-tuples. They are statically allocated once and for all. */ + +CAMLextern header_t caml_atom_table[]; +#define Atom(tag) (Val_hp (&(caml_atom_table [(tag)]))) + +/* Booleans are integers 0 or 1 */ + +#define Val_bool(x) Val_int((x) != 0) +#define Bool_val(x) Int_val(x) +#define Val_false Val_int(0) +#define Val_true Val_int(1) +#define Val_not(x) (Val_false + Val_true - (x)) + +/* The unit value is 0 (tagged) */ + +#define Val_unit Val_int(0) + +/* List constructors */ +#define Val_emptylist Val_int(0) +#define Tag_cons 0 + +/* The table of global identifiers */ + +extern value caml_global_data; + +CAMLextern value caml_set_oo_id(value obj); + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_MLVALUES_H */ diff -Nru ocaml-4.01.0/byterun/caml/osdeps.h ocaml-4.02.3/byterun/caml/osdeps.h --- ocaml-4.01.0/byterun/caml/osdeps.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/osdeps.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,68 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2001 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Operating system - specific stuff */ + +#ifndef CAML_OSDEPS_H +#define CAML_OSDEPS_H + +#include "misc.h" + +/* Decompose the given path into a list of directories, and add them + to the given table. Return the block to be freed later. */ +extern char * caml_decompose_path(struct ext_table * tbl, char * path); + +/* Search the given file in the given list of directories. + If not found, return a copy of [name]. Result is allocated with + [caml_stat_alloc]. */ +extern char * caml_search_in_path(struct ext_table * path, char * name); + +/* Same, but search an executable name in the system path for executables. */ +CAMLextern char * caml_search_exe_in_path(char * name); + +/* Same, but search a shared library in the given path. */ +extern char * caml_search_dll_in_path(struct ext_table * path, char * name); + +/* Open a shared library and return a handle on it. + If [for_execution] is true, perform full symbol resolution and + execute initialization code so that functions from the shared library + can be called. If [for_execution] is false, functions from this + shared library will not be called, but just checked for presence, + so symbol resolution can be skipped. + If [global] is true, symbols from the shared library can be used + to resolve for other libraries to be opened later on. + Return [NULL] on error. */ +extern void * caml_dlopen(char * libname, int for_execution, int global); + +/* Close a shared library handle */ +extern void caml_dlclose(void * handle); + +/* Look up the given symbol in the given shared library. + Return [NULL] if not found, or symbol value if found. */ +extern void * caml_dlsym(void * handle, char * name); + +extern void * caml_globalsym(char * name); + +/* Return an error message describing the most recent dynlink failure. */ +extern char * caml_dlerror(void); + +/* Add to [contents] the (short) names of the files contained in + the directory named [dirname]. No entries are added for [.] and [..]. + Return 0 on success, -1 on error; set errno in the case of error. */ +extern int caml_read_directory(char * dirname, struct ext_table * contents); + +/* Recover executable name if possible (/proc/sef/exe under Linux, + GetModuleFileName under Windows). */ +extern int caml_executable_name(char * name, int name_len); + +#endif /* CAML_OSDEPS_H */ diff -Nru ocaml-4.01.0/byterun/caml/prims.h ocaml-4.02.3/byterun/caml/prims.h --- ocaml-4.01.0/byterun/caml/prims.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/prims.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,34 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Interface with C primitives. */ + +#ifndef CAML_PRIMS_H +#define CAML_PRIMS_H + +typedef value (*c_primitive)(); + +extern c_primitive caml_builtin_cprim[]; +extern char * caml_names_of_builtin_cprim[]; + +extern struct ext_table caml_prim_table; +#ifdef DEBUG +extern struct ext_table caml_prim_name_table; +#endif + +#define Primitive(n) ((c_primitive)(caml_prim_table.contents[n])) + +extern char * caml_section_table; +extern asize_t caml_section_table_size; + +#endif /* CAML_PRIMS_H */ diff -Nru ocaml-4.01.0/byterun/caml/printexc.h ocaml-4.02.3/byterun/caml/printexc.h --- ocaml-4.01.0/byterun/caml/printexc.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/printexc.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,33 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2001 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_PRINTEXC_H +#define CAML_PRINTEXC_H + + +#include "misc.h" +#include "mlvalues.h" + +#ifdef __cplusplus +extern "C" { +#endif + + +CAMLextern char * caml_format_exception (value); +void caml_fatal_uncaught_exception (value) Noreturn; + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_PRINTEXC_H */ diff -Nru ocaml-4.01.0/byterun/caml/reverse.h ocaml-4.02.3/byterun/caml/reverse.h --- ocaml-4.01.0/byterun/caml/reverse.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/reverse.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,86 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Swap byte-order in 16, 32, and 64-bit integers or floats */ + +#ifndef CAML_REVERSE_H +#define CAML_REVERSE_H + +#define Reverse_16(dst,src) { \ + char * _p, * _q; \ + char _a; \ + _p = (char *) (src); \ + _q = (char *) (dst); \ + _a = _p[0]; \ + _q[0] = _p[1]; \ + _q[1] = _a; \ +} + +#define Reverse_32(dst,src) { \ + char * _p, * _q; \ + char _a, _b; \ + _p = (char *) (src); \ + _q = (char *) (dst); \ + _a = _p[0]; \ + _b = _p[1]; \ + _q[0] = _p[3]; \ + _q[1] = _p[2]; \ + _q[3] = _a; \ + _q[2] = _b; \ +} + +#define Reverse_64(dst,src) { \ + char * _p, * _q; \ + char _a, _b; \ + _p = (char *) (src); \ + _q = (char *) (dst); \ + _a = _p[0]; \ + _b = _p[1]; \ + _q[0] = _p[7]; \ + _q[1] = _p[6]; \ + _q[7] = _a; \ + _q[6] = _b; \ + _a = _p[2]; \ + _b = _p[3]; \ + _q[2] = _p[5]; \ + _q[3] = _p[4]; \ + _q[5] = _a; \ + _q[4] = _b; \ +} + +#define Perm_index(perm,i) ((perm >> (i * 4)) & 0xF) + +#define Permute_64(dst,perm_dst,src,perm_src) { \ + char * _p; \ + char _a, _b, _c, _d, _e, _f, _g, _h; \ + _p = (char *) (src); \ + _a = _p[Perm_index(perm_src, 0)]; \ + _b = _p[Perm_index(perm_src, 1)]; \ + _c = _p[Perm_index(perm_src, 2)]; \ + _d = _p[Perm_index(perm_src, 3)]; \ + _e = _p[Perm_index(perm_src, 4)]; \ + _f = _p[Perm_index(perm_src, 5)]; \ + _g = _p[Perm_index(perm_src, 6)]; \ + _h = _p[Perm_index(perm_src, 7)]; \ + _p = (char *) (dst); \ + _p[Perm_index(perm_dst, 0)] = _a; \ + _p[Perm_index(perm_dst, 1)] = _b; \ + _p[Perm_index(perm_dst, 2)] = _c; \ + _p[Perm_index(perm_dst, 3)] = _d; \ + _p[Perm_index(perm_dst, 4)] = _e; \ + _p[Perm_index(perm_dst, 5)] = _f; \ + _p[Perm_index(perm_dst, 6)] = _g; \ + _p[Perm_index(perm_dst, 7)] = _h; \ +} + +#endif /* CAML_REVERSE_H */ diff -Nru ocaml-4.01.0/byterun/caml/roots.h ocaml-4.02.3/byterun/caml/roots.h --- ocaml-4.01.0/byterun/caml/roots.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/roots.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,36 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_ROOTS_H +#define CAML_ROOTS_H + +#include "misc.h" +#include "memory.h" + +typedef void (*scanning_action) (value, value *); + +void caml_oldify_local_roots (void); +void caml_darken_all_roots (void); +void caml_do_roots (scanning_action); +#ifndef NATIVE_CODE +CAMLextern void caml_do_local_roots (scanning_action, value *, value *, + struct caml__roots_block *); +#else +CAMLextern void caml_do_local_roots(scanning_action f, char * bottom_of_stack, + uintnat last_retaddr, value * gc_regs, + struct caml__roots_block * local_roots); +#endif + +CAMLextern void (*caml_scan_roots_hook) (scanning_action); + +#endif /* CAML_ROOTS_H */ diff -Nru ocaml-4.01.0/byterun/caml/signals.h ocaml-4.02.3/byterun/caml/signals.h --- ocaml-4.01.0/byterun/caml/signals.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/signals.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,57 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_SIGNALS_H +#define CAML_SIGNALS_H + +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif +#include "misc.h" +#include "mlvalues.h" + +#ifdef __cplusplus +extern "C" { +#endif + +/* */ +CAMLextern intnat volatile caml_signals_are_pending; +CAMLextern intnat volatile caml_pending_signals[]; +CAMLextern int volatile caml_something_to_do; +extern int volatile caml_force_major_slice; +/* */ + +CAMLextern void caml_enter_blocking_section (void); +CAMLextern void caml_leave_blocking_section (void); + +/* */ +void caml_urge_major_slice (void); +CAMLextern int caml_convert_signal_number (int); +CAMLextern int caml_rev_convert_signal_number (int); +void caml_execute_signal(int signal_number, int in_signal_handler); +void caml_record_signal(int signal_number); +void caml_process_pending_signals(void); +void caml_process_event(void); +int caml_set_signal_action(int signo, int action); + +CAMLextern void (*caml_enter_blocking_section_hook)(void); +CAMLextern void (*caml_leave_blocking_section_hook)(void); +CAMLextern int (*caml_try_leave_blocking_section_hook)(void); +CAMLextern void (* volatile caml_async_action_hook)(void); +/* */ + +#ifdef __cplusplus +} +#endif + +#endif /* CAML_SIGNALS_H */ diff -Nru ocaml-4.01.0/byterun/caml/signals_machdep.h ocaml-4.02.3/byterun/caml/signals_machdep.h --- ocaml-4.01.0/byterun/caml/signals_machdep.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/signals_machdep.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,60 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Processor-specific operation: atomic "read and clear" */ + +#ifndef CAML_SIGNALS_MACHDEP_H +#define CAML_SIGNALS_MACHDEP_H + +#if defined(__GNUC__) && defined(__i386__) + +#define Read_and_clear(dst,src) \ + asm("xorl %0, %0; xchgl %0, %1" \ + : "=r" (dst), "=m" (src) \ + : "m" (src)) + +#elif defined(__GNUC__) && defined(__x86_64__) + +#define Read_and_clear(dst,src) \ + asm("xorq %0, %0; xchgq %0, %1" \ + : "=r" (dst), "=m" (src) \ + : "m" (src)) + +#elif defined(__GNUC__) && defined(__ppc__) + +#define Read_and_clear(dst,src) \ + asm("0: lwarx %0, 0, %1\n\t" \ + "stwcx. %2, 0, %1\n\t" \ + "bne- 0b" \ + : "=&r" (dst) \ + : "r" (&(src)), "r" (0) \ + : "cr0", "memory") + +#elif defined(__GNUC__) && defined(__ppc64__) + +#define Read_and_clear(dst,src) \ + asm("0: ldarx %0, 0, %1\n\t" \ + "stdcx. %2, 0, %1\n\t" \ + "bne- 0b" \ + : "=&r" (dst) \ + : "r" (&(src)), "r" (0) \ + : "cr0", "memory") + +#else + +/* Default, non-atomic implementation */ +#define Read_and_clear(dst,src) ((dst) = (src), (src) = 0) + +#endif + +#endif /* CAML_SIGNALS_MACHDEP_H */ diff -Nru ocaml-4.01.0/byterun/caml/stacks.h ocaml-4.02.3/byterun/caml/stacks.h --- ocaml-4.01.0/byterun/caml/stacks.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/stacks.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,41 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* structure of the stacks */ + +#ifndef CAML_STACKS_H +#define CAML_STACKS_H + + +#include "misc.h" +#include "mlvalues.h" +#include "memory.h" + +CAMLextern value * caml_stack_low; +CAMLextern value * caml_stack_high; +CAMLextern value * caml_stack_threshold; +CAMLextern value * caml_extern_sp; +CAMLextern value * caml_trapsp; +CAMLextern value * caml_trap_barrier; + +#define Trap_pc(tp) (((code_t *)(tp))[0]) +#define Trap_link(tp) (((value **)(tp))[1]) + +void caml_init_stack (uintnat init_max_size); +void caml_realloc_stack (asize_t required_size); +void caml_change_max_stack_size (uintnat new_max_size); +uintnat caml_stack_usage (void); + +CAMLextern uintnat (*caml_stack_usage_hook)(void); + +#endif /* CAML_STACKS_H */ diff -Nru ocaml-4.01.0/byterun/caml/startup.h ocaml-4.02.3/byterun/caml/startup.h --- ocaml-4.01.0/byterun/caml/startup.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/startup.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,38 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2001 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_STARTUP_H +#define CAML_STARTUP_H + +#include "mlvalues.h" +#include "exec.h" + +CAMLextern void caml_main(char **argv); + +CAMLextern void caml_startup_code( + code_t code, asize_t code_size, + char *data, asize_t data_size, + char *section_table, asize_t section_table_size, + char **argv); + +enum { FILE_NOT_FOUND = -1, BAD_BYTECODE = -2 }; + +extern int caml_attempt_open(char **name, struct exec_trailer *trail, + int do_open_script); +extern void caml_read_section_descriptors(int fd, struct exec_trailer *trail); +extern int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, + char *name); +extern int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name); + + +#endif /* CAML_STARTUP_H */ diff -Nru ocaml-4.01.0/byterun/caml/sys.h ocaml-4.02.3/byterun/caml/sys.h --- ocaml-4.01.0/byterun/caml/sys.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/sys.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,28 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +#ifndef CAML_SYS_H +#define CAML_SYS_H + +#include "misc.h" + +#define NO_ARG Val_int(0) + +CAMLextern void caml_sys_error (value); +CAMLextern void caml_sys_io_error (value); +extern void caml_sys_init (char * exe_name, char ** argv); +CAMLextern value caml_sys_exit (value); + +extern char * caml_exe_name; + +#endif /* CAML_SYS_H */ diff -Nru ocaml-4.01.0/byterun/caml/ui.h ocaml-4.02.3/byterun/caml/ui.h --- ocaml-4.01.0/byterun/caml/ui.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/ui.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,26 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Function declarations for non-Unix user interfaces */ + +#ifndef CAML_UI_H +#define CAML_UI_H + +#include "config.h" + +void ui_exit (int return_code); +int ui_read (int file_desc, char *buf, unsigned int length); +int ui_write (int file_desc, char *buf, unsigned int length); +void ui_print_stderr (char *format, void *arg); + +#endif /* CAML_UI_H */ diff -Nru ocaml-4.01.0/byterun/caml/weak.h ocaml-4.02.3/byterun/caml/weak.h --- ocaml-4.01.0/byterun/caml/weak.h 1970-01-01 01:00:00.000000000 +0100 +++ ocaml-4.02.3/byterun/caml/weak.h 2015-04-12 11:03:05.000000000 +0200 @@ -0,0 +1,24 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Damien Doligez, projet Para, INRIA Rocquencourt */ +/* */ +/* Copyright 1997 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* Operations on weak arrays */ + +#ifndef CAML_WEAK_H +#define CAML_WEAK_H + +#include "mlvalues.h" + +extern value caml_weak_list_head; +extern value caml_weak_none; + +#endif /* CAML_WEAK_H */ diff -Nru ocaml-4.01.0/byterun/compact.c ocaml-4.02.3/byterun/compact.c --- ocaml-4.01.0/byterun/compact.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/compact.c 2015-06-04 21:59:00.000000000 +0200 @@ -13,16 +13,17 @@ #include -#include "config.h" -#include "finalise.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "major_gc.h" -#include "memory.h" -#include "mlvalues.h" -#include "roots.h" -#include "weak.h" +#include "caml/address_class.h" +#include "caml/config.h" +#include "caml/finalise.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/weak.h" extern uintnat caml_percent_free; /* major_gc.c */ extern void caml_shrink_heap (char *); /* memory.c */ @@ -40,7 +41,7 @@ XXX Should be fixed: XXX The above assumes that all roots are aligned on a 4-byte boundary, XXX which is not always guaranteed by C. - XXX (see [caml_register_global_roots] and [caml_init_exceptions]) + XXX (see [caml_register_global_roots]) XXX Should be able to fix it to only assume 2-byte alignment. */ #define Make_ehd(s,t,c) (((s) << 10) | (t) << 2 | (c)) @@ -58,7 +59,7 @@ /* Use Ecolor (q) == 0 instead of Is_block (q) because q could be an inverted pointer for an infix header (with Ecolor == 2). */ - if (Ecolor (q) == 0 && (Classify_addr (q) & In_heap)){ + if (Ecolor (q) == 0 && Is_in_heap (q)){ switch (Ecolor (Hd_val (q))){ case 0: case 3: /* Pointer or header: insert in inverted list. */ diff -Nru ocaml-4.01.0/byterun/compact.h ocaml-4.02.3/byterun/compact.h --- ocaml-4.01.0/byterun/compact.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/compact.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,25 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_COMPACT_H -#define CAML_COMPACT_H - - -#include "config.h" -#include "misc.h" - -extern void caml_compact_heap (void); -extern void caml_compact_heap_maybe (void); - - -#endif /* CAML_COMPACT_H */ diff -Nru ocaml-4.01.0/byterun/compare.c ocaml-4.02.3/byterun/compare.c --- ocaml-4.01.0/byterun/compare.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/compare.c 2015-04-12 11:03:39.000000000 +0200 @@ -13,11 +13,11 @@ #include #include -#include "custom.h" -#include "fail.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" /* Structural comparison on trees. */ diff -Nru ocaml-4.01.0/byterun/compare.h ocaml-4.02.3/byterun/compare.h --- ocaml-4.01.0/byterun/compare.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/compare.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,19 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, Projet Moscova, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_COMPARE_H -#define CAML_COMPARE_H - -CAMLextern int caml_compare_unordered; - -#endif /* CAML_COMPARE_H */ diff -Nru ocaml-4.01.0/byterun/compatibility.h ocaml-4.02.3/byterun/compatibility.h --- ocaml-4.01.0/byterun/compatibility.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/compatibility.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,370 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ -/* */ -/* Copyright 2003 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* definitions for compatibility with old identifiers */ - -#ifndef CAML_COMPATIBILITY_H -#define CAML_COMPATIBILITY_H - -#ifndef CAML_NAME_SPACE - -/* - #define --> CAMLextern (defined with CAMLexport or CAMLprim) - (rien) --> CAMLprim - g --> global C identifier - x --> special case - - SP* signals the special cases: - - when the identifier was not simply prefixed with [caml_] - - when the [caml_] version was already used for something else, and - was renamed out of the way (watch out for [caml_alloc] and - [caml_array_bound_error] in *.s) -*/ - -/* a faire: - - ui_* (reverifier que win32.c n'en depend pas) -*/ - - -/* **** alloc.c */ -#define alloc caml_alloc /*SP*/ -#define alloc_small caml_alloc_small -#define alloc_tuple caml_alloc_tuple -#define alloc_string caml_alloc_string -#define alloc_final caml_alloc_final -#define copy_string caml_copy_string -#define alloc_array caml_alloc_array -#define copy_string_array caml_copy_string_array -#define convert_flag_list caml_convert_flag_list - -/* **** array.c */ - -/* **** backtrace.c */ -#define backtrace_active caml_backtrace_active -#define backtrace_pos caml_backtrace_pos -#define backtrace_buffer caml_backtrace_buffer -#define backtrace_last_exn caml_backtrace_last_exn -#define print_exception_backtrace caml_print_exception_backtrace - -/* **** callback.c */ -#define callback_depth caml_callback_depth -#define callbackN_exn caml_callbackN_exn -#define callback_exn caml_callback_exn -#define callback2_exn caml_callback2_exn -#define callback3_exn caml_callback3_exn -#define callback caml_callback -#define callback2 caml_callback2 -#define callback3 caml_callback3 -#define callbackN caml_callbackN - -/* **** compact.c */ - -/* **** compare.c */ -#define compare_unordered caml_compare_unordered - -/* **** custom.c */ -#define alloc_custom caml_alloc_custom -#define register_custom_operations caml_register_custom_operations - -/* **** debugger.c */ - -/* **** dynlink.c */ - -/* **** extern.c */ -#define output_val caml_output_val -#define output_value_to_malloc caml_output_value_to_malloc -#define output_value_to_block caml_output_value_to_block -#define serialize_int_1 caml_serialize_int_1 -#define serialize_int_2 caml_serialize_int_2 -#define serialize_int_4 caml_serialize_int_4 -#define serialize_int_8 caml_serialize_int_8 -#define serialize_float_4 caml_serialize_float_4 -#define serialize_float_8 caml_serialize_float_8 -#define serialize_block_1 caml_serialize_block_1 -#define serialize_block_2 caml_serialize_block_2 -#define serialize_block_4 caml_serialize_block_4 -#define serialize_block_8 caml_serialize_block_8 -#define serialize_block_float_8 caml_serialize_block_float_8 - -/* **** fail.c */ -#define external_raise caml_external_raise -#define mlraise caml_raise /*SP*/ -#define raise_constant caml_raise_constant -#define raise_with_arg caml_raise_with_arg -#define raise_with_string caml_raise_with_string -#define failwith caml_failwith -#define invalid_argument caml_invalid_argument -#define array_bound_error caml_array_bound_error /*SP*/ -#define raise_out_of_memory caml_raise_out_of_memory -#define raise_stack_overflow caml_raise_stack_overflow -#define raise_sys_error caml_raise_sys_error -#define raise_end_of_file caml_raise_end_of_file -#define raise_zero_divide caml_raise_zero_divide -#define raise_not_found caml_raise_not_found -#define raise_sys_blocked_io caml_raise_sys_blocked_io -#define init_exceptions caml_init_exceptions -/* **** asmrun/fail.c */ -/* **** asmrun/.s */ - -/* **** finalise.c */ - -/* **** fix_code.c */ - -/* **** floats.c */ -/*#define Double_val caml_Double_val done in mlvalues.h as needed */ -/*#define Store_double_val caml_Store_double_val done in mlvalues.h as needed */ -#define copy_double caml_copy_double - -/* **** freelist.c */ - -/* **** gc_ctrl.c */ - -/* **** globroots.c */ -#define register_global_root caml_register_global_root -#define remove_global_root caml_remove_global_root - -/* **** hash.c */ -#define hash_variant caml_hash_variant - -/* **** instrtrace.c */ - -/* **** intern.c */ -#define input_val caml_input_val -#define input_val_from_string caml_input_val_from_string -#define input_value_from_malloc caml_input_value_from_malloc -#define input_value_from_block caml_input_value_from_block -#define deserialize_uint_1 caml_deserialize_uint_1 -#define deserialize_sint_1 caml_deserialize_sint_1 -#define deserialize_uint_2 caml_deserialize_uint_2 -#define deserialize_sint_2 caml_deserialize_sint_2 -#define deserialize_uint_4 caml_deserialize_uint_4 -#define deserialize_sint_4 caml_deserialize_sint_4 -#define deserialize_uint_8 caml_deserialize_uint_8 -#define deserialize_sint_8 caml_deserialize_sint_8 -#define deserialize_float_4 caml_deserialize_float_4 -#define deserialize_float_8 caml_deserialize_float_8 -#define deserialize_block_1 caml_deserialize_block_1 -#define deserialize_block_2 caml_deserialize_block_2 -#define deserialize_block_4 caml_deserialize_block_4 -#define deserialize_block_8 caml_deserialize_block_8 -#define deserialize_block_float_8 caml_deserialize_block_float_8 -#define deserialize_error caml_deserialize_error - -/* **** interp.c */ - -/* **** ints.c */ -#define int32_ops caml_int32_ops -#define copy_int32 caml_copy_int32 -/*#define Int64_val caml_Int64_val *** done in mlvalues.h as needed */ -#define int64_ops caml_int64_ops -#define copy_int64 caml_copy_int64 -#define nativeint_ops caml_nativeint_ops -#define copy_nativeint caml_copy_nativeint - -/* **** io.c */ -#define channel_mutex_free caml_channel_mutex_free -#define channel_mutex_lock caml_channel_mutex_lock -#define channel_mutex_unlock caml_channel_mutex_unlock -#define channel_mutex_unlock_exn caml_channel_mutex_unlock_exn -#define all_opened_channels caml_all_opened_channels -#define open_descriptor_in caml_open_descriptor_in /*SP*/ -#define open_descriptor_out caml_open_descriptor_out /*SP*/ -#define close_channel caml_close_channel /*SP*/ -#define channel_size caml_channel_size /*SP*/ -#define channel_binary_mode caml_channel_binary_mode -#define flush_partial caml_flush_partial /*SP*/ -#define flush caml_flush /*SP*/ -#define putword caml_putword -#define putblock caml_putblock -#define really_putblock caml_really_putblock -#define seek_out caml_seek_out /*SP*/ -#define pos_out caml_pos_out /*SP*/ -#define do_read caml_do_read -#define refill caml_refill -#define getword caml_getword -#define getblock caml_getblock -#define really_getblock caml_really_getblock -#define seek_in caml_seek_in /*SP*/ -#define pos_in caml_pos_in /*SP*/ -#define input_scan_line caml_input_scan_line /*SP*/ -#define finalize_channel caml_finalize_channel -#define alloc_channel caml_alloc_channel -/*#define Val_file_offset caml_Val_file_offset *** done in io.h as needed */ -/*#define File_offset_val caml_File_offset_val *** done in io.h as needed */ - -/* **** lexing.c */ - -/* **** main.c */ -/* *** no change */ - -/* **** major_gc.c */ -#define heap_start caml_heap_start -#define page_table caml_page_table - -/* **** md5.c */ -#define md5_string caml_md5_string -#define md5_chan caml_md5_chan -#define MD5Init caml_MD5Init -#define MD5Update caml_MD5Update -#define MD5Final caml_MD5Final -#define MD5Transform caml_MD5Transform - -/* **** memory.c */ -#define alloc_shr caml_alloc_shr -#define initialize caml_initialize -#define modify caml_modify -#define stat_alloc caml_stat_alloc -#define stat_free caml_stat_free -#define stat_resize caml_stat_resize - -/* **** meta.c */ - -/* **** minor_gc.c */ -#define young_start caml_young_start -#define young_end caml_young_end -#define young_ptr caml_young_ptr -#define young_limit caml_young_limit -#define ref_table caml_ref_table -#define minor_collection caml_minor_collection -#define check_urgent_gc caml_check_urgent_gc - -/* **** misc.c */ - -/* **** obj.c */ - -/* **** parsing.c */ - -/* **** prims.c */ - -/* **** printexc.c */ -#define format_caml_exception caml_format_exception /*SP*/ - -/* **** roots.c */ -#define local_roots caml_local_roots -#define scan_roots_hook caml_scan_roots_hook -#define do_local_roots caml_do_local_roots - -/* **** signals.c */ -#define pending_signals caml_pending_signals -#define something_to_do caml_something_to_do -#define enter_blocking_section_hook caml_enter_blocking_section_hook -#define leave_blocking_section_hook caml_leave_blocking_section_hook -#define try_leave_blocking_section_hook caml_try_leave_blocking_section_hook -#define async_action_hook caml_async_action_hook -#define enter_blocking_section caml_enter_blocking_section -#define leave_blocking_section caml_leave_blocking_section -#define convert_signal_number caml_convert_signal_number -/* **** asmrun/signals.c */ -#define garbage_collection caml_garbage_collection - -/* **** stacks.c */ -#define stack_low caml_stack_low -#define stack_high caml_stack_high -#define stack_threshold caml_stack_threshold -#define extern_sp caml_extern_sp -#define trapsp caml_trapsp -#define trap_barrier caml_trap_barrier - -/* **** startup.c */ -#define atom_table caml_atom_table -/* **** asmrun/startup.c */ -#define static_data_start caml_static_data_start -#define static_data_end caml_static_data_end - -/* **** str.c */ -#define string_length caml_string_length - -/* **** sys.c */ -#define sys_error caml_sys_error -#define sys_exit caml_sys_exit - -/* **** terminfo.c */ - -/* **** unix.c & win32.c */ -#define search_exe_in_path caml_search_exe_in_path - -/* **** weak.c */ - -/* **** asmcomp/asmlink.ml */ - -/* **** asmcomp/cmmgen.ml */ - -/* **** asmcomp/asmlink.ml, asmcomp/cmmgen.ml, asmcomp/compilenv.ml */ - -/* ************************************************************* */ - -/* **** otherlibs/bigarray */ -#define int8 caml_ba_int8 -#define uint8 caml_ba_uint8 -#define int16 caml_ba_int16 -#define uint16 caml_ba_uint16 -#define MAX_NUM_DIMS CAML_BA_MAX_NUM_DIMS -#define caml_bigarray_kind caml_ba_kind -#define BIGARRAY_FLOAT32 CAML_BA_FLOAT32 -#define BIGARRAY_FLOAT64 CAML_BA_FLOAT64 -#define BIGARRAY_SINT8 CAML_BA_SINT8 -#define BIGARRAY_UINT8 CAML_BA_UINT8 -#define BIGARRAY_SINT16 CAML_BA_SINT16 -#define BIGARRAY_UINT16 CAML_BA_UINT16 -#define BIGARRAY_INT32 CAML_BA_INT32 -#define BIGARRAY_INT64 CAML_BA_INT64 -#define BIGARRAY_CAML_INT CAML_BA_CAML_INT -#define BIGARRAY_NATIVE_INT CAML_BA_NATIVE_INT -#define BIGARRAY_COMPLEX32 CAML_BA_COMPLEX32 -#define BIGARRAY_COMPLEX64 CAML_BA_COMPLEX64 -#define BIGARRAY_KIND_MASK CAML_BA_KIND_MASK -#define caml_bigarray_layout caml_ba_layout -#define BIGARRAY_C_LAYOUT CAML_BA_C_LAYOUT -#define BIGARRAY_FORTRAN_LAYOUT CAML_BA_FORTRAN_LAYOUT -#define BIGARRAY_LAYOUT_MASK CAML_BA_LAYOUT_MASK -#define caml_bigarray_managed caml_ba_managed -#define BIGARRAY_EXTERNAL CAML_BA_EXTERNAL -#define BIGARRAY_MANAGED CAML_BA_MANAGED -#define BIGARRAY_MAPPED_FILE CAML_BA_MAPPED_FILE -#define BIGARRAY_MANAGED_MASK CAML_BA_MANAGED_MASK -#define caml_bigarray_proxy caml_ba_proxy -#define caml_bigarray caml_ba_array -#define Bigarray_val Caml_ba_array_val -#define Data_bigarray_val Caml_ba_data_val -#define alloc_bigarray caml_ba_alloc -#define alloc_bigarray_dims caml_ba_alloc_dims -#define bigarray_map_file caml_ba_map_file -#define bigarray_unmap_file caml_ba_unmap_file -#define bigarray_element_size caml_ba_element_size -#define bigarray_byte_size caml_ba_byte_size -#define bigarray_deserialize caml_ba_deserialize -#define MAX_BIGARRAY_MEMORY CAML_BA_MAX_MEMORY -#define bigarray_create caml_ba_create -#define bigarray_get_N caml_ba_get_N -#define bigarray_get_1 caml_ba_get_1 -#define bigarray_get_2 caml_ba_get_2 -#define bigarray_get_3 caml_ba_get_3 -#define bigarray_get_generic caml_ba_get_generic -#define bigarray_set_1 caml_ba_set_1 -#define bigarray_set_2 caml_ba_set_2 -#define bigarray_set_3 caml_ba_set_3 -#define bigarray_set_N caml_ba_set_N -#define bigarray_set_generic caml_ba_set_generic -#define bigarray_num_dims caml_ba_num_dims -#define bigarray_dim caml_ba_dim -#define bigarray_kind caml_ba_kind -#define bigarray_layout caml_ba_layout -#define bigarray_slice caml_ba_slice -#define bigarray_sub caml_ba_sub -#define bigarray_blit caml_ba_blit -#define bigarray_fill caml_ba_fill -#define bigarray_reshape caml_ba_reshape -#define bigarray_init caml_ba_init - -#endif /* CAML_NAME_SPACE */ -#endif /* CAML_COMPATIBILITY_H */ diff -Nru ocaml-4.01.0/byterun/config.h ocaml-4.02.3/byterun/config.h --- ocaml-4.01.0/byterun/config.h 2013-03-22 19:22:51.000000000 +0100 +++ ocaml-4.02.3/byterun/config.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,167 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_CONFIG_H -#define CAML_CONFIG_H - -/* */ -/* */ -/* */ -#include "../config/m.h" -#include "../config/s.h" -/* */ - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif - -/* Types for signed chars, 32-bit integers, 64-bit integers, - native integers (as wide as a pointer type) */ - -typedef signed char schar; - -#if SIZEOF_PTR == SIZEOF_LONG -/* Standard models: ILP32 or I32LP64 */ -typedef long intnat; -typedef unsigned long uintnat; -#define ARCH_INTNAT_PRINTF_FORMAT "l" -#elif SIZEOF_PTR == SIZEOF_INT -/* Hypothetical IP32L64 model */ -typedef int intnat; -typedef unsigned int uintnat; -#define ARCH_INTNAT_PRINTF_FORMAT "" -#elif SIZEOF_PTR == 8 && defined(ARCH_INT64_TYPE) -/* Win64 model: IL32LLP64 */ -typedef ARCH_INT64_TYPE intnat; -typedef ARCH_UINT64_TYPE uintnat; -#define ARCH_INTNAT_PRINTF_FORMAT ARCH_INT64_PRINTF_FORMAT -#else -#error "No integer type available to represent pointers" -#endif - -#if SIZEOF_INT == 4 -typedef int int32; -typedef unsigned int uint32; -#define ARCH_INT32_PRINTF_FORMAT "" -#elif SIZEOF_LONG == 4 -typedef long int32; -typedef unsigned long uint32; -#define ARCH_INT32_PRINTF_FORMAT "l" -#elif SIZEOF_SHORT == 4 -typedef short int32; -typedef unsigned short uint32; -#define ARCH_INT32_PRINTF_FORMAT "" -#else -#error "No 32-bit integer type available" -#endif - -#if defined(ARCH_INT64_TYPE) -typedef ARCH_INT64_TYPE int64; -typedef ARCH_UINT64_TYPE uint64; -#else -# ifdef ARCH_BIG_ENDIAN -typedef struct { uint32 h, l; } uint64, int64; -# else -typedef struct { uint32 l, h; } uint64, int64; -# endif -#endif - -/* Endianness of floats */ - -/* ARCH_FLOAT_ENDIANNESS encodes the byte order of doubles as follows: - the value [0xabcdefgh] means that the least significant byte of the - float is at byte offset [a], the next lsb at [b], ..., and the - most significant byte at [h]. */ - -#if defined(__arm__) && !defined(__ARM_EABI__) -#define ARCH_FLOAT_ENDIANNESS 0x45670123 -#elif defined(ARCH_BIG_ENDIAN) -#define ARCH_FLOAT_ENDIANNESS 0x76543210 -#else -#define ARCH_FLOAT_ENDIANNESS 0x01234567 -#endif - -/* We use threaded code interpretation if the compiler provides labels - as first-class values (GCC 2.x). */ - -#if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG) \ - && !defined (SHRINKED_GNUC) && !defined(CAML_JIT) -#define THREADED_CODE -#endif - - -/* Do not change this definition. */ -#define Page_size (1 << Page_log) - -/* Memory model parameters */ - -/* The size of a page for memory management (in bytes) is [1 << Page_log]. - It must be a multiple of [sizeof (value)] and >= 8 and <= 20. */ -#define Page_log 12 /* A page is 4 kilobytes. */ - -/* Initial size of stack (bytes). */ -#define Stack_size (4096 * sizeof(value)) - -/* Minimum free size of stack (bytes); below that, it is reallocated. */ -#define Stack_threshold (256 * sizeof(value)) - -/* Default maximum size of the stack (words). */ -#define Max_stack_def (1024 * 1024) - - -/* Maximum size of a block allocated in the young generation (words). */ -/* Must be > 4 */ -#define Max_young_wosize 256 - - -/* Minimum size of the minor zone (words). - This must be at least [Max_young_wosize + 1]. */ -#define Minor_heap_min 4096 - -/* Maximum size of the minor zone (words). - Must be greater than or equal to [Minor_heap_min]. -*/ -#define Minor_heap_max (1 << 28) - -/* Default size of the minor zone. (words) */ -#define Minor_heap_def 262144 - - -/* Minimum size increment when growing the heap (words). - Must be a multiple of [Page_size / sizeof (value)]. */ -#define Heap_chunk_min (2 * Page_size / sizeof (value)) - -/* Default size increment when growing the heap. (words) - Must be a multiple of [Page_size / sizeof (value)]. - (Approx 512 Kb for a 32-bit platform, 1 Mb for a 64-bit platform.) */ -#define Heap_chunk_def (31 * Page_size) - -/* Default initial size of the major heap (words); - same constraints as for Heap_chunk_def. */ -#define Init_heap_def (31 * Page_size) - - -/* Default speed setting for the major GC. The heap will grow until - the dead objects and the free list represent this percentage of the - total size of live objects. */ -#define Percent_free_def 80 - -/* Default setting for the compacter: 500% - (i.e. trigger the compacter when 5/6 of the heap is free or garbage) - This can be set quite high because the overhead is over-estimated - when fragmentation occurs. - */ -#define Max_percent_free_def 500 - - -#endif /* CAML_CONFIG_H */ diff -Nru ocaml-4.01.0/byterun/custom.c ocaml-4.02.3/byterun/custom.c --- ocaml-4.01.0/byterun/custom.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/custom.c 2015-04-12 11:03:39.000000000 +0200 @@ -13,11 +13,11 @@ #include -#include "alloc.h" -#include "custom.h" -#include "fail.h" -#include "memory.h" -#include "mlvalues.h" +#include "caml/alloc.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" CAMLexport value caml_alloc_custom(struct custom_operations * ops, uintnat size, diff -Nru ocaml-4.01.0/byterun/custom.h ocaml-4.02.3/byterun/custom.h --- ocaml-4.01.0/byterun/custom.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/custom.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,71 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_CUSTOM_H -#define CAML_CUSTOM_H - - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "mlvalues.h" - -struct custom_operations { - char *identifier; - void (*finalize)(value v); - int (*compare)(value v1, value v2); - intnat (*hash)(value v); - void (*serialize)(value v, - /*out*/ uintnat * wsize_32 /*size in bytes*/, - /*out*/ uintnat * wsize_64 /*size in bytes*/); - uintnat (*deserialize)(void * dst); - int (*compare_ext)(value v1, value v2); -}; - -#define custom_finalize_default NULL -#define custom_compare_default NULL -#define custom_hash_default NULL -#define custom_serialize_default NULL -#define custom_deserialize_default NULL -#define custom_compare_ext_default NULL - -#define Custom_ops_val(v) (*((struct custom_operations **) (v))) - -#ifdef __cplusplus -extern "C" { -#endif - - -CAMLextern value caml_alloc_custom(struct custom_operations * ops, - uintnat size, /*size in bytes*/ - mlsize_t mem, /*resources consumed*/ - mlsize_t max /*max resources*/); - -CAMLextern void caml_register_custom_operations(struct custom_operations * ops); - -CAMLextern int caml_compare_unordered; - /* Used by custom comparison to report unordered NaN-like cases. */ - -/* */ -extern struct custom_operations * caml_find_custom_operations(char * ident); -extern struct custom_operations * - caml_final_custom_operations(void (*fn)(value)); - -extern void caml_init_custom_operations(void); -/* */ - -#ifdef __cplusplus -} -#endif - -#endif /* CAML_CUSTOM_H */ diff -Nru ocaml-4.01.0/byterun/debugger.c ocaml-4.02.3/byterun/debugger.c --- ocaml-4.01.0/byterun/debugger.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/debugger.c 2015-04-12 11:03:39.000000000 +0200 @@ -19,10 +19,10 @@ #include -#include "alloc.h" -#include "config.h" -#include "debugger.h" -#include "misc.h" +#include "caml/alloc.h" +#include "caml/config.h" +#include "caml/debugger.h" +#include "caml/misc.h" int caml_debugger_in_use = 0; uintnat caml_event_count; @@ -64,14 +64,14 @@ #include #endif -#include "fail.h" -#include "fix_code.h" -#include "instruct.h" -#include "intext.h" -#include "io.h" -#include "mlvalues.h" -#include "stacks.h" -#include "sys.h" +#include "caml/fail.h" +#include "caml/fix_code.h" +#include "caml/instruct.h" +#include "caml/intext.h" +#include "caml/io.h" +#include "caml/mlvalues.h" +#include "caml/stacks.h" +#include "caml/sys.h" static int sock_domain; /* Socket domain for the debugger */ static union { /* Socket address for the debugger */ @@ -250,7 +250,6 @@ void caml_debugger(enum event_kind event) { - int frame_number; value * frame; intnat i, pos; value val; @@ -258,7 +257,6 @@ if (dbg_socket == -1) return; /* Not connected to a debugger. */ /* Reset current frame */ - frame_number = 0; frame = caml_extern_sp + 1; /* Report the event to the debugger */ diff -Nru ocaml-4.01.0/byterun/debugger.h ocaml-4.02.3/byterun/debugger.h --- ocaml-4.01.0/byterun/debugger.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/debugger.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,111 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Interface with the debugger */ - -#ifndef CAML_DEBUGGER_H -#define CAML_DEBUGGER_H - -#include "misc.h" -#include "mlvalues.h" - -CAMLextern int caml_debugger_in_use; -CAMLextern int caml_debugger_fork_mode; /* non-zero for parent */ -extern uintnat caml_event_count; - -enum event_kind { - EVENT_COUNT, BREAKPOINT, PROGRAM_START, PROGRAM_EXIT, - TRAP_BARRIER, UNCAUGHT_EXC -}; - -void caml_debugger_init (void); -void caml_debugger (enum event_kind event); -void caml_debugger_cleanup_fork (void); - -/* Communication protocol */ - -/* Requests from the debugger to the runtime system */ - -enum debugger_request { - REQ_SET_EVENT = 'e', /* uint32 pos */ - /* Set an event on the instruction at position pos */ - REQ_SET_BREAKPOINT = 'B', /* uint32 pos, (char k) */ - /* Set a breakpoint at position pos */ - /* In profiling mode, the breakpoint kind is set to k */ - REQ_RESET_INSTR = 'i', /* uint32 pos */ - /* Clear an event or breapoint at position pos, restores initial instr. */ - REQ_CHECKPOINT = 'c', /* no args */ - /* Checkpoint the runtime system by forking a child process. - Reply is pid of child process or -1 if checkpoint failed. */ - REQ_GO = 'g', /* uint32 n */ - /* Run the program for n events. - Reply is one of debugger_reply described below. */ - REQ_STOP = 's', /* no args */ - /* Terminate the runtime system */ - REQ_WAIT = 'w', /* no args */ - /* Reap one dead child (a discarded checkpoint). */ - REQ_INITIAL_FRAME = '0', /* no args */ - /* Set current frame to bottom frame (the one currently executing). - Reply is stack offset and current pc. */ - REQ_GET_FRAME = 'f', /* no args */ - /* Return current frame location (stack offset + current pc). */ - REQ_SET_FRAME = 'S', /* uint32 stack_offset */ - /* Set current frame to given stack offset. No reply. */ - REQ_UP_FRAME = 'U', /* uint32 n */ - /* Move one frame up. Argument n is size of current frame (in words). - Reply is stack offset and current pc, or -1 if top of stack reached. */ - REQ_SET_TRAP_BARRIER = 'b', /* uint32 offset */ - /* Set the trap barrier at the given offset. */ - REQ_GET_LOCAL = 'L', /* uint32 slot_number */ - /* Return the local variable at the given slot in the current frame. - Reply is one value. */ - REQ_GET_ENVIRONMENT = 'E', /* uint32 slot_number */ - /* Return the local variable at the given slot in the heap environment - of the current frame. Reply is one value. */ - REQ_GET_GLOBAL = 'G', /* uint32 global_number */ - /* Return the specified global variable. Reply is one value. */ - REQ_GET_ACCU = 'A', /* no args */ - /* Return the current contents of the accumulator. Reply is one value. */ - REQ_GET_HEADER = 'H', /* mlvalue v */ - /* As REQ_GET_OBJ, but sends only the header. */ - REQ_GET_FIELD = 'F', /* mlvalue v, uint32 fieldnum */ - /* As REQ_GET_OBJ, but sends only one field. */ - REQ_MARSHAL_OBJ = 'M', /* mlvalue v */ - /* Send a copy of the data structure rooted at v, using the same - format as [caml_output_value]. */ - REQ_GET_CLOSURE_CODE = 'C', /* mlvalue v */ - /* Send the code address of the given closure. - Reply is one uint32. */ - REQ_SET_FORK_MODE = 'K' /* uint32 m */ - /* Set whether to follow the child (m=0) or the parent on fork. */ -}; - -/* Replies to a REQ_GO request. All replies are followed by three uint32: - - the value of the event counter - - the position of the stack - - the current pc. */ - -enum debugger_reply { - REP_EVENT = 'e', - /* Event counter reached 0. */ - REP_BREAKPOINT = 'b', - /* Breakpoint hit. */ - REP_EXITED = 'x', - /* Program exited by calling exit or reaching the end of the source. */ - REP_TRAP = 's', - /* Trap barrier crossed. */ - REP_UNCAUGHT_EXC = 'u' - /* Program exited due to a stray exception. */ -}; - -#endif /* CAML_DEBUGGER_H */ diff -Nru ocaml-4.01.0/byterun/.depend ocaml-4.02.3/byterun/.depend --- ocaml-4.01.0/byterun/.depend 2013-08-15 18:13:16.000000000 +0200 +++ ocaml-4.02.3/byterun/.depend 2015-07-23 17:14:03.000000000 +0200 @@ -1,422 +1,729 @@ -alloc.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h stacks.h -array.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -backtrace.o: backtrace.c config.h ../config/m.h ../config/s.h \ - compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - startup.h stacks.h sys.h backtrace.h -callback.o: callback.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h -compact.o: compact.c config.h ../config/m.h ../config/s.h compatibility.h \ - finalise.h roots.h misc.h memory.h gc.h mlvalues.h major_gc.h \ - freelist.h minor_gc.h gc_ctrl.h weak.h -compare.o: compare.c custom.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h -custom.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h -debugger.o: debugger.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ - instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h sys.h -dynlink.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h osdeps.h prims.h -extern.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ - memory.h major_gc.h freelist.h minor_gc.h reverse.h -fail.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ - freelist.h minor_gc.h printexc.h signals.h stacks.h -finalise.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h signals.h -fix_code.o: fix_code.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ - intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - reverse.h -floats.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h reverse.h stacks.h -freelist.o: freelist.c config.h ../config/m.h ../config/s.h \ - compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ - major_gc.h minor_gc.h -gc_ctrl.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ - roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ - stacks.h -globroots.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ - ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - roots.h globroots.h -hash.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h hash.h int64_native.h +alloc.o: alloc.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/major_gc.h caml/freelist.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h caml/mlvalues.h caml/stacks.h caml/memory.h +array.o: array.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/mlvalues.h +backtrace.o: backtrace.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/misc.h caml/alloc.h caml/mlvalues.h caml/io.h \ + caml/instruct.h caml/intext.h caml/io.h caml/exec.h caml/fix_code.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/startup.h caml/exec.h caml/stacks.h \ + caml/memory.h caml/sys.h caml/backtrace.h caml/fail.h +callback.o: callback.c caml/callback.h caml/compatibility.h \ + caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/fail.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h caml/interp.h caml/instruct.h caml/fix_code.h \ + caml/stacks.h caml/memory.h +compact.o: compact.c caml/address_class.h caml/misc.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/config.h caml/finalise.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/freelist.h caml/gc.h \ + caml/gc_ctrl.h caml/major_gc.h caml/memory.h caml/mlvalues.h \ + caml/roots.h caml/weak.h +compare.o: compare.c caml/custom.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/mlvalues.h +custom.o: custom.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h +debugger.o: debugger.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/config.h caml/debugger.h caml/misc.h caml/fail.h \ + caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/io.h \ + caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/sys.h +dynlink.o: dynlink.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/dynlink.h caml/fail.h \ + caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/osdeps.h \ + caml/prims.h caml/signals.h +extern.o: extern.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ + caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/mlvalues.h caml/reverse.h +fail.o: fail.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/io.h caml/gc.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/misc.h caml/mlvalues.h caml/printexc.h caml/signals.h \ + caml/stacks.h caml/memory.h +finalise.o: finalise.c caml/callback.h caml/compatibility.h \ + caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/fail.h caml/mlvalues.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/signals.h +fix_code.o: fix_code.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/debugger.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/fix_code.h caml/instruct.h \ + caml/intext.h caml/io.h caml/md5.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/misc.h caml/mlvalues.h caml/reverse.h +floats.o: floats.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/mlvalues.h \ + caml/misc.h caml/reverse.h caml/stacks.h caml/memory.h +freelist.o: freelist.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/freelist.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/gc.h caml/gc_ctrl.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/major_gc.h caml/misc.h caml/mlvalues.h +gc_ctrl.o: gc_ctrl.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/compact.h caml/custom.h caml/finalise.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/freelist.h caml/gc.h \ + caml/gc_ctrl.h caml/major_gc.h caml/minor_gc.h caml/misc.h \ + caml/mlvalues.h caml/stacks.h +globroots.o: globroots.c caml/memory.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/gc.h caml/mlvalues.h \ + caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/memory.h caml/globroots.h caml/roots.h +hash.o: hash.c caml/mlvalues.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/custom.h \ + caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/hash.h instrtrace.o: instrtrace.c -intern.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ - md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h -interp.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ - fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ - memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h -ints.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h int64_native.h -io.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h signals.h sys.h -lexing.o: lexing.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -main.o: main.c misc.h compatibility.h config.h ../config/m.h \ - ../config/s.h mlvalues.h sys.h -major_gc.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ - compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h -md5.o: md5.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h reverse.h -memory.o: memory.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ - minor_gc.h signals.h -meta.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ - major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h -minor_gc.o: minor_gc.c config.h ../config/m.h ../config/s.h \ - compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ - gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h -misc.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ - misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h -obj.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ - memory.h minor_gc.h prims.h -parsing.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \ - mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - alloc.h -prims.o: prims.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h prims.h -printexc.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ - ../config/m.h ../config/s.h misc.h callback.h debugger.h fail.h \ - printexc.h -roots.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \ - ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ - freelist.h minor_gc.h globroots.h stacks.h -signals.o: signals.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ - sys.h -signals_byt.o: signals_byt.c config.h ../config/m.h ../config/s.h \ - compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ - minor_gc.h osdeps.h signals.h signals_machdep.h -stacks.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ - fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -startup.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ - dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ - interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ - prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ - version.h -str.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h int64_native.h -sys.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ - stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h -terminfo.o: terminfo.c config.h ../config/m.h ../config/s.h \ - compatibility.h alloc.h misc.h mlvalues.h fail.h io.h -unix.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ - memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h -weak.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h -win32.o: win32.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h signals.h sys.h -alloc.d.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h stacks.h -array.d.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -backtrace.d.o: backtrace.c config.h ../config/m.h ../config/s.h \ - compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - startup.h stacks.h sys.h backtrace.h -callback.d.o: callback.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h -compact.d.o: compact.c config.h ../config/m.h ../config/s.h compatibility.h \ - finalise.h roots.h misc.h memory.h gc.h mlvalues.h major_gc.h \ - freelist.h minor_gc.h gc_ctrl.h weak.h -compare.d.o: compare.c custom.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h -custom.d.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h -debugger.d.o: debugger.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ - instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h sys.h -dynlink.d.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h osdeps.h prims.h -extern.d.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ - memory.h major_gc.h freelist.h minor_gc.h reverse.h -fail.d.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ - freelist.h minor_gc.h printexc.h signals.h stacks.h -finalise.d.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h signals.h -fix_code.d.o: fix_code.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ - intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - reverse.h -floats.d.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h reverse.h stacks.h -freelist.d.o: freelist.c config.h ../config/m.h ../config/s.h \ - compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ - major_gc.h minor_gc.h -gc_ctrl.d.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ - roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ - stacks.h -globroots.d.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ - ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - roots.h globroots.h -hash.d.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h hash.h int64_native.h -instrtrace.d.o: instrtrace.c instruct.h misc.h compatibility.h config.h \ - ../config/m.h ../config/s.h mlvalues.h opnames.h prims.h stacks.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h -intern.d.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ - md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h -interp.d.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ - fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ - memory.h gc.h minor_gc.h prims.h signals.h stacks.h -ints.d.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h int64_native.h -io.d.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h signals.h sys.h -lexing.d.o: lexing.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -main.d.o: main.c misc.h compatibility.h config.h ../config/m.h \ - ../config/s.h mlvalues.h sys.h -major_gc.d.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ - compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h -md5.d.o: md5.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h reverse.h -memory.d.o: memory.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ - minor_gc.h signals.h -meta.d.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ - major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h -minor_gc.d.o: minor_gc.c config.h ../config/m.h ../config/s.h \ - compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ - gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h -misc.d.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ - misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h -obj.d.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ - memory.h minor_gc.h prims.h -parsing.d.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \ - mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - alloc.h -prims.d.o: prims.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h prims.h -printexc.d.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ - ../config/m.h ../config/s.h misc.h callback.h debugger.h fail.h \ - printexc.h -roots.d.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \ - ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ - freelist.h minor_gc.h globroots.h stacks.h -signals.d.o: signals.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ - sys.h -signals_byt.d.o: signals_byt.c config.h ../config/m.h ../config/s.h \ - compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ - minor_gc.h osdeps.h signals.h signals_machdep.h -stacks.d.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ - fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -startup.d.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ - dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ - interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ - prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ - version.h -str.d.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h int64_native.h -sys.d.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ - stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h -terminfo.d.o: terminfo.c config.h ../config/m.h ../config/s.h \ - compatibility.h alloc.h misc.h mlvalues.h fail.h io.h -unix.d.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ - memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h -weak.d.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h -win32.d.o: win32.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h signals.h sys.h -alloc.pic.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h stacks.h -array.pic.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -backtrace.pic.o: backtrace.c config.h ../config/m.h ../config/s.h \ - compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - startup.h stacks.h sys.h backtrace.h -callback.pic.o: callback.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h -compact.pic.o: compact.c config.h ../config/m.h ../config/s.h compatibility.h \ - finalise.h roots.h misc.h memory.h gc.h mlvalues.h major_gc.h \ - freelist.h minor_gc.h gc_ctrl.h weak.h -compare.pic.o: compare.c custom.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h -custom.pic.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h -debugger.pic.o: debugger.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ - instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h sys.h -dynlink.pic.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h osdeps.h prims.h -extern.pic.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ - memory.h major_gc.h freelist.h minor_gc.h reverse.h -fail.pic.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ - freelist.h minor_gc.h printexc.h signals.h stacks.h -finalise.pic.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ - ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h signals.h -fix_code.pic.o: fix_code.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ - intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - reverse.h -floats.pic.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h reverse.h stacks.h -freelist.pic.o: freelist.c config.h ../config/m.h ../config/s.h \ - compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ - major_gc.h minor_gc.h -gc_ctrl.pic.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ - roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ - stacks.h -globroots.pic.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ - ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - roots.h globroots.h -hash.pic.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h hash.h int64_native.h +intern.o: intern.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/callback.h caml/custom.h caml/fail.h caml/gc.h \ + caml/intext.h caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h caml/misc.h caml/reverse.h +interp.o: interp.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/backtrace.h caml/callback.h caml/debugger.h \ + caml/fail.h caml/fix_code.h caml/instrtrace.h caml/instruct.h \ + caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/mlvalues.h caml/prims.h caml/signals.h caml/stacks.h caml/memory.h \ + caml/jumptbl.h +ints.o: ints.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/intext.h caml/io.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h +io.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/alloc.h caml/misc.h caml/config.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/io.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/signals.h \ + caml/sys.h +lexing.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h +main.o: main.c caml/misc.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/misc.h \ + caml/sys.h +major_gc.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/misc.h caml/custom.h \ + caml/mlvalues.h caml/config.h caml/fail.h caml/finalise.h caml/roots.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ + caml/major_gc.h caml/misc.h caml/mlvalues.h caml/roots.h caml/weak.h +md5.o: md5.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/md5.h caml/io.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/mlvalues.h \ + caml/io.h caml/reverse.h +memory.o: memory.c caml/address_class.h caml/misc.h caml/compatibility.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ + caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/minor_gc.h caml/address_class.h caml/minor_gc.h caml/misc.h \ + caml/mlvalues.h caml/signals.h +meta.o: meta.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/config.h caml/fail.h caml/fix_code.h caml/interp.h \ + caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \ + caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h caml/stacks.h \ + caml/memory.h +minor_gc.o: minor_gc.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/finalise.h caml/roots.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/gc.h caml/gc_ctrl.h caml/major_gc.h \ + caml/memory.h caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/signals.h caml/weak.h +misc.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/misc.h caml/config.h caml/memory.h caml/gc.h \ + caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +obj.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/gc.h caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \ + caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h +parsing.o: parsing.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/misc.h caml/memory.h caml/gc.h caml/mlvalues.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/alloc.h +prims.o: prims.c caml/mlvalues.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/prims.h +printexc.o: printexc.c caml/backtrace.h caml/mlvalues.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/callback.h caml/debugger.h \ + caml/fail.h caml/misc.h caml/mlvalues.h caml/printexc.h +roots.o: roots.c caml/finalise.h caml/roots.h caml/misc.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/globroots.h caml/major_gc.h caml/memory.h caml/minor_gc.h \ + caml/misc.h caml/mlvalues.h caml/roots.h caml/stacks.h +signals.o: signals.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/callback.h caml/config.h caml/fail.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/memory.h caml/signals.h caml/signals_machdep.h caml/sys.h +signals_byt.o: signals_byt.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/memory.h caml/config.h \ + caml/gc.h caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ + caml/signals_machdep.h +stacks.o: stacks.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/misc.h caml/mlvalues.h caml/stacks.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h +startup.o: startup.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/backtrace.h caml/callback.h \ + caml/custom.h caml/debugger.h caml/dynlink.h caml/exec.h caml/fail.h \ + caml/fix_code.h caml/freelist.h caml/gc_ctrl.h caml/instrtrace.h \ + caml/interp.h caml/intext.h caml/io.h caml/io.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/osdeps.h caml/prims.h \ + caml/printexc.h caml/reverse.h caml/signals.h caml/stacks.h \ + caml/memory.h caml/sys.h caml/startup.h caml/exec.h caml/version.h +str.o: str.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/mlvalues.h caml/misc.h +sys.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/alloc.h caml/misc.h caml/config.h \ + caml/mlvalues.h caml/debugger.h caml/fail.h caml/instruct.h \ + caml/mlvalues.h caml/osdeps.h caml/signals.h caml/stacks.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/sys.h +terminfo.o: terminfo.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/fail.h caml/io.h caml/mlvalues.h +unix.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/memory.h caml/config.h caml/gc.h \ + caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/osdeps.h +weak.o: weak.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h caml/mlvalues.h +win32.o: win32.c caml/address_class.h caml/misc.h caml/compatibility.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/osdeps.h caml/signals.h caml/sys.h +alloc.d.o: alloc.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/major_gc.h caml/freelist.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h caml/mlvalues.h caml/stacks.h caml/memory.h +array.d.o: array.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/mlvalues.h +backtrace.d.o: backtrace.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/misc.h caml/alloc.h caml/mlvalues.h caml/io.h \ + caml/instruct.h caml/intext.h caml/io.h caml/exec.h caml/fix_code.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/startup.h caml/exec.h caml/stacks.h \ + caml/memory.h caml/sys.h caml/backtrace.h caml/fail.h +callback.d.o: callback.c caml/callback.h caml/compatibility.h \ + caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/fail.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h caml/interp.h caml/instruct.h caml/fix_code.h \ + caml/stacks.h caml/memory.h +compact.d.o: compact.c caml/address_class.h caml/misc.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/config.h caml/finalise.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/freelist.h caml/gc.h \ + caml/gc_ctrl.h caml/major_gc.h caml/memory.h caml/mlvalues.h \ + caml/roots.h caml/weak.h +compare.d.o: compare.c caml/custom.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/mlvalues.h +custom.d.o: custom.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h +debugger.d.o: debugger.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/config.h caml/debugger.h caml/misc.h caml/fail.h \ + caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/io.h \ + caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/sys.h +dynlink.d.o: dynlink.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/dynlink.h caml/fail.h \ + caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/osdeps.h \ + caml/prims.h caml/signals.h +extern.d.o: extern.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ + caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/mlvalues.h caml/reverse.h +fail.d.o: fail.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/io.h caml/gc.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/misc.h caml/mlvalues.h caml/printexc.h caml/signals.h \ + caml/stacks.h caml/memory.h +finalise.d.o: finalise.c caml/callback.h caml/compatibility.h \ + caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/fail.h caml/mlvalues.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/signals.h +fix_code.d.o: fix_code.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/debugger.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/fix_code.h caml/instruct.h \ + caml/intext.h caml/io.h caml/md5.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/misc.h caml/mlvalues.h caml/reverse.h +floats.d.o: floats.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/mlvalues.h \ + caml/misc.h caml/reverse.h caml/stacks.h caml/memory.h +freelist.d.o: freelist.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/freelist.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/gc.h caml/gc_ctrl.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/major_gc.h caml/misc.h caml/mlvalues.h +gc_ctrl.d.o: gc_ctrl.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/compact.h caml/custom.h caml/finalise.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/freelist.h caml/gc.h \ + caml/gc_ctrl.h caml/major_gc.h caml/minor_gc.h caml/misc.h \ + caml/mlvalues.h caml/stacks.h +globroots.d.o: globroots.c caml/memory.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/gc.h caml/mlvalues.h \ + caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/memory.h caml/globroots.h caml/roots.h +hash.d.o: hash.c caml/mlvalues.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/custom.h \ + caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/hash.h +instrtrace.d.o: instrtrace.c caml/instruct.h caml/misc.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/misc.h caml/opnames.h \ + caml/prims.h caml/stacks.h caml/mlvalues.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h +intern.d.o: intern.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/callback.h caml/custom.h caml/fail.h caml/gc.h \ + caml/intext.h caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h caml/misc.h caml/reverse.h +interp.d.o: interp.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/backtrace.h caml/callback.h caml/debugger.h \ + caml/fail.h caml/fix_code.h caml/instrtrace.h caml/instruct.h \ + caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/mlvalues.h caml/prims.h caml/signals.h caml/stacks.h caml/memory.h +ints.d.o: ints.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/intext.h caml/io.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h +io.d.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/alloc.h caml/misc.h caml/config.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/io.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/signals.h \ + caml/sys.h +lexing.d.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h +main.d.o: main.c caml/misc.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/misc.h \ + caml/sys.h +major_gc.d.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/misc.h caml/custom.h \ + caml/mlvalues.h caml/config.h caml/fail.h caml/finalise.h caml/roots.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ + caml/major_gc.h caml/misc.h caml/mlvalues.h caml/roots.h caml/weak.h +md5.d.o: md5.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/md5.h caml/io.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/mlvalues.h \ + caml/io.h caml/reverse.h +memory.d.o: memory.c caml/address_class.h caml/misc.h caml/compatibility.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ + caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/minor_gc.h caml/address_class.h caml/minor_gc.h caml/misc.h \ + caml/mlvalues.h caml/signals.h +meta.d.o: meta.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/config.h caml/fail.h caml/fix_code.h caml/interp.h \ + caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \ + caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h caml/stacks.h \ + caml/memory.h +minor_gc.d.o: minor_gc.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/finalise.h caml/roots.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/gc.h caml/gc_ctrl.h caml/major_gc.h \ + caml/memory.h caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/signals.h caml/weak.h +misc.d.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/misc.h caml/config.h caml/memory.h caml/gc.h \ + caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +obj.d.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/gc.h caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \ + caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h +parsing.d.o: parsing.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/misc.h caml/memory.h caml/gc.h caml/mlvalues.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/alloc.h +prims.d.o: prims.c caml/mlvalues.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/prims.h +printexc.d.o: printexc.c caml/backtrace.h caml/mlvalues.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/callback.h caml/debugger.h \ + caml/fail.h caml/misc.h caml/mlvalues.h caml/printexc.h +roots.d.o: roots.c caml/finalise.h caml/roots.h caml/misc.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/globroots.h caml/major_gc.h caml/memory.h caml/minor_gc.h \ + caml/misc.h caml/mlvalues.h caml/roots.h caml/stacks.h +signals.d.o: signals.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/callback.h caml/config.h caml/fail.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/memory.h caml/signals.h caml/signals_machdep.h caml/sys.h +signals_byt.d.o: signals_byt.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/memory.h caml/config.h \ + caml/gc.h caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ + caml/signals_machdep.h +stacks.d.o: stacks.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/misc.h caml/mlvalues.h caml/stacks.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h +startup.d.o: startup.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/backtrace.h caml/callback.h \ + caml/custom.h caml/debugger.h caml/dynlink.h caml/exec.h caml/fail.h \ + caml/fix_code.h caml/freelist.h caml/gc_ctrl.h caml/instrtrace.h \ + caml/interp.h caml/intext.h caml/io.h caml/io.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/osdeps.h caml/prims.h \ + caml/printexc.h caml/reverse.h caml/signals.h caml/stacks.h \ + caml/memory.h caml/sys.h caml/startup.h caml/exec.h caml/version.h +str.d.o: str.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/mlvalues.h caml/misc.h +sys.d.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/alloc.h caml/misc.h caml/config.h \ + caml/mlvalues.h caml/debugger.h caml/fail.h caml/instruct.h \ + caml/mlvalues.h caml/osdeps.h caml/signals.h caml/stacks.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/sys.h +terminfo.d.o: terminfo.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/fail.h caml/io.h caml/mlvalues.h +unix.d.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/memory.h caml/config.h caml/gc.h \ + caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/osdeps.h +weak.d.o: weak.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h caml/mlvalues.h +win32.d.o: win32.c caml/address_class.h caml/misc.h caml/compatibility.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/osdeps.h caml/signals.h caml/sys.h +alloc.pic.o: alloc.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/major_gc.h caml/freelist.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h caml/mlvalues.h caml/stacks.h caml/memory.h +array.pic.o: array.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/mlvalues.h +backtrace.pic.o: backtrace.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/misc.h caml/alloc.h caml/mlvalues.h caml/io.h \ + caml/instruct.h caml/intext.h caml/io.h caml/exec.h caml/fix_code.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/startup.h caml/exec.h caml/stacks.h \ + caml/memory.h caml/sys.h caml/backtrace.h caml/fail.h +callback.pic.o: callback.c caml/callback.h caml/compatibility.h \ + caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/fail.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h caml/interp.h caml/instruct.h caml/fix_code.h \ + caml/stacks.h caml/memory.h +compact.pic.o: compact.c caml/address_class.h caml/misc.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/mlvalues.h caml/config.h caml/finalise.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/freelist.h caml/gc.h \ + caml/gc_ctrl.h caml/major_gc.h caml/memory.h caml/mlvalues.h \ + caml/roots.h caml/weak.h +compare.pic.o: compare.c caml/custom.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h caml/misc.h \ + caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/mlvalues.h +custom.pic.o: custom.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h +debugger.pic.o: debugger.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/config.h caml/debugger.h caml/misc.h caml/fail.h \ + caml/fix_code.h caml/instruct.h caml/intext.h caml/io.h caml/io.h \ + caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/sys.h +dynlink.pic.o: dynlink.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/dynlink.h caml/fail.h \ + caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/osdeps.h \ + caml/prims.h caml/signals.h +extern.pic.o: extern.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ + caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/mlvalues.h caml/reverse.h +fail.pic.o: fail.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/io.h caml/gc.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/misc.h caml/mlvalues.h caml/printexc.h caml/signals.h \ + caml/stacks.h caml/memory.h +finalise.pic.o: finalise.c caml/callback.h caml/compatibility.h \ + caml/mlvalues.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/fail.h caml/mlvalues.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/signals.h +fix_code.pic.o: fix_code.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/debugger.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/fix_code.h caml/instruct.h \ + caml/intext.h caml/io.h caml/md5.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/misc.h caml/mlvalues.h caml/reverse.h +floats.pic.o: floats.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/mlvalues.h \ + caml/misc.h caml/reverse.h caml/stacks.h caml/memory.h +freelist.pic.o: freelist.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/freelist.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/gc.h caml/gc_ctrl.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/major_gc.h caml/misc.h caml/mlvalues.h +gc_ctrl.pic.o: gc_ctrl.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/compact.h caml/custom.h caml/finalise.h \ + caml/roots.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/freelist.h caml/gc.h \ + caml/gc_ctrl.h caml/major_gc.h caml/minor_gc.h caml/misc.h \ + caml/mlvalues.h caml/stacks.h +globroots.pic.o: globroots.c caml/memory.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/gc.h caml/mlvalues.h \ + caml/misc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/memory.h caml/globroots.h caml/roots.h +hash.pic.o: hash.c caml/mlvalues.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/custom.h \ + caml/mlvalues.h caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/hash.h instrtrace.pic.o: instrtrace.c -intern.pic.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ - md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h -interp.pic.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ - fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ - memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h -ints.pic.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h int64_native.h -io.pic.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h signals.h sys.h -lexing.pic.o: lexing.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -main.pic.o: main.c misc.h compatibility.h config.h ../config/m.h \ - ../config/s.h mlvalues.h sys.h -major_gc.pic.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ - compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h -md5.pic.o: md5.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h reverse.h -memory.pic.o: memory.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ - minor_gc.h signals.h -meta.pic.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ - major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h -minor_gc.pic.o: minor_gc.c config.h ../config/m.h ../config/s.h \ - compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ - gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h -misc.pic.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ - misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h -obj.pic.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ - memory.h minor_gc.h prims.h -parsing.pic.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \ - mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - alloc.h -prims.pic.o: prims.c mlvalues.h compatibility.h config.h ../config/m.h \ - ../config/s.h misc.h prims.h -printexc.pic.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ - ../config/m.h ../config/s.h misc.h callback.h debugger.h fail.h \ - printexc.h -roots.pic.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \ - ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ - freelist.h minor_gc.h globroots.h stacks.h -signals.pic.o: signals.c alloc.h compatibility.h misc.h config.h \ - ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ - sys.h -signals_byt.pic.o: signals_byt.c config.h ../config/m.h ../config/s.h \ - compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ - minor_gc.h osdeps.h signals.h signals_machdep.h -stacks.pic.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ - fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h -startup.pic.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ - alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ - dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ - interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ - prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ - version.h -str.pic.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h int64_native.h -sys.pic.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ - misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ - stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h -terminfo.pic.o: terminfo.c config.h ../config/m.h ../config/s.h \ - compatibility.h alloc.h misc.h mlvalues.h fail.h io.h -unix.pic.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ - memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h -weak.pic.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ - minor_gc.h -win32.pic.o: win32.c fail.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h signals.h sys.h +intern.pic.o: intern.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/callback.h caml/custom.h caml/fail.h caml/gc.h \ + caml/intext.h caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/mlvalues.h caml/misc.h caml/reverse.h +interp.pic.o: interp.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/backtrace.h caml/callback.h caml/debugger.h \ + caml/fail.h caml/fix_code.h caml/instrtrace.h caml/instruct.h \ + caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/mlvalues.h caml/prims.h caml/signals.h caml/stacks.h caml/memory.h \ + caml/jumptbl.h +ints.pic.o: ints.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/intext.h caml/io.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h +io.pic.o: io.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/alloc.h caml/misc.h caml/config.h \ + caml/mlvalues.h caml/custom.h caml/fail.h caml/io.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/signals.h \ + caml/sys.h +lexing.pic.o: lexing.c caml/fail.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/mlvalues.h caml/stacks.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h +main.pic.o: main.c caml/misc.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/misc.h \ + caml/sys.h +major_gc.pic.o: major_gc.c caml/compact.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/misc.h caml/custom.h \ + caml/mlvalues.h caml/config.h caml/fail.h caml/finalise.h caml/roots.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ + caml/major_gc.h caml/misc.h caml/mlvalues.h caml/roots.h caml/weak.h +md5.pic.o: md5.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/md5.h caml/io.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/mlvalues.h \ + caml/io.h caml/reverse.h +memory.pic.o: memory.c caml/address_class.h caml/misc.h caml/compatibility.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/freelist.h caml/gc.h caml/gc_ctrl.h \ + caml/major_gc.h caml/freelist.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/minor_gc.h caml/address_class.h caml/minor_gc.h caml/misc.h \ + caml/mlvalues.h caml/signals.h +meta.pic.o: meta.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/config.h caml/fail.h caml/fix_code.h caml/interp.h \ + caml/intext.h caml/io.h caml/major_gc.h caml/freelist.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \ + caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h caml/stacks.h \ + caml/memory.h +minor_gc.pic.o: minor_gc.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/finalise.h caml/roots.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/gc.h caml/gc_ctrl.h caml/major_gc.h \ + caml/memory.h caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/signals.h caml/weak.h +misc.pic.o: misc.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/misc.h caml/config.h caml/memory.h caml/gc.h \ + caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h +obj.pic.o: obj.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/gc.h caml/interp.h caml/major_gc.h caml/freelist.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/minor_gc.h caml/address_class.h \ + caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/prims.h +parsing.pic.o: parsing.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/mlvalues.h \ + caml/config.h caml/misc.h caml/memory.h caml/gc.h caml/mlvalues.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/alloc.h +prims.pic.o: prims.c caml/mlvalues.h caml/compatibility.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/misc.h caml/prims.h +printexc.pic.o: printexc.c caml/backtrace.h caml/mlvalues.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/misc.h caml/callback.h caml/debugger.h \ + caml/fail.h caml/misc.h caml/mlvalues.h caml/printexc.h +roots.pic.o: roots.c caml/finalise.h caml/roots.h caml/misc.h \ + caml/compatibility.h caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/memory.h caml/gc.h caml/mlvalues.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/globroots.h caml/major_gc.h caml/memory.h caml/minor_gc.h \ + caml/misc.h caml/mlvalues.h caml/roots.h caml/stacks.h +signals.pic.o: signals.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/callback.h caml/config.h caml/fail.h caml/memory.h \ + caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/misc.h caml/mlvalues.h caml/roots.h \ + caml/memory.h caml/signals.h caml/signals_machdep.h caml/sys.h +signals_byt.pic.o: signals_byt.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/memory.h caml/config.h \ + caml/gc.h caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/osdeps.h caml/signals.h \ + caml/signals_machdep.h +stacks.pic.o: stacks.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/fail.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/misc.h caml/mlvalues.h caml/stacks.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h +startup.pic.o: startup.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/backtrace.h caml/callback.h \ + caml/custom.h caml/debugger.h caml/dynlink.h caml/exec.h caml/fail.h \ + caml/fix_code.h caml/freelist.h caml/gc_ctrl.h caml/instrtrace.h \ + caml/interp.h caml/intext.h caml/io.h caml/io.h caml/memory.h caml/gc.h \ + caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ + caml/minor_gc.h caml/misc.h caml/mlvalues.h caml/osdeps.h caml/prims.h \ + caml/printexc.h caml/reverse.h caml/signals.h caml/stacks.h \ + caml/memory.h caml/sys.h caml/startup.h caml/exec.h caml/version.h +str.pic.o: str.c caml/alloc.h caml/compatibility.h caml/misc.h caml/config.h \ + caml/../../config/m.h caml/../../config/s.h caml/mlvalues.h caml/fail.h \ + caml/mlvalues.h caml/misc.h +sys.pic.o: sys.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/alloc.h caml/misc.h caml/config.h \ + caml/mlvalues.h caml/debugger.h caml/fail.h caml/instruct.h \ + caml/mlvalues.h caml/osdeps.h caml/signals.h caml/stacks.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \ + caml/address_class.h caml/sys.h +terminfo.pic.o: terminfo.c caml/config.h caml/../../config/m.h \ + caml/../../config/s.h caml/compatibility.h caml/alloc.h caml/misc.h \ + caml/config.h caml/mlvalues.h caml/fail.h caml/io.h caml/mlvalues.h +unix.pic.o: unix.c caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/compatibility.h caml/memory.h caml/config.h caml/gc.h \ + caml/mlvalues.h caml/misc.h caml/major_gc.h caml/freelist.h \ + caml/minor_gc.h caml/address_class.h caml/misc.h caml/osdeps.h +weak.pic.o: weak.c caml/alloc.h caml/compatibility.h caml/misc.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/major_gc.h caml/freelist.h \ + caml/memory.h caml/gc.h caml/major_gc.h caml/minor_gc.h \ + caml/address_class.h caml/mlvalues.h +win32.pic.o: win32.c caml/address_class.h caml/misc.h caml/compatibility.h \ + caml/config.h caml/../../config/m.h caml/../../config/s.h \ + caml/mlvalues.h caml/fail.h caml/memory.h caml/gc.h caml/major_gc.h \ + caml/freelist.h caml/minor_gc.h caml/address_class.h caml/misc.h \ + caml/osdeps.h caml/signals.h caml/sys.h diff -Nru ocaml-4.01.0/byterun/dynlink.c ocaml-4.02.3/byterun/dynlink.c --- ocaml-4.01.0/byterun/dynlink.c 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/byterun/dynlink.c 2015-04-12 11:03:39.000000000 +0200 @@ -18,18 +18,19 @@ #include #include #include -#include "config.h" +#include "caml/config.h" #ifdef HAS_UNISTD #include #endif -#include "alloc.h" -#include "dynlink.h" -#include "fail.h" -#include "mlvalues.h" -#include "memory.h" -#include "misc.h" -#include "osdeps.h" -#include "prims.h" +#include "caml/alloc.h" +#include "caml/dynlink.h" +#include "caml/fail.h" +#include "caml/mlvalues.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/osdeps.h" +#include "caml/prims.h" +#include "caml/signals.h" #ifndef NATIVE_CODE @@ -79,9 +80,7 @@ stdlib = getenv("OCAMLLIB"); if (stdlib == NULL) stdlib = getenv("CAMLLIB"); if (stdlib == NULL) stdlib = OCAML_STDLIB_DIR; - ldconfname = caml_stat_alloc(strlen(stdlib) + 2 + sizeof(LD_CONF_NAME)); - strcpy(ldconfname, stdlib); - strcat(ldconfname, "/" LD_CONF_NAME); + ldconfname = caml_strconcat(3, stdlib, "/", LD_CONF_NAME); if (stat(ldconfname, &st) == -1) { caml_stat_free(ldconfname); return NULL; @@ -121,7 +120,9 @@ realname = caml_search_dll_in_path(&caml_shared_libs_path, name); caml_gc_message(0x100, "Loading shared library %s\n", (uintnat) realname); + caml_enter_blocking_section(); handle = caml_dlopen(realname, 1, 1); + caml_leave_blocking_section(); if (handle == NULL) caml_fatal_error_arg2("Fatal error: cannot load shared library %s\n", name, "Reason: %s\n", caml_dlerror()); @@ -204,10 +205,15 @@ { void * handle; value result; + char * p; caml_gc_message(0x100, "Opening shared library %s\n", (uintnat) String_val(filename)); - handle = caml_dlopen(String_val(filename), Int_val(mode), 1); + p = caml_strdup(String_val(filename)); + caml_enter_blocking_section(); + handle = caml_dlopen(p, Int_val(mode), 1); + caml_leave_blocking_section(); + caml_stat_free(p); if (handle == NULL) caml_failwith(caml_dlerror()); result = caml_alloc_small(1, Abstract_tag); Handle_val(result) = handle; diff -Nru ocaml-4.01.0/byterun/dynlink.h ocaml-4.02.3/byterun/dynlink.h --- ocaml-4.01.0/byterun/dynlink.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/dynlink.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,36 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Dynamic loading of C primitives. */ - -#ifndef CAML_DYNLINK_H -#define CAML_DYNLINK_H - -#include "misc.h" - -/* Build the table of primitives, given a search path, a list - of shared libraries, and a list of primitive names - (all three 0-separated in char arrays). - Abort the runtime system on error. */ -extern void caml_build_primitive_table(char * lib_path, - char * libs, - char * req_prims); - -/* The search path for shared libraries */ -extern struct ext_table caml_shared_libs_path; - -/* Build the table of primitives as a copy of the builtin primitive table. - Used for executables generated by ocamlc -output-obj. */ -extern void caml_build_primitive_table_builtin(void); - -#endif /* CAML_DYNLINK_H */ diff -Nru ocaml-4.01.0/byterun/exec.h ocaml-4.02.3/byterun/exec.h --- ocaml-4.01.0/byterun/exec.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/exec.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,60 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* exec.h : format of executable bytecode files */ - -#ifndef CAML_EXEC_H -#define CAML_EXEC_H - -/* Executable bytecode files are composed of a number of sections, - identified by 4-character names. A table of contents at the - end of the file lists the section names along with their sizes, - in the order in which they appear in the file: - - offset 0 ---> initial junk - data for section 1 - data for section 2 - ... - data for section N - table of contents: - descriptor for section 1 - ... - descriptor for section N - trailer - end of file ---> -*/ - -/* Structure of t.o.c. entries - Numerical quantities are 32-bit unsigned integers, big endian */ - -struct section_descriptor { - char name[4]; /* Section name */ - uint32 len; /* Length of data in bytes */ -}; - -/* Structure of the trailer. */ - -struct exec_trailer { - uint32 num_sections; /* Number of sections */ - char magic[12]; /* The magic number */ - struct section_descriptor * section; /* Not part of file */ -}; - -#define TRAILER_SIZE (4+12) - -/* Magic number for this release */ - -#define EXEC_MAGIC "Caml1999X008" - - -#endif /* CAML_EXEC_H */ diff -Nru ocaml-4.01.0/byterun/extern.c ocaml-4.02.3/byterun/extern.c --- ocaml-4.01.0/byterun/extern.c 2013-07-23 16:48:47.000000000 +0200 +++ ocaml-4.02.3/byterun/extern.c 2015-04-12 11:03:39.000000000 +0200 @@ -13,20 +13,20 @@ /* Structured output */ -/* The interface of this file is "intext.h" */ +/* The interface of this file is "caml/intext.h" */ #include -#include "alloc.h" -#include "custom.h" -#include "fail.h" -#include "gc.h" -#include "intext.h" -#include "io.h" -#include "md5.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "reverse.h" +#include "caml/alloc.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/gc.h" +#include "caml/intext.h" +#include "caml/io.h" +#include "caml/md5.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/reverse.h" static uintnat obj_counter; /* Number of objects emitted so far */ static uintnat size_32; /* Size in words of 32-bit block for struct. */ diff -Nru ocaml-4.01.0/byterun/fail.c ocaml-4.02.3/byterun/fail.c --- ocaml-4.01.0/byterun/fail.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/fail.c 2015-04-12 11:03:39.000000000 +0200 @@ -15,16 +15,16 @@ #include #include -#include "alloc.h" -#include "fail.h" -#include "io.h" -#include "gc.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "printexc.h" -#include "signals.h" -#include "stacks.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/io.h" +#include "caml/gc.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/printexc.h" +#include "caml/signals.h" +#include "caml/stacks.h" CAMLexport struct longjmp_buffer * caml_external_raise = NULL; value caml_exn_bucket; @@ -39,13 +39,7 @@ CAMLexport void caml_raise_constant(value tag) { - CAMLparam1 (tag); - CAMLlocal1 (bucket); - - bucket = caml_alloc_small (1, 0); - Field(bucket, 0) = tag; - caml_raise(bucket); - CAMLnoreturn; + caml_raise(tag); } CAMLexport void caml_raise_with_arg(value tag, value arg) @@ -77,11 +71,9 @@ CAMLexport void caml_raise_with_string(value tag, char const *msg) { - CAMLparam1 (tag); - CAMLlocal1 (vmsg); - - vmsg = caml_copy_string(msg); - caml_raise_with_arg(tag, vmsg); + CAMLparam1(tag); + value v_msg = caml_copy_string(msg); + caml_raise_with_arg(tag, v_msg); CAMLnoreturn; } @@ -111,21 +103,9 @@ caml_invalid_argument("index out of bounds"); } -/* Problem: we can't use [caml_raise_constant], because it allocates and - we're out of memory... Here, we allocate statically the exn bucket - for [Out_of_memory]. */ - -static struct { - header_t hdr; - value exn; -} out_of_memory_bucket = { 0, 0 }; - CAMLexport void caml_raise_out_of_memory(void) { - if (out_of_memory_bucket.exn == 0) - caml_fatal_error - ("Fatal error: out of memory while raising Out_of_memory\n"); - caml_raise((value) &(out_of_memory_bucket.exn)); + caml_raise_constant(Field(caml_global_data, OUT_OF_MEMORY_EXN)); } CAMLexport void caml_raise_stack_overflow(void) @@ -158,15 +138,6 @@ caml_raise_constant(Field(caml_global_data, SYS_BLOCKED_IO)); } -/* Initialization of statically-allocated exception buckets */ - -void caml_init_exceptions(void) -{ - out_of_memory_bucket.hdr = Make_header(1, 0, Caml_white); - out_of_memory_bucket.exn = Field(caml_global_data, OUT_OF_MEMORY_EXN); - caml_register_global_root(&out_of_memory_bucket.exn); -} - int caml_is_special_exception(value exn) { return exn == Field(caml_global_data, MATCH_FAILURE_EXN) || exn == Field(caml_global_data, ASSERT_FAILURE_EXN) diff -Nru ocaml-4.01.0/byterun/fail.h ocaml-4.02.3/byterun/fail.h --- ocaml-4.01.0/byterun/fail.h 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/byterun/fail.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,85 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_FAIL_H -#define CAML_FAIL_H - -/* */ -#include -/* */ - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "misc.h" -#include "mlvalues.h" - -/* */ -#define OUT_OF_MEMORY_EXN 0 /* "Out_of_memory" */ -#define SYS_ERROR_EXN 1 /* "Sys_error" */ -#define FAILURE_EXN 2 /* "Failure" */ -#define INVALID_EXN 3 /* "Invalid_argument" */ -#define END_OF_FILE_EXN 4 /* "End_of_file" */ -#define ZERO_DIVIDE_EXN 5 /* "Division_by_zero" */ -#define NOT_FOUND_EXN 6 /* "Not_found" */ -#define MATCH_FAILURE_EXN 7 /* "Match_failure" */ -#define STACK_OVERFLOW_EXN 8 /* "Stack_overflow" */ -#define SYS_BLOCKED_IO 9 /* "Sys_blocked_io" */ -#define ASSERT_FAILURE_EXN 10 /* "Assert_failure" */ -#define UNDEFINED_RECURSIVE_MODULE_EXN 11 /* "Undefined_recursive_module" */ - -#ifdef POSIX_SIGNALS -struct longjmp_buffer { - sigjmp_buf buf; -}; -#else -struct longjmp_buffer { - jmp_buf buf; -}; -#define sigsetjmp(buf,save) setjmp(buf) -#define siglongjmp(buf,val) longjmp(buf,val) -#endif - -CAMLextern struct longjmp_buffer * caml_external_raise; -extern value caml_exn_bucket; -int caml_is_special_exception(value exn); - -/* */ - -#ifdef __cplusplus -extern "C" { -#endif - -CAMLextern void caml_raise (value bucket) Noreturn; -CAMLextern void caml_raise_constant (value tag) Noreturn; -CAMLextern void caml_raise_with_arg (value tag, value arg) Noreturn; -CAMLextern void caml_raise_with_args (value tag, int nargs, value arg[]) - Noreturn; -CAMLextern void caml_raise_with_string (value tag, char const * msg) Noreturn; -CAMLextern void caml_failwith (char const *) Noreturn; -CAMLextern void caml_invalid_argument (char const *) Noreturn; -CAMLextern void caml_raise_out_of_memory (void) Noreturn; -CAMLextern void caml_raise_stack_overflow (void) Noreturn; -CAMLextern void caml_raise_sys_error (value) Noreturn; -CAMLextern void caml_raise_end_of_file (void) Noreturn; -CAMLextern void caml_raise_zero_divide (void) Noreturn; -CAMLextern void caml_raise_not_found (void) Noreturn; -CAMLextern void caml_init_exceptions (void); -CAMLextern void caml_array_bound_error (void) Noreturn; -CAMLextern void caml_raise_sys_blocked_io (void) Noreturn; - -#ifdef __cplusplus -} -#endif - -#endif /* CAML_FAIL_H */ diff -Nru ocaml-4.01.0/byterun/finalise.c ocaml-4.02.3/byterun/finalise.c --- ocaml-4.01.0/byterun/finalise.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/finalise.c 2015-07-20 16:46:48.000000000 +0200 @@ -13,11 +13,11 @@ /* Handling of finalised values. */ -#include "callback.h" -#include "fail.h" -#include "mlvalues.h" -#include "roots.h" -#include "signals.h" +#include "caml/callback.h" +#include "caml/fail.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/signals.h" struct final { value fun; @@ -125,6 +125,7 @@ if (running_finalisation_function) return; if (to_do_hd != NULL){ + if (caml_finalise_begin_hook != NULL) (*caml_finalise_begin_hook) (); caml_gc_message (0x80, "Calling finalisation functions.\n", 0); while (1){ while (to_do_hd != NULL && to_do_hd->size == 0){ @@ -143,6 +144,7 @@ if (Is_exception_result (res)) caml_raise (Extract_exception (res)); } caml_gc_message (0x80, "Done calling finalisation functions.\n", 0); + if (caml_finalise_end_hook != NULL) (*caml_finalise_end_hook) (); } } diff -Nru ocaml-4.01.0/byterun/finalise.h ocaml-4.02.3/byterun/finalise.h --- ocaml-4.01.0/byterun/finalise.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/finalise.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,27 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Moscova, INRIA Rocquencourt */ -/* */ -/* Copyright 2000 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_FINALISE_H -#define CAML_FINALISE_H - -#include "roots.h" - -void caml_final_update (void); -void caml_final_do_calls (void); -void caml_final_do_strong_roots (scanning_action f); -void caml_final_do_weak_roots (scanning_action f); -void caml_final_do_young_roots (scanning_action f); -void caml_final_empty_young (void); -value caml_final_register (value f, value v); - -#endif /* CAML_FINALISE_H */ diff -Nru ocaml-4.01.0/byterun/fix_code.c ocaml-4.02.3/byterun/fix_code.c --- ocaml-4.01.0/byterun/fix_code.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/fix_code.c 2015-04-12 11:03:39.000000000 +0200 @@ -13,21 +13,21 @@ /* Handling of blocks of bytecode (endianness switch, threading). */ -#include "config.h" +#include "caml/config.h" #ifdef HAS_UNISTD #include #endif -#include "debugger.h" -#include "fix_code.h" -#include "instruct.h" -#include "intext.h" -#include "md5.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "reverse.h" +#include "caml/debugger.h" +#include "caml/fix_code.h" +#include "caml/instruct.h" +#include "caml/intext.h" +#include "caml/md5.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/reverse.h" code_t caml_start_code; asize_t caml_code_size; @@ -95,37 +95,48 @@ char ** caml_instr_table; char * caml_instr_base; -void caml_thread_code (code_t code, asize_t len) +static int* opcode_nargs = NULL; +int* caml_init_opcode_nargs() { - code_t p; - int l [STOP + 1]; - int i; + if( opcode_nargs == NULL ){ + int* l = (int*)caml_stat_alloc(sizeof(int) * FIRST_UNIMPLEMENTED_OP); + int i; - for (i = 0; i <= STOP; i++) { - l [i] = 0; + for (i = 0; i < FIRST_UNIMPLEMENTED_OP; i++) { + l [i] = 0; + } + /* Instructions with one operand */ + l[PUSHACC] = l[ACC] = l[POP] = l[ASSIGN] = + l[PUSHENVACC] = l[ENVACC] = l[PUSH_RETADDR] = l[APPLY] = + l[APPTERM1] = l[APPTERM2] = l[APPTERM3] = l[RETURN] = + l[GRAB] = l[PUSHGETGLOBAL] = l[GETGLOBAL] = l[SETGLOBAL] = + l[PUSHATOM] = l[ATOM] = l[MAKEBLOCK1] = l[MAKEBLOCK2] = + l[MAKEBLOCK3] = l[MAKEFLOATBLOCK] = l[GETFIELD] = + l[GETFLOATFIELD] = l[SETFIELD] = l[SETFLOATFIELD] = + l[BRANCH] = l[BRANCHIF] = l[BRANCHIFNOT] = l[PUSHTRAP] = + l[C_CALL1] = l[C_CALL2] = l[C_CALL3] = l[C_CALL4] = l[C_CALL5] = + l[CONSTINT] = l[PUSHCONSTINT] = l[OFFSETINT] = + l[OFFSETREF] = l[OFFSETCLOSURE] = l[PUSHOFFSETCLOSURE] = 1; + + /* Instructions with two operands */ + l[APPTERM] = l[CLOSURE] = l[PUSHGETGLOBALFIELD] = + l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] = + l[BEQ] = l[BNEQ] = l[BLTINT] = l[BLEINT] = l[BGTINT] = l[BGEINT] = + l[BULTINT] = l[BUGEINT] = l[GETPUBMET] = 2; + + opcode_nargs = l; } - /* Instructions with one operand */ - l[PUSHACC] = l[ACC] = l[POP] = l[ASSIGN] = - l[PUSHENVACC] = l[ENVACC] = l[PUSH_RETADDR] = l[APPLY] = - l[APPTERM1] = l[APPTERM2] = l[APPTERM3] = l[RETURN] = - l[GRAB] = l[PUSHGETGLOBAL] = l[GETGLOBAL] = l[SETGLOBAL] = - l[PUSHATOM] = l[ATOM] = l[MAKEBLOCK1] = l[MAKEBLOCK2] = - l[MAKEBLOCK3] = l[MAKEFLOATBLOCK] = l[GETFIELD] = - l[GETFLOATFIELD] = l[SETFIELD] = l[SETFLOATFIELD] = - l[BRANCH] = l[BRANCHIF] = l[BRANCHIFNOT] = l[PUSHTRAP] = - l[C_CALL1] = l[C_CALL2] = l[C_CALL3] = l[C_CALL4] = l[C_CALL5] = - l[CONSTINT] = l[PUSHCONSTINT] = l[OFFSETINT] = - l[OFFSETREF] = l[OFFSETCLOSURE] = l[PUSHOFFSETCLOSURE] = 1; - - /* Instructions with two operands */ - l[APPTERM] = l[CLOSURE] = l[PUSHGETGLOBALFIELD] = - l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] = - l[BEQ] = l[BNEQ] = l[BLTINT] = l[BLEINT] = l[BGTINT] = l[BGEINT] = - l[BULTINT] = l[BUGEINT] = l[GETPUBMET] = 2; + return opcode_nargs; +} + +void caml_thread_code (code_t code, asize_t len) +{ + code_t p; + int* l = caml_init_opcode_nargs(); len /= sizeof(opcode_t); for (p = code; p < code + len; /*nothing*/) { opcode_t instr = *p; - if (instr < 0 || instr > STOP){ + if (instr < 0 || instr >= FIRST_UNIMPLEMENTED_OP){ /* FIXME -- should Assert(false) ? caml_fatal_error_arg ("Fatal error in fix_code: bad opcode (%lx)\n", (char *)(long)instr); @@ -149,6 +160,13 @@ Assert(p == code + len); } +#else + +int* caml_init_opcode_nargs() +{ + return NULL; +} + #endif /* THREADED_CODE */ void caml_set_instruction(code_t pos, opcode_t instr) diff -Nru ocaml-4.01.0/byterun/fix_code.h ocaml-4.02.3/byterun/fix_code.h --- ocaml-4.01.0/byterun/fix_code.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/fix_code.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,40 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Handling of blocks of bytecode (endianness switch, threading). */ - -#ifndef CAML_FIX_CODE_H -#define CAML_FIX_CODE_H - - -#include "config.h" -#include "misc.h" -#include "mlvalues.h" - -extern code_t caml_start_code; -extern asize_t caml_code_size; -extern unsigned char * caml_saved_code; - -void caml_init_code_fragments(); -void caml_load_code (int fd, asize_t len); -void caml_fixup_endianness (code_t code, asize_t len); -void caml_set_instruction (code_t pos, opcode_t instr); -int caml_is_instruction (opcode_t instr1, opcode_t instr2); - -#ifdef THREADED_CODE -extern char ** caml_instr_table; -extern char * caml_instr_base; -void caml_thread_code (code_t code, asize_t len); -#endif - -#endif /* CAML_FIX_CODE_H */ diff -Nru ocaml-4.01.0/byterun/floats.c ocaml-4.02.3/byterun/floats.c --- ocaml-4.01.0/byterun/floats.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/floats.c 2015-06-02 17:16:56.000000000 +0200 @@ -11,20 +11,20 @@ /* */ /***********************************************************************/ -/* The interface of this file is in "mlvalues.h" and "alloc.h" */ +/* The interface of this file is in "caml/mlvalues.h" and "caml/alloc.h" */ #include #include #include #include -#include "alloc.h" -#include "fail.h" -#include "memory.h" -#include "mlvalues.h" -#include "misc.h" -#include "reverse.h" -#include "stacks.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/misc.h" +#include "caml/reverse.h" +#include "caml/stacks.h" #ifdef _MSC_VER #include @@ -71,68 +71,29 @@ CAMLprim value caml_format_float(value fmt, value arg) { -#define MAX_DIGITS 350 -/* Max number of decimal digits in a "natural" (not artificially padded) - representation of a float. Can be quite big for %f format. - Max exponent for IEEE format is 308 decimal digits. - Rounded up for good measure. */ - char format_buffer[MAX_DIGITS + 20]; - int prec, i; - char * p; - char * dest; value res; double d = Double_val(arg); #ifdef HAS_BROKEN_PRINTF if (isfinite(d)) { #endif - prec = MAX_DIGITS; - for (p = String_val(fmt); *p != 0; p++) { - if (*p >= '0' && *p <= '9') { - i = atoi(p) + MAX_DIGITS; - if (i > prec) prec = i; - break; - } - } - for( ; *p != 0; p++) { - if (*p == '.') { - i = atoi(p+1) + MAX_DIGITS; - if (i > prec) prec = i; - break; - } - } - if (prec < sizeof(format_buffer)) { - dest = format_buffer; - } else { - dest = caml_stat_alloc(prec); - } - sprintf(dest, String_val(fmt), d); - res = caml_copy_string(dest); - if (dest != format_buffer) { - caml_stat_free(dest); - } + res = caml_alloc_sprintf(String_val(fmt), d); #ifdef HAS_BROKEN_PRINTF } else { - if (isnan(d)) - { + if (isnan(d)) { res = caml_copy_string("nan"); - } - else - { + } else { if (d > 0) - { res = caml_copy_string("inf"); - } else - { res = caml_copy_string("-inf"); - } } } #endif return res; } +#if 0 /*CAMLprim*/ value caml_float_of_substring(value vs, value idx, value l) { char parse_buffer[64]; @@ -163,6 +124,7 @@ if (buf != parse_buffer) caml_stat_free(buf); caml_failwith("float_of_string"); } +#endif CAMLprim value caml_float_of_string(value vs) { @@ -188,6 +150,7 @@ error: if (buf != parse_buffer) caml_stat_free(buf); caml_failwith("float_of_string"); + return Val_unit; /* not reached */ } CAMLprim value caml_int_of_float(value f) @@ -490,7 +453,8 @@ CAMLprim value caml_classify_float(value vd) { /* Cygwin 1.3 has problems with fpclassify (PR#1293), so don't use it */ -#if defined(fpclassify) && !defined(__CYGWIN32__) && !defined(__MINGW32__) + /* FIXME Cygwin 1.3 is ancient! Revisit this decision. */ +#if defined(fpclassify) && !defined(__CYGWIN__) && !defined(__MINGW32__) switch (fpclassify(Double_val(vd))) { case FP_NAN: return Val_int(FP_nan); diff -Nru ocaml-4.01.0/byterun/freelist.c ocaml-4.02.3/byterun/freelist.c --- ocaml-4.01.0/byterun/freelist.c 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/byterun/freelist.c 2015-04-12 11:03:39.000000000 +0200 @@ -18,14 +18,14 @@ #include -#include "config.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "memory.h" -#include "major_gc.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/config.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/memory.h" +#include "caml/major_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" /* The free-list is kept sorted by increasing addresses. This makes the merging of adjacent free blocks possible. diff -Nru ocaml-4.01.0/byterun/freelist.h ocaml-4.02.3/byterun/freelist.h --- ocaml-4.01.0/byterun/freelist.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/freelist.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,34 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Free lists of heap blocks. */ - -#ifndef CAML_FREELIST_H -#define CAML_FREELIST_H - - -#include "misc.h" -#include "mlvalues.h" - -extern asize_t caml_fl_cur_size; /* size in words */ - -char *caml_fl_allocate (mlsize_t); -void caml_fl_init_merge (void); -void caml_fl_reset (void); -char *caml_fl_merge_block (char *); -void caml_fl_add_blocks (char *); -void caml_make_free_blocks (value *, mlsize_t, int, int); -void caml_set_allocation_policy (uintnat); - - -#endif /* CAML_FREELIST_H */ diff -Nru ocaml-4.01.0/byterun/gc_ctrl.c ocaml-4.02.3/byterun/gc_ctrl.c --- ocaml-4.01.0/byterun/gc_ctrl.c 2013-07-17 13:50:53.000000000 +0200 +++ ocaml-4.02.3/byterun/gc_ctrl.c 2015-04-12 11:03:39.000000000 +0200 @@ -11,21 +11,21 @@ /* */ /***********************************************************************/ -#include "alloc.h" -#include "compact.h" -#include "custom.h" -#include "finalise.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "major_gc.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/alloc.h" +#include "caml/compact.h" +#include "caml/custom.h" +#include "caml/finalise.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/major_gc.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" #ifdef NATIVE_CODE #include "stack.h" #else -#include "stacks.h" +#include "caml/stacks.h" #endif #ifndef NATIVE_CODE @@ -43,10 +43,10 @@ caml_stat_compactions = 0, caml_stat_heap_chunks = 0; -extern uintnat caml_major_heap_increment; /* bytes; see major_gc.c */ -extern uintnat caml_percent_free; /* see major_gc.c */ -extern uintnat caml_percent_max; /* see compact.c */ -extern uintnat caml_allocation_policy; /* see freelist.c */ +extern uintnat caml_major_heap_increment; /* percent or words; see major_gc.c */ +extern uintnat caml_percent_free; /* see major_gc.c */ +extern uintnat caml_percent_max; /* see compact.c */ +extern uintnat caml_allocation_policy; /* see freelist.c */ #define Next(hp) ((hp) + Bhsize_hp (hp)) @@ -321,7 +321,7 @@ res = caml_alloc_tuple (7); Store_field (res, 0, Val_long (Wsize_bsize (caml_minor_heap_size))); /* s */ - Store_field (res, 1,Val_long(Wsize_bsize(caml_major_heap_increment)));/* i */ + Store_field (res, 1, Val_long (caml_major_heap_increment)); /* i */ Store_field (res, 2, Val_long (caml_percent_free)); /* o */ Store_field (res, 3, Val_long (caml_verb_gc)); /* v */ Store_field (res, 4, Val_long (caml_percent_max)); /* O */ @@ -346,14 +346,6 @@ return p; } -static intnat norm_heapincr (uintnat i) -{ -#define Psv (Wsize_bsize (Page_size)) - i = ((i + Psv - 1) / Psv) * Psv; - if (i < Heap_chunk_min) i = Heap_chunk_min; - return i; -} - static intnat norm_minsize (intnat s) { if (s < Minor_heap_min) s = Minor_heap_min; @@ -386,11 +378,16 @@ caml_gc_message (0x20, "New max overhead: %d%%\n", caml_percent_max); } - newheapincr = Bsize_wsize (norm_heapincr (Long_val (Field (v, 1)))); + newheapincr = Long_val (Field (v, 1)); if (newheapincr != caml_major_heap_increment){ caml_major_heap_increment = newheapincr; - caml_gc_message (0x20, "New heap increment size: %luk bytes\n", - caml_major_heap_increment/1024); + if (newheapincr > 1000){ + caml_gc_message (0x20, "New heap increment size: %luk words\n", + caml_major_heap_increment/1024); + }else{ + caml_gc_message (0x20, "New heap increment size: %lu%%\n", + caml_major_heap_increment); + } } oldpolicy = caml_allocation_policy; caml_set_allocation_policy (Long_val (Field (v, 6))); @@ -475,17 +472,26 @@ return Val_unit; } +uintnat caml_normalize_heap_increment (uintnat i) +{ + if (i < Bsize_wsize (Heap_chunk_min)){ + i = Bsize_wsize (Heap_chunk_min); + } + return ((i + Page_size - 1) >> Page_log) << Page_log; +} + void caml_init_gc (uintnat minor_size, uintnat major_size, uintnat major_incr, uintnat percent_fr, uintnat percent_m) { - uintnat major_heap_size = Bsize_wsize (norm_heapincr (major_size)); + uintnat major_heap_size = + Bsize_wsize (caml_normalize_heap_increment (major_size)); if (caml_page_table_initialize(Bsize_wsize(minor_size) + major_heap_size)){ caml_fatal_error ("OCaml runtime error: cannot initialize page table\n"); } caml_set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size))); - caml_major_heap_increment = Bsize_wsize (norm_heapincr (major_incr)); + caml_major_heap_increment = major_incr; caml_percent_free = norm_pfree (percent_fr); caml_percent_max = norm_pmax (percent_m); caml_init_major_heap (major_heap_size); @@ -495,8 +501,13 @@ major_heap_size / 1024); caml_gc_message (0x20, "Initial space overhead: %lu%%\n", caml_percent_free); caml_gc_message (0x20, "Initial max overhead: %lu%%\n", caml_percent_max); - caml_gc_message (0x20, "Initial heap increment: %luk bytes\n", - caml_major_heap_increment / 1024); + if (caml_major_heap_increment > 1000){ + caml_gc_message (0x20, "Initial heap increment: %luk words\n", + caml_major_heap_increment / 1024); + }else{ + caml_gc_message (0x20, "Initial heap increment: %lu%%\n", + caml_major_heap_increment); + } caml_gc_message (0x20, "Initial allocation policy: %d\n", caml_allocation_policy); } diff -Nru ocaml-4.01.0/byterun/gc_ctrl.h ocaml-4.02.3/byterun/gc_ctrl.h --- ocaml-4.01.0/byterun/gc_ctrl.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/gc_ctrl.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,40 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_GC_CTRL_H -#define CAML_GC_CTRL_H - -#include "misc.h" - -extern double - caml_stat_minor_words, - caml_stat_promoted_words, - caml_stat_major_words; - -extern intnat - caml_stat_minor_collections, - caml_stat_major_collections, - caml_stat_heap_size, - caml_stat_top_heap_size, - caml_stat_compactions, - caml_stat_heap_chunks; - -void caml_init_gc (uintnat, uintnat, uintnat, - uintnat, uintnat); - - -#ifdef DEBUG -void caml_heap_check (void); -#endif - -#endif /* CAML_GC_CTRL_H */ diff -Nru ocaml-4.01.0/byterun/gc.h ocaml-4.02.3/byterun/gc.h --- ocaml-4.01.0/byterun/gc.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/gc.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,56 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_GC_H -#define CAML_GC_H - - -#include "mlvalues.h" - -#define Caml_white (0 << 8) -#define Caml_gray (1 << 8) -#define Caml_blue (2 << 8) -#define Caml_black (3 << 8) - -#define Color_hd(hd) ((color_t) ((hd) & Caml_black)) -#define Color_hp(hp) (Color_hd (Hd_hp (hp))) -#define Color_val(val) (Color_hd (Hd_val (val))) - -#define Is_white_hd(hd) (Color_hd (hd) == Caml_white) -#define Is_gray_hd(hd) (Color_hd (hd) == Caml_gray) -#define Is_blue_hd(hd) (Color_hd (hd) == Caml_blue) -#define Is_black_hd(hd) (Color_hd (hd) == Caml_black) - -#define Whitehd_hd(hd) (((hd) & ~Caml_black)/*| Caml_white*/) -#define Grayhd_hd(hd) (((hd) & ~Caml_black) | Caml_gray) -#define Blackhd_hd(hd) (((hd)/*& ~Caml_black*/)| Caml_black) -#define Bluehd_hd(hd) (((hd) & ~Caml_black) | Caml_blue) - -/* This depends on the layout of the header. See [mlvalues.h]. */ -#define Make_header(wosize, tag, color) \ - (/*Assert ((wosize) <= Max_wosize),*/ \ - ((header_t) (((header_t) (wosize) << 10) \ - + (color) \ - + (tag_t) (tag))) \ - ) - -#define Is_white_val(val) (Color_val(val) == Caml_white) -#define Is_gray_val(val) (Color_val(val) == Caml_gray) -#define Is_blue_val(val) (Color_val(val) == Caml_blue) -#define Is_black_val(val) (Color_val(val) == Caml_black) - -/* For extern.c */ -#define Colornum_hd(hd) ((color_t) (((hd) >> 8) & 3)) -#define Coloredhd_hd(hd,colnum) (((hd) & ~Caml_black) | ((colnum) << 8)) - -#endif /* CAML_GC_H */ diff -Nru ocaml-4.01.0/byterun/globroots.c ocaml-4.02.3/byterun/globroots.c --- ocaml-4.01.0/byterun/globroots.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/globroots.c 2015-04-12 11:03:39.000000000 +0200 @@ -13,11 +13,11 @@ /* Registration of global memory roots */ -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "roots.h" -#include "globroots.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/globroots.h" /* The sets of global memory roots are represented as skip lists (see William Pugh, "Skip lists: a probabilistic alternative to diff -Nru ocaml-4.01.0/byterun/globroots.h ocaml-4.02.3/byterun/globroots.h --- ocaml-4.01.0/byterun/globroots.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/globroots.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,25 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2001 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Registration of global memory roots */ - -#ifndef CAML_GLOBROOTS_H -#define CAML_GLOBROOTS_H - -#include "mlvalues.h" -#include "roots.h" - -void caml_scan_global_roots(scanning_action f); -void caml_scan_global_young_roots(scanning_action f); - -#endif /* CAML_GLOBROOTS_H */ diff -Nru ocaml-4.01.0/byterun/hash.c ocaml-4.02.3/byterun/hash.c --- ocaml-4.01.0/byterun/hash.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/hash.c 2015-04-12 11:03:39.000000000 +0200 @@ -16,16 +16,10 @@ /* The interface of this file is in "mlvalues.h" (for [caml_hash_variant]) and in "hash.h" (for the other exported functions). */ -#include "mlvalues.h" -#include "custom.h" -#include "memory.h" -#include "hash.h" - -#ifdef ARCH_INT64_TYPE -#include "int64_native.h" -#else -#include "int64_emul.h" -#endif +#include "caml/mlvalues.h" +#include "caml/custom.h" +#include "caml/memory.h" +#include "caml/hash.h" /* The new implementation, based on MurmurHash 3, http://code.google.com/p/smhasher/ */ @@ -77,9 +71,7 @@ CAMLexport uint32 caml_hash_mix_int64(uint32 h, int64 d) { - uint32 hi, lo; - - I64_split(d, hi, lo); + uint32 hi = (uint32) (d >> 32), lo = (uint32) d; MIX(h, lo); MIX(h, hi); return h; @@ -180,6 +172,8 @@ /* Maximal size of the queue used for breadth-first traversal. */ #define HASH_QUEUE_SIZE 256 +/* Maximal number of Forward_tag links followed in one step */ +#define MAX_FORWARD_DEREFERENCE 1000 /* The generic hash function */ @@ -221,7 +215,7 @@ for (i = 0, len = Wosize_val(v) / Double_wosize; i < len; i++) { h = caml_hash_mix_double(h, Double_field(v, i)); num--; - if (num < 0) break; + if (num <= 0) break; } break; case Abstract_tag: @@ -234,8 +228,15 @@ v = v - Infix_offset_val(v); goto again; case Forward_tag: - v = Forward_val(v); - goto again; + /* PR#6361: we can have a loop here, so limit the number of + Forward_tag links being followed */ + for (i = MAX_FORWARD_DEREFERENCE; i > 0; i--) { + v = Forward_val(v); + if (Is_long(v) || !Is_in_value_area(v) || Tag_val(v) != Forward_tag) + goto again; + } + /* Give up on this object and move to the next */ + break; case Object_tag: h = caml_hash_mix_intnat(h, Oid_val(v)); num--; diff -Nru ocaml-4.01.0/byterun/hash.h ocaml-4.02.3/byterun/hash.h --- ocaml-4.01.0/byterun/hash.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/hash.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,29 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ -/* */ -/* Copyright 2011 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Auxiliary functions for custom hash functions */ - -#ifndef CAML_HASH_H -#define CAML_HASH_H - -#include "mlvalues.h" - -CAMLextern uint32 caml_hash_mix_uint32(uint32 h, uint32 d); -CAMLextern uint32 caml_hash_mix_intnat(uint32 h, intnat d); -CAMLextern uint32 caml_hash_mix_int64(uint32 h, int64 d); -CAMLextern uint32 caml_hash_mix_double(uint32 h, double d); -CAMLextern uint32 caml_hash_mix_float(uint32 h, float d); -CAMLextern uint32 caml_hash_mix_string(uint32 h, value s); - - -#endif diff -Nru ocaml-4.01.0/byterun/.ignore ocaml-4.02.3/byterun/.ignore --- ocaml-4.01.0/byterun/.ignore 2012-07-26 21:21:54.000000000 +0200 +++ ocaml-4.02.3/byterun/.ignore 2015-04-12 11:03:39.000000000 +0200 @@ -1,8 +1,8 @@ -jumptbl.h +caml/jumptbl.h primitives prims.c -opnames.h -version.h +caml/opnames.h +caml/version.h ocamlrun ocamlrun.exe ocamlrund diff -Nru ocaml-4.01.0/byterun/instrtrace.c ocaml-4.02.3/byterun/instrtrace.c --- ocaml-4.01.0/byterun/instrtrace.c 2013-03-22 19:36:22.000000000 +0100 +++ ocaml-4.02.3/byterun/instrtrace.c 2015-04-12 11:03:39.000000000 +0200 @@ -19,12 +19,12 @@ #include #include -#include "instruct.h" -#include "misc.h" -#include "mlvalues.h" -#include "opnames.h" -#include "prims.h" -#include "stacks.h" +#include "caml/instruct.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/opnames.h" +#include "caml/prims.h" +#include "caml/stacks.h" extern code_t caml_start_code; @@ -84,7 +84,7 @@ char *nam; nam = (instr < 0 || instr > STOP) - ? (sprintf (nambuf, "???%d", instr), nambuf) + ? (snprintf (nambuf, sizeof(nambuf), "???%d", instr), nambuf) : names_of_instructions[instr]; pc++; switch (instr) { @@ -125,7 +125,7 @@ case OFFSETREF: case OFFSETCLOSURE: case PUSHOFFSETCLOSURE: - sprintf(buf, "%s %d", nam, pc[0]); + snprintf(buf, sizeof(buf), "%s %d", nam, pc[0]); break; /* Instructions with two operands */ case APPTERM: @@ -142,16 +142,16 @@ case BGEINT: case BULTINT: case BUGEINT: - sprintf(buf, "%s %d, %d", nam, pc[0], pc[1]); + snprintf(buf, sizeof(buf), "%s %d, %d", nam, pc[0], pc[1]); break; case SWITCH: - sprintf(buf, "SWITCH sz%#lx=%ld::ntag%ld nint%ld", + snprintf(buf, sizeof(buf), "SWITCH sz%#lx=%ld::ntag%ld nint%ld", (long) pc[0], (long) pc[0], (unsigned long) pc[0] >> 16, (unsigned long) pc[0] & 0xffff); break; /* Instructions with a C primitive as operand */ case C_CALLN: - sprintf(buf, "%s %d,", nam, pc[0]); + snprintf(buf, sizeof(buf), "%s %d,", nam, pc[0]); pc++; /* fallthrough */ case C_CALL1: @@ -160,12 +160,13 @@ case C_CALL4: case C_CALL5: if (pc[0] < 0 || pc[0] >= caml_prim_name_table.size) - sprintf(buf, "%s unknown primitive %d", nam, pc[0]); + snprintf(buf, sizeof(buf), "%s unknown primitive %d", nam, pc[0]); else - sprintf(buf, "%s %s", nam, (char *) caml_prim_name_table.contents[pc[0]]); + snprintf(buf, sizeof(buf), "%s %s", + nam, (char *) caml_prim_name_table.contents[pc[0]]); break; default: - sprintf(buf, "%s", nam); + snprintf(buf, sizeof(buf), "%s", nam); break; }; return buf; diff -Nru ocaml-4.01.0/byterun/instrtrace.h ocaml-4.02.3/byterun/instrtrace.h --- ocaml-4.01.0/byterun/instrtrace.h 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/byterun/instrtrace.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,30 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Trace the instructions executed */ - -#ifndef _instrtrace_ -#define _instrtrace_ - - -#include "mlvalues.h" -#include "misc.h" - -extern int caml_trace_flag; -extern intnat caml_icount; -void caml_stop_here (void); -void caml_disasm_instr (code_t pc); -void caml_trace_value_file (value v, code_t prog, int proglen, FILE * f); -void caml_trace_accu_sp_file(value accu, value * sp, code_t prog, int proglen, - FILE * f); -#endif diff -Nru ocaml-4.01.0/byterun/instruct.h ocaml-4.02.3/byterun/instruct.h --- ocaml-4.01.0/byterun/instruct.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/instruct.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,59 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* The instruction set. */ - -#ifndef CAML_INSTRUCT_H -#define CAML_INSTRUCT_H - -enum instructions { - ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, - ACC, PUSH, - PUSHACC0, PUSHACC1, PUSHACC2, PUSHACC3, - PUSHACC4, PUSHACC5, PUSHACC6, PUSHACC7, - PUSHACC, POP, ASSIGN, - ENVACC1, ENVACC2, ENVACC3, ENVACC4, ENVACC, - PUSHENVACC1, PUSHENVACC2, PUSHENVACC3, PUSHENVACC4, PUSHENVACC, - PUSH_RETADDR, APPLY, APPLY1, APPLY2, APPLY3, - APPTERM, APPTERM1, APPTERM2, APPTERM3, - RETURN, RESTART, GRAB, - CLOSURE, CLOSUREREC, - OFFSETCLOSUREM2, OFFSETCLOSURE0, OFFSETCLOSURE2, OFFSETCLOSURE, - PUSHOFFSETCLOSUREM2, PUSHOFFSETCLOSURE0, - PUSHOFFSETCLOSURE2, PUSHOFFSETCLOSURE, - GETGLOBAL, PUSHGETGLOBAL, GETGLOBALFIELD, PUSHGETGLOBALFIELD, SETGLOBAL, - ATOM0, ATOM, PUSHATOM0, PUSHATOM, - MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3, MAKEFLOATBLOCK, - GETFIELD0, GETFIELD1, GETFIELD2, GETFIELD3, GETFIELD, GETFLOATFIELD, - SETFIELD0, SETFIELD1, SETFIELD2, SETFIELD3, SETFIELD, SETFLOATFIELD, - VECTLENGTH, GETVECTITEM, SETVECTITEM, - GETSTRINGCHAR, SETSTRINGCHAR, - BRANCH, BRANCHIF, BRANCHIFNOT, SWITCH, BOOLNOT, - PUSHTRAP, POPTRAP, RAISE, CHECK_SIGNALS, - C_CALL1, C_CALL2, C_CALL3, C_CALL4, C_CALL5, C_CALLN, - CONST0, CONST1, CONST2, CONST3, CONSTINT, - PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT, - NEGINT, ADDINT, SUBINT, MULINT, DIVINT, MODINT, - ANDINT, ORINT, XORINT, LSLINT, LSRINT, ASRINT, - EQ, NEQ, LTINT, LEINT, GTINT, GEINT, - OFFSETINT, OFFSETREF, ISINT, - GETMETHOD, - BEQ, BNEQ, BLTINT, BLEINT, BGTINT, BGEINT, - ULTINT, UGEINT, - BULTINT, BUGEINT, - GETPUBMET, GETDYNMET, - STOP, - EVENT, BREAK -}; - -#endif /* CAML_INSTRUCT_H */ diff -Nru ocaml-4.01.0/byterun/int64_emul.h ocaml-4.02.3/byterun/int64_emul.h --- ocaml-4.01.0/byterun/int64_emul.h 2012-11-29 10:55:00.000000000 +0100 +++ ocaml-4.02.3/byterun/int64_emul.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,287 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Software emulation of 64-bit integer arithmetic, for C compilers - that do not support it. */ - -#ifndef CAML_INT64_EMUL_H -#define CAML_INT64_EMUL_H - -#include - -#ifdef ARCH_BIG_ENDIAN -#define I64_literal(hi,lo) { hi, lo } -#else -#define I64_literal(hi,lo) { lo, hi } -#endif - -#define I64_split(x,hi,lo) (hi = (x).h, lo = (x).l) - -/* Unsigned comparison */ -static int I64_ucompare(uint64 x, uint64 y) -{ - if (x.h > y.h) return 1; - if (x.h < y.h) return -1; - if (x.l > y.l) return 1; - if (x.l < y.l) return -1; - return 0; -} - -#define I64_ult(x, y) (I64_ucompare(x, y) < 0) - -/* Signed comparison */ -static int I64_compare(int64 x, int64 y) -{ - if ((int32)x.h > (int32)y.h) return 1; - if ((int32)x.h < (int32)y.h) return -1; - if (x.l > y.l) return 1; - if (x.l < y.l) return -1; - return 0; -} - -/* Negation */ -static int64 I64_neg(int64 x) -{ - int64 res; - res.l = -x.l; - res.h = ~x.h; - if (res.l == 0) res.h++; - return res; -} - -/* Addition */ -static int64 I64_add(int64 x, int64 y) -{ - int64 res; - res.l = x.l + y.l; - res.h = x.h + y.h; - if (res.l < x.l) res.h++; - return res; -} - -/* Subtraction */ -static int64 I64_sub(int64 x, int64 y) -{ - int64 res; - res.l = x.l - y.l; - res.h = x.h - y.h; - if (x.l < y.l) res.h--; - return res; -} - -/* Multiplication */ -static int64 I64_mul(int64 x, int64 y) -{ - int64 res; - uint32 prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF); - uint32 prod10 = (x.l >> 16) * (y.l & 0xFFFF); - uint32 prod01 = (x.l & 0xFFFF) * (y.l >> 16); - uint32 prod11 = (x.l >> 16) * (y.l >> 16); - res.l = prod00; - res.h = prod11 + (prod01 >> 16) + (prod10 >> 16); - prod01 = prod01 << 16; res.l += prod01; if (res.l < prod01) res.h++; - prod10 = prod10 << 16; res.l += prod10; if (res.l < prod10) res.h++; - res.h += x.l * y.h + x.h * y.l; - return res; -} - -#define I64_is_zero(x) (((x).l | (x).h) == 0) -#define I64_is_negative(x) ((int32) (x).h < 0) -#define I64_is_min_int(x) ((x).l == 0 && (x).h == 0x80000000U) -#define I64_is_minus_one(x) (((x).l & (x).h) == 0xFFFFFFFFU) - -/* Bitwise operations */ -static int64 I64_and(int64 x, int64 y) -{ - int64 res; - res.l = x.l & y.l; - res.h = x.h & y.h; - return res; -} - -static int64 I64_or(int64 x, int64 y) -{ - int64 res; - res.l = x.l | y.l; - res.h = x.h | y.h; - return res; -} - -static int64 I64_xor(int64 x, int64 y) -{ - int64 res; - res.l = x.l ^ y.l; - res.h = x.h ^ y.h; - return res; -} - -/* Shifts */ -static int64 I64_lsl(int64 x, int s) -{ - int64 res; - s = s & 63; - if (s == 0) return x; - if (s < 32) { - res.l = x.l << s; - res.h = (x.h << s) | (x.l >> (32 - s)); - } else { - res.l = 0; - res.h = x.l << (s - 32); - } - return res; -} - -static int64 I64_lsr(int64 x, int s) -{ - int64 res; - s = s & 63; - if (s == 0) return x; - if (s < 32) { - res.l = (x.l >> s) | (x.h << (32 - s)); - res.h = x.h >> s; - } else { - res.l = x.h >> (s - 32); - res.h = 0; - } - return res; -} - -static int64 I64_asr(int64 x, int s) -{ - int64 res; - s = s & 63; - if (s == 0) return x; - if (s < 32) { - res.l = (x.l >> s) | (x.h << (32 - s)); - res.h = (int32) x.h >> s; - } else { - res.l = (int32) x.h >> (s - 32); - res.h = (int32) x.h >> 31; - } - return res; -} - -/* Division and modulus */ - -#define I64_SHL1(x) x.h = (x.h << 1) | (x.l >> 31); x.l <<= 1 -#define I64_SHR1(x) x.l = (x.l >> 1) | (x.h << 31); x.h >>= 1 - -static void I64_udivmod(uint64 modulus, uint64 divisor, - uint64 * quo, uint64 * mod) -{ - int64 quotient, mask; - int cmp; - - quotient.h = 0; quotient.l = 0; - mask.h = 0; mask.l = 1; - while ((int32) divisor.h >= 0) { - cmp = I64_ucompare(divisor, modulus); - I64_SHL1(divisor); - I64_SHL1(mask); - if (cmp >= 0) break; - } - while (mask.l | mask.h) { - if (I64_ucompare(modulus, divisor) >= 0) { - quotient.h |= mask.h; quotient.l |= mask.l; - modulus = I64_sub(modulus, divisor); - } - I64_SHR1(mask); - I64_SHR1(divisor); - } - *quo = quotient; - *mod = modulus; -} - -static int64 I64_div(int64 x, int64 y) -{ - int64 q, r; - int32 sign; - - sign = x.h ^ y.h; - if ((int32) x.h < 0) x = I64_neg(x); - if ((int32) y.h < 0) y = I64_neg(y); - I64_udivmod(x, y, &q, &r); - if (sign < 0) q = I64_neg(q); - return q; -} - -static int64 I64_mod(int64 x, int64 y) -{ - int64 q, r; - int32 sign; - - sign = x.h; - if ((int32) x.h < 0) x = I64_neg(x); - if ((int32) y.h < 0) y = I64_neg(y); - I64_udivmod(x, y, &q, &r); - if (sign < 0) r = I64_neg(r); - return r; -} - -/* Coercions */ - -static int64 I64_of_int32(int32 x) -{ - int64 res; - res.l = x; - res.h = x >> 31; - return res; -} - -#define I64_to_int32(x) ((int32) (x).l) - -/* Note: we assume sizeof(intnat) = 4 here, which is true otherwise - autoconfiguration would have selected native 64-bit integers */ -#define I64_of_intnat I64_of_int32 -#define I64_to_intnat I64_to_int32 - -static double I64_to_double(int64 x) -{ - double res; - int32 sign = x.h; - if (sign < 0) x = I64_neg(x); - res = ldexp((double) x.h, 32) + x.l; - if (sign < 0) res = -res; - return res; -} - -static int64 I64_of_double(double f) -{ - int64 res; - double frac, integ; - int neg; - - neg = (f < 0); - f = fabs(f); - frac = modf(ldexp(f, -32), &integ); - res.h = (uint32) integ; - res.l = (uint32) ldexp(frac, 32); - if (neg) res = I64_neg(res); - return res; -} - -static int64 I64_bswap(int64 x) -{ - int64 res; - res.h = (((x.l & 0x000000FF) << 24) | - ((x.l & 0x0000FF00) << 8) | - ((x.l & 0x00FF0000) >> 8) | - ((x.l & 0xFF000000) >> 24)); - res.l = (((x.h & 0x000000FF) << 24) | - ((x.h & 0x0000FF00) << 8) | - ((x.h & 0x00FF0000) >> 8) | - ((x.h & 0xFF000000) >> 24)); - return res; -} - -#endif /* CAML_INT64_EMUL_H */ diff -Nru ocaml-4.01.0/byterun/int64_format.h ocaml-4.02.3/byterun/int64_format.h --- ocaml-4.01.0/byterun/int64_format.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/int64_format.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,105 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* printf-like formatting of 64-bit integers, in case the C library - printf() function does not support them. */ - -#ifndef CAML_INT64_FORMAT_H -#define CAML_INT64_FORMAT_H - -static void I64_format(char * buffer, char * fmt, int64 x) -{ - static char conv_lower[] = "0123456789abcdef"; - static char conv_upper[] = "0123456789ABCDEF"; - char rawbuffer[24]; - char justify, signstyle, filler, alternate, signedconv; - int base, width, sign, i, rawlen; - char * cvtbl; - char * p, * r; - int64 wbase, digit; - - /* Parsing of format */ - justify = '+'; - signstyle = '-'; - filler = ' '; - alternate = 0; - base = 0; - signedconv = 0; - width = 0; - cvtbl = conv_lower; - for (p = fmt; *p != 0; p++) { - switch (*p) { - case '-': - justify = '-'; break; - case '+': case ' ': - signstyle = *p; break; - case '0': - filler = '0'; break; - case '#': - alternate = 1; break; - case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': - width = atoi(p); - while (p[1] >= '0' && p[1] <= '9') p++; - break; - case 'd': case 'i': - signedconv = 1; /* fallthrough */ - case 'u': - base = 10; break; - case 'x': - base = 16; break; - case 'X': - base = 16; cvtbl = conv_upper; break; - case 'o': - base = 8; break; - } - } - if (base == 0) { buffer[0] = 0; return; } - /* Do the conversion */ - sign = 1; - if (signedconv && I64_is_negative(x)) { sign = -1; x = I64_neg(x); } - r = rawbuffer + sizeof(rawbuffer); - wbase = I64_of_int32(base); - do { - I64_udivmod(x, wbase, &x, &digit); - *--r = cvtbl[I64_to_int32(digit)]; - } while (! I64_is_zero(x)); - rawlen = rawbuffer + sizeof(rawbuffer) - r; - /* Adjust rawlen to reflect additional chars (sign, etc) */ - if (signedconv && (sign < 0 || signstyle != '-')) rawlen++; - if (alternate) { - if (base == 8) rawlen += 1; - if (base == 16) rawlen += 2; - } - /* Do the formatting */ - p = buffer; - if (justify == '+' && filler == ' ') { - for (i = rawlen; i < width; i++) *p++ = ' '; - } - if (signedconv) { - if (sign < 0) *p++ = '-'; - else if (signstyle != '-') *p++ = signstyle; - } - if (alternate && base == 8) *p++ = '0'; - if (alternate && base == 16) { *p++ = '0'; *p++ = 'x'; } - if (justify == '+' && filler == '0') { - for (i = rawlen; i < width; i++) *p++ = '0'; - } - while (r < rawbuffer + sizeof(rawbuffer)) *p++ = *r++; - if (justify == '-') { - for (i = rawlen; i < width; i++) *p++ = ' '; - } - *p = 0; -} - -#endif /* CAML_INT64_FORMAT_H */ diff -Nru ocaml-4.01.0/byterun/int64_native.h ocaml-4.02.3/byterun/int64_native.h --- ocaml-4.01.0/byterun/int64_native.h 2013-04-18 15:52:32.000000000 +0200 +++ ocaml-4.02.3/byterun/int64_native.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,61 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Wrapper macros around native 64-bit integer arithmetic, - so that it has the same interface as the software emulation - provided in int64_emul.h */ - -#ifndef CAML_INT64_NATIVE_H -#define CAML_INT64_NATIVE_H - -#define I64_literal(hi,lo) ((int64)(hi) << 32 | (lo)) -#define I64_split(x,hi,lo) (hi = (uint32)((x)>>32), lo = (uint32)(x)) -#define I64_compare(x,y) (((x) > (y)) - ((x) < (y))) -#define I64_ult(x,y) ((uint64)(x) < (uint64)(y)) -#define I64_neg(x) (-(x)) -#define I64_add(x,y) ((x) + (y)) -#define I64_sub(x,y) ((x) - (y)) -#define I64_mul(x,y) ((x) * (y)) -#define I64_is_zero(x) ((x) == 0) -#define I64_is_negative(x) ((x) < 0) -#define I64_is_min_int(x) ((x) == ((int64)1 << 63)) -#define I64_is_minus_one(x) ((x) == -1) - -#define I64_div(x,y) ((x) / (y)) -#define I64_mod(x,y) ((x) % (y)) -#define I64_udivmod(x,y,quo,rem) \ - (*(rem) = (uint64)(x) % (uint64)(y), \ - *(quo) = (uint64)(x) / (uint64)(y)) -#define I64_and(x,y) ((x) & (y)) -#define I64_or(x,y) ((x) | (y)) -#define I64_xor(x,y) ((x) ^ (y)) -#define I64_lsl(x,y) ((x) << (y)) -#define I64_asr(x,y) ((x) >> (y)) -#define I64_lsr(x,y) ((uint64)(x) >> (y)) -#define I64_to_intnat(x) ((intnat) (x)) -#define I64_of_intnat(x) ((intnat) (x)) -#define I64_to_int32(x) ((int32) (x)) -#define I64_of_int32(x) ((int64) (x)) -#define I64_to_double(x) ((double)(x)) -#define I64_of_double(x) ((int64)(x)) - -#define I64_bswap(x) ((((x) & 0x00000000000000FFULL) << 56) | \ - (((x) & 0x000000000000FF00ULL) << 40) | \ - (((x) & 0x0000000000FF0000ULL) << 24) | \ - (((x) & 0x00000000FF000000ULL) << 8) | \ - (((x) & 0x000000FF00000000ULL) >> 8) | \ - (((x) & 0x0000FF0000000000ULL) >> 24) | \ - (((x) & 0x00FF000000000000ULL) >> 40) | \ - (((x) & 0xFF00000000000000ULL) >> 56)) - -#endif /* CAML_INT64_NATIVE_H */ diff -Nru ocaml-4.01.0/byterun/intern.c ocaml-4.02.3/byterun/intern.c --- ocaml-4.01.0/byterun/intern.c 2013-06-07 16:06:30.000000000 +0200 +++ ocaml-4.02.3/byterun/intern.c 2015-04-12 11:03:39.000000000 +0200 @@ -13,22 +13,22 @@ /* Structured input, compact format */ -/* The interface of this file is "intext.h" */ +/* The interface of this file is "caml/intext.h" */ #include #include -#include "alloc.h" -#include "callback.h" -#include "custom.h" -#include "fail.h" -#include "gc.h" -#include "intext.h" -#include "io.h" -#include "md5.h" -#include "memory.h" -#include "mlvalues.h" -#include "misc.h" -#include "reverse.h" +#include "caml/alloc.h" +#include "caml/callback.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/gc.h" +#include "caml/intext.h" +#include "caml/io.h" +#include "caml/md5.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/misc.h" +#include "caml/reverse.h" static unsigned char * intern_src; /* Reading pointer in block holding input data. */ @@ -64,10 +64,6 @@ /* Point to the heap block allocated as destination block. Meaningful only if intern_extra_block is NULL. */ -static value * camlinternaloo_last_id = NULL; -/* Pointer to a reference holding the last object id. - -1 means not available (CamlinternalOO not loaded). */ - static char * intern_resolve_code_pointer(unsigned char digest[16], asize_t offset); static void intern_bad_code_pointer(unsigned char digest[16]) Noreturn; @@ -290,16 +286,9 @@ switch (sp->op) { case OFreshOID: /* Refresh the object ID */ - if (camlinternaloo_last_id == NULL) { - camlinternaloo_last_id = caml_named_value("CamlinternalOO.last_id"); - if (camlinternaloo_last_id == NULL) - camlinternaloo_last_id = (value*) (-1); - } - if (camlinternaloo_last_id != (value*) (-1)) { - value id = Field(*camlinternaloo_last_id,0); - Field(dest, 0) = id; - Field(*camlinternaloo_last_id,0) = id + 2; - } + /* but do not do it for predefined exception slots */ + if (Int_val(Field((value)dest, 1)) >= 0) + caml_set_oo_id((value)dest); /* Pop item and iterate */ sp--; break; @@ -336,7 +325,7 @@ /* Request freshing OID */ PushItem(); sp->op = OFreshOID; - sp->dest = &Field(v, 1); + sp->dest = (value*) v; sp->arg = 1; /* Finally read first two block elements: method table and old OID */ ReadItems(&Field(v, 0), 2); @@ -503,8 +492,6 @@ { mlsize_t wosize; - if (camlinternaloo_last_id == (value*)-1) - camlinternaloo_last_id = NULL; /* Reset ignore flag */ if (whsize == 0) { intern_obj_table = NULL; intern_extra_block = NULL; @@ -751,7 +738,8 @@ static void intern_bad_code_pointer(unsigned char digest[16]) { char msg[256]; - sprintf(msg, "input_value: unknown code module " + snprintf(msg, sizeof(msg), + "input_value: unknown code module " "%02X%02X%02X%02X%02X%02X%02X%02X" "%02X%02X%02X%02X%02X%02X%02X%02X", digest[0], digest[1], digest[2], digest[3], diff -Nru ocaml-4.01.0/byterun/interp.c ocaml-4.02.3/byterun/interp.c --- ocaml-4.01.0/byterun/interp.c 2013-06-01 09:43:45.000000000 +0200 +++ ocaml-4.02.3/byterun/interp.c 2015-04-12 11:03:39.000000000 +0200 @@ -13,22 +13,22 @@ /* The bytecode interpreter */ #include -#include "alloc.h" -#include "backtrace.h" -#include "callback.h" -#include "debugger.h" -#include "fail.h" -#include "fix_code.h" -#include "instrtrace.h" -#include "instruct.h" -#include "interp.h" -#include "major_gc.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "prims.h" -#include "signals.h" -#include "stacks.h" +#include "caml/alloc.h" +#include "caml/backtrace.h" +#include "caml/callback.h" +#include "caml/debugger.h" +#include "caml/fail.h" +#include "caml/fix_code.h" +#include "caml/instrtrace.h" +#include "caml/instruct.h" +#include "caml/interp.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/prims.h" +#include "caml/signals.h" +#include "caml/stacks.h" /* Registers for the abstract machine: pc the code pointer @@ -173,16 +173,14 @@ #define SP_REG asm("%r14") #define ACCU_REG asm("%r13") #endif +#ifdef __aarch64__ +#define PC_REG asm("%x19") +#define SP_REG asm("%x20") +#define ACCU_REG asm("%x21") +#define JUMPTBL_BASE_REG asm("%x22") #endif - -/* Division and modulus madness */ - -#ifdef NONSTANDARD_DIV_MOD -extern intnat caml_safe_div(intnat p, intnat q); -extern intnat caml_safe_mod(intnat p, intnat q); #endif - #ifdef DEBUG static intnat caml_bcodcount; #endif @@ -222,7 +220,7 @@ #ifdef THREADED_CODE static void * jumptable[] = { -# include "jumptbl.h" +# include "caml/jumptbl.h" }; #endif @@ -525,10 +523,21 @@ int nvars = *pc++; int i; if (nvars > 0) *--sp = accu; - Alloc_small(accu, 1 + nvars, Closure_tag); + if (nvars < Max_young_wosize) { + /* nvars + 1 <= Max_young_wosize, can allocate in minor heap */ + Alloc_small(accu, 1 + nvars, Closure_tag); + for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i]; + } else { + /* PR#6385: must allocate in major heap */ + /* caml_alloc_shr and caml_initialize never trigger a GC, + so no need to Setup_for_gc */ + accu = caml_alloc_shr(1 + nvars, Closure_tag); + for (i = 0; i < nvars; i++) caml_initialize(&Field(accu, i + 1), sp[i]); + } + /* The code pointer is not in the heap, so no need to go through + caml_initialize. */ Code_val(accu) = pc + *pc; pc++; - for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i]; sp += nvars; Next; } @@ -536,15 +545,25 @@ Instruct(CLOSUREREC): { int nfuncs = *pc++; int nvars = *pc++; + mlsize_t blksize = nfuncs * 2 - 1 + nvars; int i; value * p; if (nvars > 0) *--sp = accu; - Alloc_small(accu, nfuncs * 2 - 1 + nvars, Closure_tag); - p = &Field(accu, nfuncs * 2 - 1); - for (i = 0; i < nvars; i++) { - *p++ = sp[i]; + if (blksize <= Max_young_wosize) { + Alloc_small(accu, blksize, Closure_tag); + p = &Field(accu, nfuncs * 2 - 1); + for (i = 0; i < nvars; i++, p++) *p = sp[i]; + } else { + /* PR#6385: must allocate in major heap */ + /* caml_alloc_shr and caml_initialize never trigger a GC, + so no need to Setup_for_gc */ + accu = caml_alloc_shr(blksize, Closure_tag); + p = &Field(accu, nfuncs * 2 - 1); + for (i = 0; i < nvars; i++, p++) caml_initialize(p, sp[i]); } sp += nvars; + /* The code pointers and infix headers are not in the heap, + so no need to go through caml_initialize. */ p = &Field(accu, 0); *p = (value) (pc + pc[0]); *--sp = accu; @@ -814,10 +833,20 @@ sp += 4; Next; + Instruct(RAISE_NOTRACE): + if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER); + goto raise_notrace; + + Instruct(RERAISE): + if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER); + if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp, 1); + goto raise_notrace; + Instruct(RAISE): raise_exception: if (caml_trapsp >= caml_trap_barrier) caml_debugger(TRAP_BARRIER); - if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp); + if (caml_backtrace_active) caml_stash_backtrace(accu, pc, sp, 0); + raise_notrace: if ((char *) caml_trapsp >= (char *) caml_stack_high - initial_sp_offset) { caml_external_raise = initial_external_raise; @@ -946,21 +975,13 @@ Instruct(DIVINT): { intnat divisor = Long_val(*sp++); if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); } -#ifdef NONSTANDARD_DIV_MOD - accu = Val_long(caml_safe_div(Long_val(accu), divisor)); -#else accu = Val_long(Long_val(accu) / divisor); -#endif Next; } Instruct(MODINT): { intnat divisor = Long_val(*sp++); if (divisor == 0) { Setup_for_c_call; caml_raise_zero_divide(); } -#ifdef NONSTANDARD_DIV_MOD - accu = Val_long(caml_safe_mod(Long_val(accu), divisor)); -#else accu = Val_long(Long_val(accu) % divisor); -#endif Next; } Instruct(ANDINT): diff -Nru ocaml-4.01.0/byterun/interp.h ocaml-4.02.3/byterun/interp.h --- ocaml-4.01.0/byterun/interp.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/interp.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,31 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* The bytecode interpreter */ - -#ifndef CAML_INTERP_H -#define CAML_INTERP_H - -#include "misc.h" -#include "mlvalues.h" - -/* interpret a bytecode */ -value caml_interprete (code_t prog, asize_t prog_size); - -/* tell the runtime that a bytecode program might be needed */ -void caml_prepare_bytecode(code_t prog, asize_t prog_size); - -/* tell the runtime that a bytecode program is no more needed */ -void caml_release_bytecode(code_t prog, asize_t prog_size); - -#endif /* CAML_INTERP_H */ diff -Nru ocaml-4.01.0/byterun/intext.h ocaml-4.02.3/byterun/intext.h --- ocaml-4.01.0/byterun/intext.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/intext.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,168 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Structured input/output */ - -#ifndef CAML_INTEXT_H -#define CAML_INTEXT_H - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "misc.h" -#include "mlvalues.h" - -/* */ -#include "io.h" - -/* Magic number */ - -#define Intext_magic_number 0x8495A6BE - -/* Codes for the compact format */ - -#define PREFIX_SMALL_BLOCK 0x80 -#define PREFIX_SMALL_INT 0x40 -#define PREFIX_SMALL_STRING 0x20 -#define CODE_INT8 0x0 -#define CODE_INT16 0x1 -#define CODE_INT32 0x2 -#define CODE_INT64 0x3 -#define CODE_SHARED8 0x4 -#define CODE_SHARED16 0x5 -#define CODE_SHARED32 0x6 -#define CODE_BLOCK32 0x8 -#define CODE_BLOCK64 0x13 -#define CODE_STRING8 0x9 -#define CODE_STRING32 0xA -#define CODE_DOUBLE_BIG 0xB -#define CODE_DOUBLE_LITTLE 0xC -#define CODE_DOUBLE_ARRAY8_BIG 0xD -#define CODE_DOUBLE_ARRAY8_LITTLE 0xE -#define CODE_DOUBLE_ARRAY32_BIG 0xF -#define CODE_DOUBLE_ARRAY32_LITTLE 0x7 -#define CODE_CODEPOINTER 0x10 -#define CODE_INFIXPOINTER 0x11 -#define CODE_CUSTOM 0x12 - -#if ARCH_FLOAT_ENDIANNESS == 0x76543210 -#define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG -#define CODE_DOUBLE_ARRAY8_NATIVE CODE_DOUBLE_ARRAY8_BIG -#define CODE_DOUBLE_ARRAY32_NATIVE CODE_DOUBLE_ARRAY32_BIG -#else -#define CODE_DOUBLE_NATIVE CODE_DOUBLE_LITTLE -#define CODE_DOUBLE_ARRAY8_NATIVE CODE_DOUBLE_ARRAY8_LITTLE -#define CODE_DOUBLE_ARRAY32_NATIVE CODE_DOUBLE_ARRAY32_LITTLE -#endif - -/* Size-ing data structures for extern. Chosen so that - sizeof(struct trail_block) and sizeof(struct output_block) - are slightly below 8Kb. */ - -#define ENTRIES_PER_TRAIL_BLOCK 1025 -#define SIZE_EXTERN_OUTPUT_BLOCK 8100 - -/* The entry points */ - -void caml_output_val (struct channel * chan, value v, value flags); - /* Output [v] with flags [flags] on the channel [chan]. */ - -/* */ - -#ifdef __cplusplus -extern "C" { -#endif - -CAMLextern void caml_output_value_to_malloc(value v, value flags, - /*out*/ char ** buf, - /*out*/ intnat * len); - /* Output [v] with flags [flags] to a memory buffer allocated with - malloc. On return, [*buf] points to the buffer and [*len] - contains the number of bytes in buffer. */ -CAMLextern intnat caml_output_value_to_block(value v, value flags, - char * data, intnat len); - /* Output [v] with flags [flags] to a user-provided memory buffer. - [data] points to the start of this buffer, and [len] is its size - in bytes. Return the number of bytes actually written in buffer. - Raise [Failure] if buffer is too short. */ - -/* */ -value caml_input_val (struct channel * chan); - /* Read a structured value from the channel [chan]. */ -/* */ - -CAMLextern value caml_input_val_from_string (value str, intnat ofs); - /* Read a structured value from the OCaml string [str], starting - at offset [ofs]. */ -CAMLextern value caml_input_value_from_malloc(char * data, intnat ofs); - /* Read a structured value from a malloced buffer. [data] points - to the beginning of the buffer, and [ofs] is the offset of the - beginning of the externed data in this buffer. The buffer is - deallocated with [free] on return, or if an exception is raised. */ -CAMLextern value caml_input_value_from_block(char * data, intnat len); - /* Read a structured value from a user-provided buffer. [data] points - to the beginning of the externed data in this buffer, - and [len] is the length in bytes of valid data in this buffer. - The buffer is never deallocated by this routine. */ - -/* Functions for writing user-defined marshallers */ - -CAMLextern void caml_serialize_int_1(int i); -CAMLextern void caml_serialize_int_2(int i); -CAMLextern void caml_serialize_int_4(int32 i); -CAMLextern void caml_serialize_int_8(int64 i); -CAMLextern void caml_serialize_float_4(float f); -CAMLextern void caml_serialize_float_8(double f); -CAMLextern void caml_serialize_block_1(void * data, intnat len); -CAMLextern void caml_serialize_block_2(void * data, intnat len); -CAMLextern void caml_serialize_block_4(void * data, intnat len); -CAMLextern void caml_serialize_block_8(void * data, intnat len); -CAMLextern void caml_serialize_block_float_8(void * data, intnat len); - -CAMLextern int caml_deserialize_uint_1(void); -CAMLextern int caml_deserialize_sint_1(void); -CAMLextern int caml_deserialize_uint_2(void); -CAMLextern int caml_deserialize_sint_2(void); -CAMLextern uint32 caml_deserialize_uint_4(void); -CAMLextern int32 caml_deserialize_sint_4(void); -CAMLextern uint64 caml_deserialize_uint_8(void); -CAMLextern int64 caml_deserialize_sint_8(void); -CAMLextern float caml_deserialize_float_4(void); -CAMLextern double caml_deserialize_float_8(void); -CAMLextern void caml_deserialize_block_1(void * data, intnat len); -CAMLextern void caml_deserialize_block_2(void * data, intnat len); -CAMLextern void caml_deserialize_block_4(void * data, intnat len); -CAMLextern void caml_deserialize_block_8(void * data, intnat len); -CAMLextern void caml_deserialize_block_float_8(void * data, intnat len); -CAMLextern void caml_deserialize_error(char * msg); - -/* */ - -/* Auxiliary stuff for sending code pointers */ - -struct code_fragment { - char * code_start; - char * code_end; - unsigned char digest[16]; - char digest_computed; -}; - -struct ext_table caml_code_fragments_table; - -/* */ - -#ifdef __cplusplus -} -#endif - -#endif /* CAML_INTEXT_H */ diff -Nru ocaml-4.01.0/byterun/ints.c ocaml-4.02.3/byterun/ints.c --- ocaml-4.01.0/byterun/ints.c 2013-04-18 15:59:50.000000000 +0200 +++ ocaml-4.02.3/byterun/ints.c 2015-04-12 11:03:39.000000000 +0200 @@ -13,13 +13,13 @@ #include #include -#include "alloc.h" -#include "custom.h" -#include "fail.h" -#include "intext.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" +#include "caml/alloc.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/intext.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" static char * parse_sign_and_base(char * p, /*out*/ int * base, @@ -96,24 +96,6 @@ return sign < 0 ? -((intnat) res) : (intnat) res; } -#ifdef NONSTANDARD_DIV_MOD -intnat caml_safe_div(intnat p, intnat q) -{ - uintnat ap = p >= 0 ? p : -p; - uintnat aq = q >= 0 ? q : -q; - uintnat ar = ap / aq; - return (p ^ q) >= 0 ? ar : -ar; -} - -intnat caml_safe_mod(intnat p, intnat q) -{ - uintnat ap = p >= 0 ? p : -p; - uintnat aq = q >= 0 ? q : -q; - uintnat ar = ap % aq; - return p >= 0 ? ar : -ar; -} -#endif - value caml_bswap16_direct(value x) { return ((((x & 0x00FF) << 8) | @@ -142,13 +124,10 @@ #define FORMAT_BUFFER_SIZE 32 -static char * parse_format(value fmt, - char * suffix, - char format_string[], - char default_format_buffer[], - char *conv) +static char parse_format(value fmt, + char * suffix, + char format_string[FORMAT_BUFFER_SIZE]) { - int prec; char * p; char lastletter; mlsize_t len, len_suffix; @@ -167,41 +146,25 @@ memmove(p, suffix, len_suffix); p += len_suffix; *p++ = lastletter; *p = 0; - /* Determine space needed for result and allocate it dynamically if needed */ - prec = 22 + 5; /* 22 digits for 64-bit number in octal + 5 extra */ - for (p = String_val(fmt); *p != 0; p++) { - if (*p >= '0' && *p <= '9') { - prec = atoi(p) + 5; - break; - } - } - *conv = lastletter; - if (prec < FORMAT_BUFFER_SIZE) - return default_format_buffer; - else - return caml_stat_alloc(prec + 1); + /* Return the conversion type (last letter) */ + return lastletter; } CAMLprim value caml_format_int(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; - char default_format_buffer[FORMAT_BUFFER_SIZE]; - char * buffer; char conv; value res; - buffer = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, - format_string, default_format_buffer, &conv); + conv = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, format_string); switch (conv) { case 'u': case 'x': case 'X': case 'o': - sprintf(buffer, format_string, Unsigned_long_val(arg)); + res = caml_alloc_sprintf(format_string, Unsigned_long_val(arg)); break; default: - sprintf(buffer, format_string, Long_val(arg)); + res = caml_alloc_sprintf(format_string, Long_val(arg)); break; } - res = caml_copy_string(buffer); - if (buffer != default_format_buffer) caml_stat_free(buffer); return res; } @@ -269,11 +232,7 @@ /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ if (dividend == (1<<31) && divisor == -1) return v1; -#ifdef NONSTANDARD_DIV_MOD - return caml_copy_int32(caml_safe_div(dividend, divisor)); -#else return caml_copy_int32(dividend / divisor); -#endif } CAMLprim value caml_int32_mod(value v1, value v2) @@ -284,11 +243,7 @@ /* PR#4740: on some processors, modulus crashes if division overflows. Implement the same behavior as for type "int". */ if (dividend == (1<<31) && divisor == -1) return caml_copy_int32(0); -#ifdef NONSTANDARD_DIV_MOD - return caml_copy_int32(caml_safe_mod(dividend, divisor)); -#else return caml_copy_int32(dividend % divisor); -#endif } CAMLprim value caml_int32_and(value v1, value v2) @@ -346,17 +301,9 @@ CAMLprim value caml_int32_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; - char default_format_buffer[FORMAT_BUFFER_SIZE]; - char * buffer; - char conv; - value res; - buffer = parse_format(fmt, ARCH_INT32_PRINTF_FORMAT, - format_string, default_format_buffer, &conv); - sprintf(buffer, format_string, Int32_val(arg)); - res = caml_copy_string(buffer); - if (buffer != default_format_buffer) caml_stat_free(buffer); - return res; + parse_format(fmt, ARCH_INT32_PRINTF_FORMAT, format_string); + return caml_alloc_sprintf(format_string, Int32_val(arg)); } CAMLprim value caml_int32_of_string(value s) @@ -380,12 +327,6 @@ /* 64-bit integers */ -#ifdef ARCH_INT64_TYPE -#include "int64_native.h" -#else -#include "int64_emul.h" -#endif - #ifdef ARCH_ALIGN_INT64 CAMLexport int64 caml_Int64_val(value v) @@ -402,15 +343,13 @@ { int64 i1 = Int64_val(v1); int64 i2 = Int64_val(v2); - return I64_compare(i1, i2); + return (i1 > i2) - (i1 < i2); } static intnat int64_hash(value v) { int64 x = Int64_val(v); - uint32 lo, hi; - - I64_split(x, hi, lo); + uint32 lo = (uint32) x, hi = (uint32) (x >> 32); return hi ^ lo; } @@ -459,59 +398,58 @@ } CAMLprim value caml_int64_neg(value v) -{ return caml_copy_int64(I64_neg(Int64_val(v))); } +{ return caml_copy_int64(- Int64_val(v)); } CAMLprim value caml_int64_add(value v1, value v2) -{ return caml_copy_int64(I64_add(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) + Int64_val(v2)); } CAMLprim value caml_int64_sub(value v1, value v2) -{ return caml_copy_int64(I64_sub(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) - Int64_val(v2)); } CAMLprim value caml_int64_mul(value v1, value v2) -{ return caml_copy_int64(I64_mul(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) * Int64_val(v2)); } + +#define Int64_min_int ((intnat) 1 << (sizeof(intnat) * 8 - 1)) CAMLprim value caml_int64_div(value v1, value v2) { int64 dividend = Int64_val(v1); int64 divisor = Int64_val(v2); - if (I64_is_zero(divisor)) caml_raise_zero_divide(); + if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ - if (I64_is_min_int(dividend) && I64_is_minus_one(divisor)) return v1; - return caml_copy_int64(I64_div(Int64_val(v1), divisor)); + if (dividend == ((int64)1 << 63) && divisor == -1) return v1; + return caml_copy_int64(Int64_val(v1) / divisor); } CAMLprim value caml_int64_mod(value v1, value v2) { int64 dividend = Int64_val(v1); int64 divisor = Int64_val(v2); - if (I64_is_zero(divisor)) caml_raise_zero_divide(); + if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ - if (I64_is_min_int(dividend) && I64_is_minus_one(divisor)) { - int64 zero = I64_literal(0,0); - return caml_copy_int64(zero); - } - return caml_copy_int64(I64_mod(Int64_val(v1), divisor)); + if (dividend == ((int64)1 << 63) && divisor == -1) return caml_copy_int64(0); + return caml_copy_int64(Int64_val(v1) % divisor); } CAMLprim value caml_int64_and(value v1, value v2) -{ return caml_copy_int64(I64_and(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) & Int64_val(v2)); } CAMLprim value caml_int64_or(value v1, value v2) -{ return caml_copy_int64(I64_or(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) | Int64_val(v2)); } CAMLprim value caml_int64_xor(value v1, value v2) -{ return caml_copy_int64(I64_xor(Int64_val(v1), Int64_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) ^ Int64_val(v2)); } CAMLprim value caml_int64_shift_left(value v1, value v2) -{ return caml_copy_int64(I64_lsl(Int64_val(v1), Int_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) << Int_val(v2)); } CAMLprim value caml_int64_shift_right(value v1, value v2) -{ return caml_copy_int64(I64_asr(Int64_val(v1), Int_val(v2))); } +{ return caml_copy_int64(Int64_val(v1) >> Int_val(v2)); } CAMLprim value caml_int64_shift_right_unsigned(value v1, value v2) -{ return caml_copy_int64(I64_lsr(Int64_val(v1), Int_val(v2))); } +{ return caml_copy_int64((uint64) (Int64_val(v1)) >> Int_val(v2)); } #ifdef ARCH_SIXTYFOUR static value caml_swap64(value x) @@ -531,98 +469,92 @@ #endif CAMLprim value caml_int64_bswap(value v) -{ return caml_copy_int64(I64_bswap(Int64_val(v))); } +{ + int64 x = Int64_val(v); + return caml_copy_int64 + (((x & 0x00000000000000FFULL) << 56) | + ((x & 0x000000000000FF00ULL) << 40) | + ((x & 0x0000000000FF0000ULL) << 24) | + ((x & 0x00000000FF000000ULL) << 8) | + ((x & 0x000000FF00000000ULL) >> 8) | + ((x & 0x0000FF0000000000ULL) >> 24) | + ((x & 0x00FF000000000000ULL) >> 40) | + ((x & 0xFF00000000000000ULL) >> 56)); +} CAMLprim value caml_int64_of_int(value v) -{ return caml_copy_int64(I64_of_intnat(Long_val(v))); } +{ return caml_copy_int64((int64) (Long_val(v))); } CAMLprim value caml_int64_to_int(value v) -{ return Val_long(I64_to_intnat(Int64_val(v))); } +{ return Val_long((intnat) (Int64_val(v))); } CAMLprim value caml_int64_of_float(value v) -{ return caml_copy_int64(I64_of_double(Double_val(v))); } +{ return caml_copy_int64((int64) (Double_val(v))); } CAMLprim value caml_int64_to_float(value v) -{ - int64 i = Int64_val(v); - return caml_copy_double(I64_to_double(i)); -} +{ return caml_copy_double((double) (Int64_val(v))); } CAMLprim value caml_int64_of_int32(value v) -{ return caml_copy_int64(I64_of_int32(Int32_val(v))); } +{ return caml_copy_int64((int64) (Int32_val(v))); } CAMLprim value caml_int64_to_int32(value v) -{ return caml_copy_int32(I64_to_int32(Int64_val(v))); } +{ return caml_copy_int32((int32) (Int64_val(v))); } CAMLprim value caml_int64_of_nativeint(value v) -{ return caml_copy_int64(I64_of_intnat(Nativeint_val(v))); } +{ return caml_copy_int64((int64) (Nativeint_val(v))); } CAMLprim value caml_int64_to_nativeint(value v) -{ return caml_copy_nativeint(I64_to_intnat(Int64_val(v))); } +{ return caml_copy_nativeint((intnat) (Int64_val(v))); } CAMLprim value caml_int64_compare(value v1, value v2) { int64 i1 = Int64_val(v1); int64 i2 = Int64_val(v2); - return Val_int(I64_compare(i1, i2)); + return Val_int((i1 > i2) - (i1 < i2)); } -#ifdef ARCH_INT64_PRINTF_FORMAT -#define I64_format(buf,fmt,x) sprintf(buf,fmt,x) -#else -#include "int64_format.h" -#define ARCH_INT64_PRINTF_FORMAT "" -#endif - CAMLprim value caml_int64_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; - char default_format_buffer[FORMAT_BUFFER_SIZE]; - char * buffer; - char conv; - value res; - buffer = parse_format(fmt, ARCH_INT64_PRINTF_FORMAT, - format_string, default_format_buffer, &conv); - I64_format(buffer, format_string, Int64_val(arg)); - res = caml_copy_string(buffer); - if (buffer != default_format_buffer) caml_stat_free(buffer); - return res; + parse_format(fmt, ARCH_INT64_PRINTF_FORMAT, format_string); + return caml_alloc_sprintf(format_string, Int64_val(arg)); } CAMLprim value caml_int64_of_string(value s) { char * p; - uint64 max_uint64 = I64_literal(0xFFFFFFFF, 0xFFFFFFFF); - uint64 max_int64_pos = I64_literal(0x7FFFFFFF, 0xFFFFFFFF); - uint64 max_int64_neg = I64_literal(0x80000000, 0x00000000); uint64 res, threshold; int sign, base, d; p = parse_sign_and_base(String_val(s), &base, &sign); - I64_udivmod(max_uint64, I64_of_int32(base), &threshold, &res); + threshold = ((uint64) -1) / base; d = parse_digit(*p); if (d < 0 || d >= base) caml_failwith("int_of_string"); - res = I64_of_int32(d); + res = d; for (p++; /*nothing*/; p++) { char c = *p; if (c == '_') continue; d = parse_digit(c); if (d < 0 || d >= base) break; /* Detect overflow in multiplication base * res */ - if (I64_ult(threshold, res)) caml_failwith("int_of_string"); - res = I64_add(I64_mul(I64_of_int32(base), res), I64_of_int32(d)); + if (res > threshold) caml_failwith("int_of_string"); + res = base * res + d; /* Detect overflow in addition (base * res) + d */ - if (I64_ult(res, I64_of_int32(d))) caml_failwith("int_of_string"); + if (res < (uint64) d) caml_failwith("int_of_string"); } if (p != String_val(s) + caml_string_length(s)){ caml_failwith("int_of_string"); } if (base == 10) { - if (I64_ult((sign >= 0 ? max_int64_pos : max_int64_neg), res)) - caml_failwith("int_of_string"); + /* Signed representation expected, allow -2^63 to 2^63 - 1 only */ + if (sign >= 0) { + if (res >= (uint64)1 << 63) caml_failwith("int_of_string"); + } else { + if (res > (uint64)1 << 63) caml_failwith("int_of_string"); + } } - if (sign < 0) res = I64_neg(res); + if (sign < 0) res = - res; return caml_copy_int64(res); } @@ -745,11 +677,7 @@ /* PR#4740: on some processors, modulus crashes if division overflows. Implement the same behavior as for type "int". */ if (dividend == Nativeint_min_int && divisor == -1) return v1; -#ifdef NONSTANDARD_DIV_MOD - return caml_copy_nativeint(caml_safe_div(dividend, divisor)); -#else return caml_copy_nativeint(dividend / divisor); -#endif } CAMLprim value caml_nativeint_mod(value v1, value v2) @@ -762,11 +690,7 @@ if (dividend == Nativeint_min_int && divisor == -1){ return caml_copy_nativeint(0); } -#ifdef NONSTANDARD_DIV_MOD - return caml_copy_nativeint(caml_safe_mod(dividend, divisor)); -#else return caml_copy_nativeint(dividend % divisor); -#endif } CAMLprim value caml_nativeint_and(value v1, value v2) @@ -834,17 +758,9 @@ CAMLprim value caml_nativeint_format(value fmt, value arg) { char format_string[FORMAT_BUFFER_SIZE]; - char default_format_buffer[FORMAT_BUFFER_SIZE]; - char * buffer; - char conv; - value res; - buffer = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, - format_string, default_format_buffer, &conv); - sprintf(buffer, format_string, Nativeint_val(arg)); - res = caml_copy_string(buffer); - if (buffer != default_format_buffer) caml_stat_free(buffer); - return res; + parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, format_string); + return caml_alloc_sprintf(format_string, Nativeint_val(arg)); } CAMLprim value caml_nativeint_of_string(value s) diff -Nru ocaml-4.01.0/byterun/io.c ocaml-4.02.3/byterun/io.c --- ocaml-4.01.0/byterun/io.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/io.c 2015-04-12 11:03:39.000000000 +0200 @@ -18,19 +18,22 @@ #include #include #include -#include "config.h" +#include "caml/config.h" #ifdef HAS_UNISTD #include #endif -#include "alloc.h" -#include "custom.h" -#include "fail.h" -#include "io.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "signals.h" -#include "sys.h" +#ifdef __CYGWIN__ +#include +#endif +#include "caml/alloc.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/io.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/signals.h" +#include "caml/sys.h" #ifndef SEEK_SET #define SEEK_SET 0 @@ -788,21 +791,3 @@ Unlock(channel); CAMLreturn (Val_long(res)); } - -/* Conversion between file_offset and int64 */ - -#ifndef ARCH_INT64_TYPE -CAMLexport value caml_Val_file_offset(file_offset fofs) -{ - int64 ofs; - ofs.l = fofs; - ofs.h = 0; - return caml_copy_int64(ofs); -} - -CAMLexport file_offset caml_File_offset_val(value v) -{ - int64 ofs = Int64_val(v); - return (file_offset) ofs.l; -} -#endif diff -Nru ocaml-4.01.0/byterun/io.h ocaml-4.02.3/byterun/io.h --- ocaml-4.01.0/byterun/io.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/io.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,124 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Buffered input/output */ - -#ifndef CAML_IO_H -#define CAML_IO_H - -#include "misc.h" -#include "mlvalues.h" - -#ifndef IO_BUFFER_SIZE -#define IO_BUFFER_SIZE 65536 -#endif - -#if defined(_WIN32) -typedef __int64 file_offset; -extern __int64 _lseeki64(int, __int64, int); -#define lseek(fd,d,m) _lseeki64(fd,d,m) -#elif defined(HAS_OFF_T) -#include -typedef off_t file_offset; -#else -typedef long file_offset; -#endif - -struct channel { - int fd; /* Unix file descriptor */ - file_offset offset; /* Absolute position of fd in the file */ - char * end; /* Physical end of the buffer */ - char * curr; /* Current position in the buffer */ - char * max; /* Logical end of the buffer (for input) */ - void * mutex; /* Placeholder for mutex (for systhreads) */ - struct channel * next, * prev;/* Double chaining of channels (flush_all) */ - int revealed; /* For Cash only */ - int old_revealed; /* For Cash only */ - int refcount; /* For flush_all and for Cash */ - int flags; /* Bitfield */ - char buff[IO_BUFFER_SIZE]; /* The buffer itself */ -}; - -enum { - CHANNEL_FLAG_FROM_SOCKET = 1 /* For Windows */ -}; - -/* For an output channel: - [offset] is the absolute position of the beginning of the buffer [buff]. - For an input channel: - [offset] is the absolute position of the logical end of the buffer, [max]. -*/ - -/* Functions and macros that can be called from C. Take arguments of - type struct channel *. No locking is performed. */ - -#define putch(channel, ch) do{ \ - if ((channel)->curr >= (channel)->end) caml_flush_partial(channel); \ - *((channel)->curr)++ = (ch); \ -}while(0) - -#define getch(channel) \ - ((channel)->curr >= (channel)->max \ - ? caml_refill(channel) \ - : (unsigned char) *((channel)->curr)++) - -CAMLextern struct channel * caml_open_descriptor_in (int); -CAMLextern struct channel * caml_open_descriptor_out (int); -CAMLextern void caml_close_channel (struct channel *); -CAMLextern int caml_channel_binary_mode (struct channel *); -CAMLextern value caml_alloc_channel(struct channel *chan); - -CAMLextern int caml_flush_partial (struct channel *); -CAMLextern void caml_flush (struct channel *); -CAMLextern void caml_putword (struct channel *, uint32); -CAMLextern int caml_putblock (struct channel *, char *, intnat); -CAMLextern void caml_really_putblock (struct channel *, char *, intnat); - -CAMLextern unsigned char caml_refill (struct channel *); -CAMLextern uint32 caml_getword (struct channel *); -CAMLextern int caml_getblock (struct channel *, char *, intnat); -CAMLextern int caml_really_getblock (struct channel *, char *, intnat); - -/* Extract a struct channel * from the heap object representing it */ - -#define Channel(v) (*((struct channel **) (Data_custom_val(v)))) - -/* The locking machinery */ - -CAMLextern void (*caml_channel_mutex_free) (struct channel *); -CAMLextern void (*caml_channel_mutex_lock) (struct channel *); -CAMLextern void (*caml_channel_mutex_unlock) (struct channel *); -CAMLextern void (*caml_channel_mutex_unlock_exn) (void); - -CAMLextern struct channel * caml_all_opened_channels; - -#define Lock(channel) \ - if (caml_channel_mutex_lock != NULL) (*caml_channel_mutex_lock)(channel) -#define Unlock(channel) \ - if (caml_channel_mutex_unlock != NULL) (*caml_channel_mutex_unlock)(channel) -#define Unlock_exn() \ - if (caml_channel_mutex_unlock_exn != NULL) (*caml_channel_mutex_unlock_exn)() - -/* Conversion between file_offset and int64 */ - -#ifdef ARCH_INT64_TYPE -#define Val_file_offset(fofs) caml_copy_int64(fofs) -#define File_offset_val(v) ((file_offset) Int64_val(v)) -#else -CAMLextern value caml_Val_file_offset(file_offset fofs); -CAMLextern file_offset caml_File_offset_val(value v); -#define Val_file_offset caml_Val_file_offset -#define File_offset_val caml_File_offset_val -#endif - -#endif /* CAML_IO_H */ diff -Nru ocaml-4.01.0/byterun/lexing.c ocaml-4.02.3/byterun/lexing.c --- ocaml-4.01.0/byterun/lexing.c 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/byterun/lexing.c 2015-04-12 11:03:39.000000000 +0200 @@ -13,9 +13,9 @@ /* The table-driven automaton for lexers generated by camllex. */ -#include "fail.h" -#include "mlvalues.h" -#include "stacks.h" +#include "caml/fail.h" +#include "caml/mlvalues.h" +#include "caml/stacks.h" struct lexer_buffer { value refill_buff; @@ -49,7 +49,7 @@ #if defined(ARCH_BIG_ENDIAN) || SIZEOF_SHORT != 2 #define Short(tbl,n) \ (*((unsigned char *)((tbl) + (n) * 2)) + \ - (*((schar *)((tbl) + (n) * 2 + 1)) << 8)) + (*((signed char *)((tbl) + (n) * 2 + 1)) << 8)) #else #define Short(tbl,n) (((short *)(tbl))[(n)]) #endif diff -Nru ocaml-4.01.0/byterun/main.c ocaml-4.02.3/byterun/main.c --- ocaml-4.01.0/byterun/main.c 2013-02-26 13:47:13.000000000 +0100 +++ ocaml-4.02.3/byterun/main.c 2015-04-12 11:03:39.000000000 +0200 @@ -14,9 +14,9 @@ /* Main entry point (can be overridden by a user-provided main() function that calls caml_main() later). */ -#include "misc.h" -#include "mlvalues.h" -#include "sys.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/sys.h" CAMLextern void caml_main (char **); diff -Nru ocaml-4.01.0/byterun/major_gc.c ocaml-4.02.3/byterun/major_gc.c --- ocaml-4.01.0/byterun/major_gc.c 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/byterun/major_gc.c 2015-07-20 16:46:48.000000000 +0200 @@ -13,19 +13,25 @@ #include -#include "compact.h" -#include "custom.h" -#include "config.h" -#include "fail.h" -#include "finalise.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "major_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "roots.h" -#include "weak.h" +#include "caml/compact.h" +#include "caml/custom.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/finalise.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/major_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/weak.h" + +#if defined (NATIVE_CODE) && defined (NO_NAKED_POINTERS) +#define NATIVE_CODE_AND_NO_NAKED_POINTERS +#else +#undef NATIVE_CODE_AND_NO_NAKED_POINTERS +#endif uintnat caml_percent_free; uintnat caml_major_heap_increment; @@ -53,6 +59,8 @@ static unsigned long major_gc_counter = 0; #endif +void (*caml_major_gc_hook)(void) = NULL; + static void realloc_gray_vals (void) { value *new; @@ -82,7 +90,11 @@ void caml_darken (value v, value *p /* not used */) { +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + if (Is_block (v) && Wosize_val (v) > 0) { +#else if (Is_block (v) && Is_in_heap (v)) { +#endif header_t h = Hd_val (v); tag_t t = Tag_hd (h); if (t == Infix_tag){ @@ -90,6 +102,15 @@ h = Hd_val (v); t = Tag_hd (h); } +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + /* We insist that naked pointers to outside the heap point to things that + look like values with headers coloured black. This isn't always + strictly necessary but is essential in certain cases---in particular + when the value is allocated in a read-only section. (For the values + where it would be safe it is a performance improvement since we avoid + putting them on the grey list.) */ + CAMLassert (Is_in_heap (v) || Is_black_hd (h)); +#endif CAMLassert (!Is_blue_hd (h)); if (Is_white_hd (h)){ if (t < No_scan_tag){ @@ -124,6 +145,9 @@ value v, child; header_t hd; mlsize_t size, i; +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + int marking_closure = 0; +#endif caml_gc_message (0x40, "Marking %ld words\n", work); caml_gc_message (0x40, "Subphase = %ld\n", caml_gc_subphase); @@ -132,13 +156,26 @@ if (gray_vals_ptr > gray_vals){ v = *--gray_vals_ptr; hd = Hd_val(v); +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + marking_closure = + (Tag_hd (hd) == Closure_tag || Tag_hd (hd) == Infix_tag); +#endif Assert (Is_gray_hd (hd)); Hd_val (v) = Blackhd_hd (hd); size = Wosize_hd (hd); if (Tag_hd (hd) < No_scan_tag){ for (i = 0; i < size; i++){ child = Field (v, i); +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + if (Is_block (child) + && Wosize_val (child) > 0 /* Atoms never need to be marked. */ + /* Closure blocks contain code pointers at offsets that cannot + be reliably determined, so we always use the page table when + marking such values. */ + && (!marking_closure || Is_in_heap (child))) { +#else if (Is_block (child) && Is_in_heap (child)) { +#endif hd = Hd_val (child); if (Tag_hd (hd) == Forward_tag){ value f = Forward_val (child); @@ -154,6 +191,10 @@ child -= Infix_offset_val(child); hd = Hd_val(child); } +#ifdef NATIVE_CODE_AND_NO_NAKED_POINTERS + /* See [caml_darken] for a description of this assertion. */ + CAMLassert (Is_in_heap (child) || Is_black_hd (hd)); +#endif if (Is_white_hd (hd)){ Hd_val (child) = Grayhd_hd (hd); *gray_vals_ptr++ = child; @@ -272,6 +313,7 @@ limit = chunk + Chunk_size (chunk); work = 0; caml_fl_size_at_phase_change = caml_fl_cur_size; + if (caml_major_gc_hook) (*caml_major_gc_hook)(); } break; default: Assert (0); @@ -378,6 +420,8 @@ This slice will either mark MS words or sweep SS words. */ + if (caml_major_slice_begin_hook != NULL) (*caml_major_slice_begin_hook) (); + if (caml_gc_phase == Phase_idle) start_cycle (); p = (double) caml_allocated_words * 3.0 * (100 + caml_percent_free) @@ -425,6 +469,7 @@ caml_allocated_words = 0; caml_dependent_allocated = 0; caml_extra_heap_resources = 0.0; + if (caml_major_slice_end_hook != NULL) (*caml_major_slice_end_hook) (); return computed_work; } @@ -457,15 +502,23 @@ return ((request + Page_size - 1) >> Page_log) << Page_log; } -/* Make sure the request is >= caml_major_heap_increment, then call - clip_heap_chunk_size, then make sure the result is >= request. +/* Compute the heap increment, make sure the request is at least that big, + then call clip_heap_chunk_size, then make sure the result is >= request. */ asize_t caml_round_heap_chunk_size (asize_t request) { asize_t result = request; + uintnat incr; + + /* Compute the heap increment as a byte size. */ + if (caml_major_heap_increment > 1000){ + incr = Bsize_wsize (caml_major_heap_increment); + }else{ + incr = caml_stat_heap_size / 100 * caml_major_heap_increment; + } - if (result < caml_major_heap_increment){ - result = caml_major_heap_increment; + if (result < incr){ + result = incr; } result = clip_heap_chunk_size (result); diff -Nru ocaml-4.01.0/byterun/major_gc.h ocaml-4.02.3/byterun/major_gc.h --- ocaml-4.01.0/byterun/major_gc.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/major_gc.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,60 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_MAJOR_GC_H -#define CAML_MAJOR_GC_H - - -#include "freelist.h" -#include "misc.h" - -typedef struct { - void *block; /* address of the malloced block this chunk live in */ - asize_t alloc; /* in bytes, used for compaction */ - asize_t size; /* in bytes */ - char *next; -} heap_chunk_head; - -#define Chunk_size(c) (((heap_chunk_head *) (c)) [-1]).size -#define Chunk_alloc(c) (((heap_chunk_head *) (c)) [-1]).alloc -#define Chunk_next(c) (((heap_chunk_head *) (c)) [-1]).next -#define Chunk_block(c) (((heap_chunk_head *) (c)) [-1]).block - -extern int caml_gc_phase; -extern int caml_gc_subphase; -extern uintnat caml_allocated_words; -extern double caml_extra_heap_resources; -extern uintnat caml_dependent_size, caml_dependent_allocated; -extern uintnat caml_fl_size_at_phase_change; - -#define Phase_mark 0 -#define Phase_sweep 1 -#define Phase_idle 2 -#define Subphase_main 10 -#define Subphase_weak1 11 -#define Subphase_weak2 12 -#define Subphase_final 13 - -CAMLextern char *caml_heap_start; -extern uintnat total_heap_size; -extern char *caml_gc_sweep_hp; - -void caml_init_major_heap (asize_t); /* size in bytes */ -asize_t caml_round_heap_chunk_size (asize_t); /* size in bytes */ -void caml_darken (value, value *); -intnat caml_major_collection_slice (intnat); -void major_collection (void); -void caml_finish_major_cycle (void); - - -#endif /* CAML_MAJOR_GC_H */ diff -Nru ocaml-4.01.0/byterun/Makefile ocaml-4.02.3/byterun/Makefile --- ocaml-4.01.0/byterun/Makefile 2013-03-28 17:10:24.000000000 +0100 +++ ocaml-4.02.3/byterun/Makefile 2015-05-10 07:45:57.000000000 +0200 @@ -13,17 +13,14 @@ include Makefile.common -CFLAGS=-DCAML_NAME_SPACE -O $(BYTECCCOMPOPTS) $(IFLEXDIR) +CFLAGS=-DCAML_NAME_SPACE $(BYTECCCOMPOPTS) $(IFLEXDIR) DFLAGS=-DCAML_NAME_SPACE -g -DDEBUG $(BYTECCCOMPOPTS) $(IFLEXDIR) -OBJS=$(COMMONOBJS) unix.o main.o +OBJS=$(COMMONOBJS) $(UNIX_OR_WIN32).o main.o DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o PICOBJS=$(OBJS:.o=.pic.o) -SHARED_LIBS_TMP=$(SUPPORTS_SHARED_LIBRARIES:%false=) -SHARED_LIBS_DEPS=$(SHARED_LIBS_TMP:%true=libcamlrun_shared.so) - -all:: $(SHARED_LIBS_DEPS) +all:: all-$(SHARED) ocamlrun$(EXE): libcamlrun.a prims.o $(MKEXE) $(BYTECCLINKOPTS) -o ocamlrun$(EXE) \ @@ -34,42 +31,50 @@ prims.o libcamlrund.a $(BYTECCLIBS) libcamlrun.a: $(OBJS) - ar rc libcamlrun.a $(OBJS) + $(ARCMD) rc libcamlrun.a $(OBJS) $(RANLIB) libcamlrun.a libcamlrund.a: $(DOBJS) - ar rc libcamlrund.a $(DOBJS) + $(ARCMD) rc libcamlrund.a $(DOBJS) $(RANLIB) libcamlrund.a +all-noshared: +.PHONY: all-noshared + +all-shared: libcamlrun_pic.a libcamlrun_shared.so +.PHONY: all-shared + +libcamlrun_pic.a: $(PICOBJS) + ar rc libcamlrun_pic.a $(PICOBJS) + $(RANLIB) libcamlrun_pic.a + libcamlrun_shared.so: $(PICOBJS) $(MKDLL) -o libcamlrun_shared.so $(PICOBJS) $(BYTECCLIBS) -install:: - if test -f libcamlrun_shared.so; then \ - cp libcamlrun_shared.so $(LIBDIR)/libcamlrun_shared.so; fi +install:: install-$(SHARED) -clean:: - rm -f libcamlrun_shared.so - -.SUFFIXES: .d.o .pic.o +install-noshared: +.PHONY: install-noshared -.c.d.o: - ln -s -f $*.c $*.d.c - $(CC) -c $(DFLAGS) $*.d.c - rm $*.d.c - -.c.pic.o: - ln -s -f $*.c $*.pic.c - $(CC) -c $(CFLAGS) $(SHAREDCCCOMPOPTS) $*.pic.c - rm $*.pic.c +install-shared: + cp libcamlrun_shared.so $(INSTALL_LIBDIR)/libcamlrun_shared.so + cp libcamlrun_pic.a $(INSTALL_LIBDIR)/libcamlrun_pic.a + cd $(INSTALL_LIBDIR); $(RANLIB) libcamlrun_pic.a +.PHONY: install-shared clean:: - rm -f *.pic.c *.d.c + rm -f libcamlrun_shared.so libcamlrun_pic.a + +%.d.o: %.c + $(CC) -c $(DFLAGS) $< -o $@ + +%.pic.o: %.c + $(CC) -c $(CFLAGS) $(SHAREDCCCOMPOPTS) $< -o $@ -depend : prims.c opnames.h jumptbl.h version.h - -gcc -MM $(BYTECCCOMPOPTS) *.c > .depend - -gcc -MM $(BYTECCCOMPOPTS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend - -gcc -MM $(BYTECCCOMPOPTS) *.c | sed -e 's/\.o/.pic.o/' >> .depend +depend : prims.c caml/opnames.h caml/jumptbl.h caml/version.h + -$(CC) -MM $(BYTECCCOMPOPTS) *.c > .depend + -$(CC) -MM $(BYTECCCOMPOPTS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend + -$(CC) -MM $(BYTECCCOMPOPTS) *.c | sed -e 's/\.o/.pic.o/' >> .depend .PHONY: depend include .depend diff -Nru ocaml-4.01.0/byterun/Makefile.common ocaml-4.02.3/byterun/Makefile.common --- ocaml-4.01.0/byterun/Makefile.common 2013-08-19 20:21:47.000000000 +0200 +++ ocaml-4.02.3/byterun/Makefile.common 2015-06-04 21:59:00.000000000 +0200 @@ -12,6 +12,8 @@ ######################################################################### include ../config/Makefile +CAMLRUN ?= ../boot/ocamlrun +CAMLYACC ?= ../boot/ocamlyacc CC=$(BYTECC) @@ -31,8 +33,10 @@ dynlink.c backtrace.c PUBLIC_INCLUDES=\ - alloc.h callback.h config.h custom.h fail.h hash.h intext.h \ - memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h + address_class.h alloc.h callback.h config.h custom.h fail.h gc.h \ + hash.h intext.h \ + memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h \ + version.h all:: ocamlrun$(EXE) ld.conf libcamlrun.$(A) all-$(RUNTIMED) @@ -48,15 +52,22 @@ echo "$(STUBLIBDIR)" > ld.conf echo "$(LIBDIR)" >> ld.conf +# Installation + +INSTALL_BINDIR=$(DESTDIR)$(BINDIR) +INSTALL_LIBDIR=$(DESTDIR)$(LIBDIR) + + install:: - cp ocamlrun$(EXE) $(BINDIR)/ocamlrun$(EXE) - cp libcamlrun.$(A) $(LIBDIR)/libcamlrun.$(A) - cd $(LIBDIR); $(RANLIB) libcamlrun.$(A) - if test -d $(LIBDIR)/caml; then : ; else mkdir $(LIBDIR)/caml; fi + cp $(CAMLRUN)$(EXE) $(INSTALL_BINDIR)/ocamlrun$(EXE) + cp libcamlrun.$(A) $(INSTALL_LIBDIR)/libcamlrun.$(A) + cd $(INSTALL_LIBDIR); $(RANLIB) libcamlrun.$(A) + if test -d $(INSTALL_LIBDIR)/caml; then : ; \ + else mkdir $(INSTALL_LIBDIR)/caml; fi for i in $(PUBLIC_INCLUDES); do \ - sed -f ../tools/cleanup-header $$i > $(LIBDIR)/caml/$$i; \ + sed -f ../tools/cleanup-header caml/$$i > $(INSTALL_LIBDIR)/caml/$$i; \ done - cp ld.conf $(LIBDIR)/ld.conf + cp ld.conf $(INSTALL_LIBDIR)/ld.conf .PHONY: install install:: install-$(RUNTIMED) @@ -64,9 +75,13 @@ install-noruntimed: .PHONY: install-noruntimed +# TODO: when cross-compiling, do not install ocamlrund +# it doesn't hurt to install it, but it's useless and might be confusing +# because it's an executable for the target machine, while we're installing +# binaries for the host. install-runtimed: - cp ocamlrund$(EXE) $(BINDIR)/ocamlrund$(EXE) - cp libcamlrund.$(A) $(LIBDIR)/libcamlrund.$(A) + cp ocamlrund$(EXE) $(INSTALL_BINDIR)/ocamlrund$(EXE) + cp libcamlrund.$(A) $(INSTALL_LIBDIR)/libcamlrund.$(A) .PHONY: install-runtimed # If primitives contain duplicated lines (e.g. because the code is defined @@ -88,8 +103,8 @@ | sort | uniq > primitives prims.c : primitives - (echo '#include "mlvalues.h"'; \ - echo '#include "prims.h"'; \ + (echo '#include "caml/mlvalues.h"'; \ + echo '#include "caml/prims.h"'; \ sed -e 's/.*/extern value &();/' primitives; \ echo 'c_primitive caml_builtin_cprim[] = {'; \ sed -e 's/.*/ &,/' primitives; \ @@ -98,23 +113,23 @@ sed -e 's/.*/ "&",/' primitives; \ echo ' 0 };') > prims.c -opnames.h : instruct.h +caml/opnames.h : caml/instruct.h sed -e '/\/\*/d' \ -e '/^#/d' \ -e 's/enum /char * names_of_/' \ -e 's/{$$/[] = {/' \ - -e 's/\([[:upper:]][[:upper:]_0-9]*\)/"\1"/g' instruct.h > opnames.h + -e 's/\([[:upper:]][[:upper:]_0-9]*\)/"\1"/g' caml/instruct.h > caml/opnames.h -# jumptbl.h is required only if you have GCC 2.0 or later -jumptbl.h : instruct.h +# caml/jumptbl.h is required only if you have GCC 2.0 or later +caml/jumptbl.h : caml/instruct.h sed -n -e '/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp' \ - -e '/^}/q' instruct.h > jumptbl.h + -e '/^}/q' caml/instruct.h > caml/jumptbl.h -version.h : ../VERSION - echo "#define OCAML_VERSION \"`sed -e 1q ../VERSION`\"" > version.h +caml/version.h : ../VERSION ../tools/make-version-header.sh + ../tools/make-version-header.sh ../VERSION > caml/version.h clean :: rm -f ocamlrun$(EXE) ocamlrund$(EXE) *.$(O) *.$(A) *.$(SO) - rm -f primitives prims.c opnames.h jumptbl.h ld.conf - rm -f version.h + rm -f primitives prims.c caml/opnames.h caml/jumptbl.h ld.conf + rm -f caml/version.h .PHONY: clean diff -Nru ocaml-4.01.0/byterun/Makefile.nt ocaml-4.02.3/byterun/Makefile.nt --- ocaml-4.01.0/byterun/Makefile.nt 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/byterun/Makefile.nt 2015-04-12 18:57:32.000000000 +0200 @@ -24,7 +24,7 @@ $(EXTRALIBS) libcamlrun.$(A) ocamlrund$(EXE): libcamlrund.$(A) prims.$(O) main.$(O) - $(MKEXE) -o ocamlrun$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) \ + $(MKEXE) -o ocamlrund$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) \ $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrund.$(A) libcamlrun.$(A): $(OBJS) @@ -33,21 +33,20 @@ libcamlrund.$(A): $(DOBJS) $(call MKLIB,libcamlrund.$(A),$(DOBJS)) -.SUFFIXES: .$(O) .$(DBGO) - -.c.$(O): +%.$(O): %.c $(CC) $(CFLAGS) $(BYTECCCOMPOPTS) -c $< -.c.$(DBGO): - $(CC) $(CFLAGS) $(BYTECCDBGCOMPOPTS) -c $< - mv $*.$(O) $*.$(DBGO) +%.$(DBGO): %.c + $(CC) $(CFLAGS) $(BYTECCDBGCOMPOPTS) -c -o $@ $< .depend.nt: .depend rm -f .depend.win32 - echo "win32.o: win32.c fail.h compatibility.h \\" >> .depend.win32 - echo " misc.h config.h ../config/m.h ../config/s.h \\" >> .depend.win32 - echo " mlvalues.h memory.h gc.h major_gc.h \\" >> .depend.win32 - echo " freelist.h minor_gc.h osdeps.h signals.h" >> .depend.win32 + echo "win32.o: win32.c \\" >> .depend.win32 + echo " caml/fail.h caml/compatibility.h caml/misc.h \\" >> .depend.win32 + echo " caml/config.h ../config/m.h ../config/s.h \\" >> .depend.win32 + echo " caml/mlvalues.h caml/memory.h caml/gc.h \\" >> .depend.win32 + echo " caml/major_gc.h caml/freelist.h caml/minor_gc.h \\" >> .depend.win32 + echo " caml/osdeps.h caml/signals.h" >> .depend.win32 cat .depend >> .depend.win32 sed -e '/\.d\.o/q' -e 's/^\(.*\)\.o:/\1.$$(O) \1.$$(DBGO):/' \ .depend.win32 > .depend.nt diff -Nru ocaml-4.01.0/byterun/md5.c ocaml-4.02.3/byterun/md5.c --- ocaml-4.01.0/byterun/md5.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/md5.c 2015-04-12 11:03:39.000000000 +0200 @@ -12,13 +12,13 @@ /***********************************************************************/ #include -#include "alloc.h" -#include "fail.h" -#include "md5.h" -#include "memory.h" -#include "mlvalues.h" -#include "io.h" -#include "reverse.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/md5.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/io.h" +#include "caml/reverse.h" /* MD5 message digest */ @@ -33,18 +33,16 @@ return res; } -CAMLprim value caml_md5_chan(value vchan, value len) +CAMLexport value caml_md5_channel(struct channel *chan, intnat toread) { - CAMLparam2 (vchan, len); - struct channel * chan = Channel(vchan); + CAMLparam0(); struct MD5Context ctx; value res; - intnat toread, read; + intnat read; char buffer[4096]; Lock(chan); caml_MD5Init(&ctx); - toread = Long_val(len); if (toread < 0){ while (1){ read = caml_getblock (chan, buffer, sizeof(buffer)); @@ -66,6 +64,12 @@ CAMLreturn (res); } +CAMLprim value caml_md5_chan(value vchan, value len) +{ + CAMLparam2 (vchan, len); + CAMLreturn (caml_md5_channel(Channel(vchan), Long_val(len))); +} + CAMLexport void caml_md5_block(unsigned char digest[16], void * data, uintnat len) { diff -Nru ocaml-4.01.0/byterun/md5.h ocaml-4.02.3/byterun/md5.h --- ocaml-4.01.0/byterun/md5.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/md5.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,41 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1999 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* MD5 message digest */ - -#ifndef CAML_MD5_H -#define CAML_MD5_H - - -#include "mlvalues.h" -#include "io.h" - -CAMLextern value caml_md5_string (value str, value ofs, value len); -CAMLextern value caml_md5_chan (value vchan, value len); -CAMLextern void caml_md5_block(unsigned char digest[16], - void * data, uintnat len); - -struct MD5Context { - uint32 buf[4]; - uint32 bits[2]; - unsigned char in[64]; -}; - -CAMLextern void caml_MD5Init (struct MD5Context *context); -CAMLextern void caml_MD5Update (struct MD5Context *context, unsigned char *buf, - uintnat len); -CAMLextern void caml_MD5Final (unsigned char *digest, struct MD5Context *ctx); -CAMLextern void caml_MD5Transform (uint32 *buf, uint32 *in); - - -#endif /* CAML_MD5_H */ diff -Nru ocaml-4.01.0/byterun/memory.c ocaml-4.02.3/byterun/memory.c --- ocaml-4.01.0/byterun/memory.c 2013-08-01 10:12:41.000000000 +0200 +++ ocaml-4.02.3/byterun/memory.c 2015-06-04 21:59:00.000000000 +0200 @@ -13,17 +13,18 @@ #include #include -#include "fail.h" -#include "freelist.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "major_gc.h" -#include "memory.h" -#include "major_gc.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "signals.h" +#include "caml/address_class.h" +#include "caml/fail.h" +#include "caml/freelist.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/major_gc.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/signals.h" extern uintnat caml_percent_free; /* major_gc.c */ diff -Nru ocaml-4.01.0/byterun/memory.h ocaml-4.02.3/byterun/memory.h --- ocaml-4.01.0/byterun/memory.h 2013-06-01 09:43:45.000000000 +0200 +++ ocaml-4.02.3/byterun/memory.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,443 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Allocation macros and functions */ - -#ifndef CAML_MEMORY_H -#define CAML_MEMORY_H - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "config.h" -/* */ -#include "gc.h" -#include "major_gc.h" -#include "minor_gc.h" -/* */ -#include "misc.h" -#include "mlvalues.h" - -#ifdef __cplusplus -extern "C" { -#endif - - -CAMLextern value caml_alloc_shr (mlsize_t, tag_t); -CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t); -CAMLextern void caml_alloc_dependent_memory (mlsize_t); -CAMLextern void caml_free_dependent_memory (mlsize_t); -CAMLextern void caml_modify (value *, value); -CAMLextern void caml_initialize (value *, value); -CAMLextern value caml_check_urgent_gc (value); -CAMLextern void * caml_stat_alloc (asize_t); /* Size in bytes. */ -CAMLextern void caml_stat_free (void *); -CAMLextern void * caml_stat_resize (void *, asize_t); /* Size in bytes. */ -char *caml_alloc_for_heap (asize_t request); /* Size in bytes. */ -void caml_free_for_heap (char *mem); -int caml_add_to_heap (char *mem); -color_t caml_allocation_color (void *hp); - -/* void caml_shrink_heap (char *); Only used in compact.c */ - -/* */ - -#define Not_in_heap 0 -#define In_heap 1 -#define In_young 2 -#define In_static_data 4 -#define In_code_area 8 - -#ifdef ARCH_SIXTYFOUR - -/* 64 bits: Represent page table as a sparse hash table */ -int caml_page_table_lookup(void * addr); -#define Classify_addr(a) (caml_page_table_lookup((void *)(a))) - -#else - -/* 32 bits: Represent page table as a 2-level array */ -#define Pagetable2_log 11 -#define Pagetable2_size (1 << Pagetable2_log) -#define Pagetable1_log (Page_log + Pagetable2_log) -#define Pagetable1_size (1 << (32 - Pagetable1_log)) -CAMLextern unsigned char * caml_page_table[Pagetable1_size]; - -#define Pagetable_index1(a) (((uintnat)(a)) >> Pagetable1_log) -#define Pagetable_index2(a) \ - ((((uintnat)(a)) >> Page_log) & (Pagetable2_size - 1)) -#define Classify_addr(a) \ - caml_page_table[Pagetable_index1(a)][Pagetable_index2(a)] - -#endif - -#define Is_in_value_area(a) \ - (Classify_addr(a) & (In_heap | In_young | In_static_data)) -#define Is_in_heap(a) (Classify_addr(a) & In_heap) -#define Is_in_heap_or_young(a) (Classify_addr(a) & (In_heap | In_young)) - -int caml_page_table_add(int kind, void * start, void * end); -int caml_page_table_remove(int kind, void * start, void * end); -int caml_page_table_initialize(mlsize_t bytesize); - -#ifdef DEBUG -#define DEBUG_clear(result, wosize) do{ \ - uintnat caml__DEBUG_i; \ - for (caml__DEBUG_i = 0; caml__DEBUG_i < (wosize); ++ caml__DEBUG_i){ \ - Field ((result), caml__DEBUG_i) = Debug_uninit_minor; \ - } \ -}while(0) -#else -#define DEBUG_clear(result, wosize) -#endif - -#define Alloc_small(result, wosize, tag) do{ CAMLassert ((wosize) >= 1); \ - CAMLassert ((tag_t) (tag) < 256); \ - CAMLassert ((wosize) <= Max_young_wosize); \ - caml_young_ptr -= Bhsize_wosize (wosize); \ - if (caml_young_ptr < caml_young_start){ \ - caml_young_ptr += Bhsize_wosize (wosize); \ - Setup_for_gc; \ - caml_minor_collection (); \ - Restore_after_gc; \ - caml_young_ptr -= Bhsize_wosize (wosize); \ - } \ - Hd_hp (caml_young_ptr) = Make_header ((wosize), (tag), Caml_black); \ - (result) = Val_hp (caml_young_ptr); \ - DEBUG_clear ((result), (wosize)); \ -}while(0) - -/* Deprecated alias for [caml_modify] */ - -#define Modify(fp,val) caml_modify((fp), (val)) - -/* */ - -struct caml__roots_block { - struct caml__roots_block *next; - intnat ntables; - intnat nitems; - value *tables [5]; -}; - -CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ - -/* The following macros are used to declare C local variables and - function parameters of type [value]. - - The function body must start with one of the [CAMLparam] macros. - If the function has no parameter of type [value], use [CAMLparam0]. - If the function has 1 to 5 [value] parameters, use the corresponding - [CAMLparam] with the parameters as arguments. - If the function has more than 5 [value] parameters, use [CAMLparam5] - for the first 5 parameters, and one or more calls to the [CAMLxparam] - macros for the others. - If the function takes an array of [value]s as argument, use - [CAMLparamN] to declare it (or [CAMLxparamN] if you already have a - call to [CAMLparam] for some other arguments). - - If you need local variables of type [value], declare them with one - or more calls to the [CAMLlocal] macros at the beginning of the - function, after the call to CAMLparam. Use [CAMLlocalN] (at the - beginning of the function) to declare an array of [value]s. - - Your function may raise an exception or return a [value] with the - [CAMLreturn] macro. Its argument is simply the [value] returned by - your function. Do NOT directly return a [value] with the [return] - keyword. If your function returns void, use [CAMLreturn0]. - - All the identifiers beginning with "caml__" are reserved by OCaml. - Do not use them for anything (local or global variables, struct or - union tags, macros, etc.) -*/ - -#define CAMLparam0() \ - struct caml__roots_block *caml__frame = caml_local_roots - -#define CAMLparam1(x) \ - CAMLparam0 (); \ - CAMLxparam1 (x) - -#define CAMLparam2(x, y) \ - CAMLparam0 (); \ - CAMLxparam2 (x, y) - -#define CAMLparam3(x, y, z) \ - CAMLparam0 (); \ - CAMLxparam3 (x, y, z) - -#define CAMLparam4(x, y, z, t) \ - CAMLparam0 (); \ - CAMLxparam4 (x, y, z, t) - -#define CAMLparam5(x, y, z, t, u) \ - CAMLparam0 (); \ - CAMLxparam5 (x, y, z, t, u) - -#define CAMLparamN(x, size) \ - CAMLparam0 (); \ - CAMLxparamN (x, (size)) - - -#if defined(__GNUC__) && (__GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ > 7)) - #define CAMLunused __attribute__ ((unused)) -#else - #define CAMLunused -#endif - -#define CAMLxparam1(x) \ - struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ - (caml__roots_##x.next = caml_local_roots), \ - (caml_local_roots = &caml__roots_##x), \ - (caml__roots_##x.nitems = 1), \ - (caml__roots_##x.ntables = 1), \ - (caml__roots_##x.tables [0] = &x), \ - 0) - -#define CAMLxparam2(x, y) \ - struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ - (caml__roots_##x.next = caml_local_roots), \ - (caml_local_roots = &caml__roots_##x), \ - (caml__roots_##x.nitems = 1), \ - (caml__roots_##x.ntables = 2), \ - (caml__roots_##x.tables [0] = &x), \ - (caml__roots_##x.tables [1] = &y), \ - 0) - -#define CAMLxparam3(x, y, z) \ - struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ - (caml__roots_##x.next = caml_local_roots), \ - (caml_local_roots = &caml__roots_##x), \ - (caml__roots_##x.nitems = 1), \ - (caml__roots_##x.ntables = 3), \ - (caml__roots_##x.tables [0] = &x), \ - (caml__roots_##x.tables [1] = &y), \ - (caml__roots_##x.tables [2] = &z), \ - 0) - -#define CAMLxparam4(x, y, z, t) \ - struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ - (caml__roots_##x.next = caml_local_roots), \ - (caml_local_roots = &caml__roots_##x), \ - (caml__roots_##x.nitems = 1), \ - (caml__roots_##x.ntables = 4), \ - (caml__roots_##x.tables [0] = &x), \ - (caml__roots_##x.tables [1] = &y), \ - (caml__roots_##x.tables [2] = &z), \ - (caml__roots_##x.tables [3] = &t), \ - 0) - -#define CAMLxparam5(x, y, z, t, u) \ - struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ - (caml__roots_##x.next = caml_local_roots), \ - (caml_local_roots = &caml__roots_##x), \ - (caml__roots_##x.nitems = 1), \ - (caml__roots_##x.ntables = 5), \ - (caml__roots_##x.tables [0] = &x), \ - (caml__roots_##x.tables [1] = &y), \ - (caml__roots_##x.tables [2] = &z), \ - (caml__roots_##x.tables [3] = &t), \ - (caml__roots_##x.tables [4] = &u), \ - 0) - -#define CAMLxparamN(x, size) \ - struct caml__roots_block caml__roots_##x; \ - CAMLunused int caml__dummy_##x = ( \ - (caml__roots_##x.next = caml_local_roots), \ - (caml_local_roots = &caml__roots_##x), \ - (caml__roots_##x.nitems = (size)), \ - (caml__roots_##x.ntables = 1), \ - (caml__roots_##x.tables[0] = &(x[0])), \ - 0) - -#define CAMLlocal1(x) \ - value x = 0; \ - CAMLxparam1 (x) - -#define CAMLlocal2(x, y) \ - value x = 0, y = 0; \ - CAMLxparam2 (x, y) - -#define CAMLlocal3(x, y, z) \ - value x = 0, y = 0, z = 0; \ - CAMLxparam3 (x, y, z) - -#define CAMLlocal4(x, y, z, t) \ - value x = 0, y = 0, z = 0, t = 0; \ - CAMLxparam4 (x, y, z, t) - -#define CAMLlocal5(x, y, z, t, u) \ - value x = 0, y = 0, z = 0, t = 0, u = 0; \ - CAMLxparam5 (x, y, z, t, u) - -#define CAMLlocalN(x, size) \ - value x [(size)] = { 0, /* 0, 0, ... */ }; \ - CAMLxparamN (x, (size)) - - -#define CAMLreturn0 do{ \ - caml_local_roots = caml__frame; \ - return; \ -}while (0) - -#define CAMLreturnT(type, result) do{ \ - type caml__temp_result = (result); \ - caml_local_roots = caml__frame; \ - return (caml__temp_result); \ -}while(0) - -#define CAMLreturn(result) CAMLreturnT(value, result) - -#define CAMLnoreturn ((void) caml__frame) - - -/* convenience macro */ -#define Store_field(block, offset, val) do{ \ - mlsize_t caml__temp_offset = (offset); \ - value caml__temp_val = (val); \ - caml_modify (&Field ((block), caml__temp_offset), caml__temp_val); \ -}while(0) - -/* - NOTE: [Begin_roots] and [End_roots] are superseded by [CAMLparam]*, - [CAMLxparam]*, [CAMLlocal]*, [CAMLreturn]. - - [Begin_roots] and [End_roots] are used for C variables that are GC roots. - It must contain all values in C local variables and function parameters - at the time the minor GC is called. - Usage: - After initialising your local variables to legal OCaml values, but before - calling allocation functions, insert [Begin_roots_n(v1, ... vn)], where - v1 ... vn are your variables of type [value] that you want to be updated - across allocations. - At the end, insert [End_roots()]. - - Note that [Begin_roots] opens a new block, and [End_roots] closes it. - Thus they must occur in matching pairs at the same brace nesting level. - - You can use [Val_unit] as a dummy initial value for your variables. -*/ - -#define Begin_root Begin_roots1 - -#define Begin_roots1(r0) { \ - struct caml__roots_block caml__roots_block; \ - caml__roots_block.next = caml_local_roots; \ - caml_local_roots = &caml__roots_block; \ - caml__roots_block.nitems = 1; \ - caml__roots_block.ntables = 1; \ - caml__roots_block.tables[0] = &(r0); - -#define Begin_roots2(r0, r1) { \ - struct caml__roots_block caml__roots_block; \ - caml__roots_block.next = caml_local_roots; \ - caml_local_roots = &caml__roots_block; \ - caml__roots_block.nitems = 1; \ - caml__roots_block.ntables = 2; \ - caml__roots_block.tables[0] = &(r0); \ - caml__roots_block.tables[1] = &(r1); - -#define Begin_roots3(r0, r1, r2) { \ - struct caml__roots_block caml__roots_block; \ - caml__roots_block.next = caml_local_roots; \ - caml_local_roots = &caml__roots_block; \ - caml__roots_block.nitems = 1; \ - caml__roots_block.ntables = 3; \ - caml__roots_block.tables[0] = &(r0); \ - caml__roots_block.tables[1] = &(r1); \ - caml__roots_block.tables[2] = &(r2); - -#define Begin_roots4(r0, r1, r2, r3) { \ - struct caml__roots_block caml__roots_block; \ - caml__roots_block.next = caml_local_roots; \ - caml_local_roots = &caml__roots_block; \ - caml__roots_block.nitems = 1; \ - caml__roots_block.ntables = 4; \ - caml__roots_block.tables[0] = &(r0); \ - caml__roots_block.tables[1] = &(r1); \ - caml__roots_block.tables[2] = &(r2); \ - caml__roots_block.tables[3] = &(r3); - -#define Begin_roots5(r0, r1, r2, r3, r4) { \ - struct caml__roots_block caml__roots_block; \ - caml__roots_block.next = caml_local_roots; \ - caml_local_roots = &caml__roots_block; \ - caml__roots_block.nitems = 1; \ - caml__roots_block.ntables = 5; \ - caml__roots_block.tables[0] = &(r0); \ - caml__roots_block.tables[1] = &(r1); \ - caml__roots_block.tables[2] = &(r2); \ - caml__roots_block.tables[3] = &(r3); \ - caml__roots_block.tables[4] = &(r4); - -#define Begin_roots_block(table, size) { \ - struct caml__roots_block caml__roots_block; \ - caml__roots_block.next = caml_local_roots; \ - caml_local_roots = &caml__roots_block; \ - caml__roots_block.nitems = (size); \ - caml__roots_block.ntables = 1; \ - caml__roots_block.tables[0] = (table); - -#define End_roots() caml_local_roots = caml__roots_block.next; } - - -/* [caml_register_global_root] registers a global C variable as a memory root - for the duration of the program, or until [caml_remove_global_root] is - called. */ - -CAMLextern void caml_register_global_root (value *); - -/* [caml_remove_global_root] removes a memory root registered on a global C - variable with [caml_register_global_root]. */ - -CAMLextern void caml_remove_global_root (value *); - -/* [caml_register_generational_global_root] registers a global C - variable as a memory root for the duration of the program, or until - [caml_remove_generational_global_root] is called. - The program guarantees that the value contained in this variable - will not be assigned directly. If the program needs to change - the value of this variable, it must do so by calling - [caml_modify_generational_global_root]. The [value *] pointer - passed to [caml_register_generational_global_root] must contain - a valid OCaml value before the call. - In return for these constraints, scanning of memory roots during - minor collection is made more efficient. */ - -CAMLextern void caml_register_generational_global_root (value *); - -/* [caml_remove_generational_global_root] removes a memory root - registered on a global C variable with - [caml_register_generational_global_root]. */ - -CAMLextern void caml_remove_generational_global_root (value *); - -/* [caml_modify_generational_global_root(r, newval)] - modifies the value contained in [r], storing [newval] inside. - In other words, the assignment [*r = newval] is performed, - but in a way that is compatible with the optimized scanning of - generational global roots. [r] must be a global memory root - previously registered with [caml_register_generational_global_root]. */ - -CAMLextern void caml_modify_generational_global_root(value *r, value newval); - -#ifdef __cplusplus -} -#endif - -#endif /* CAML_MEMORY_H */ diff -Nru ocaml-4.01.0/byterun/meta.c ocaml-4.02.3/byterun/meta.c --- ocaml-4.01.0/byterun/meta.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/meta.c 2015-04-12 11:03:39.000000000 +0200 @@ -14,19 +14,19 @@ /* Primitives for the toplevel */ #include -#include "alloc.h" -#include "config.h" -#include "fail.h" -#include "fix_code.h" -#include "interp.h" -#include "intext.h" -#include "major_gc.h" -#include "memory.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "prims.h" -#include "stacks.h" +#include "caml/alloc.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/fix_code.h" +#include "caml/interp.h" +#include "caml/intext.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/prims.h" +#include "caml/stacks.h" #ifndef NATIVE_CODE diff -Nru ocaml-4.01.0/byterun/minor_gc.c ocaml-4.02.3/byterun/minor_gc.c --- ocaml-4.01.0/byterun/minor_gc.c 2013-07-17 13:50:53.000000000 +0200 +++ ocaml-4.02.3/byterun/minor_gc.c 2015-07-20 16:46:48.000000000 +0200 @@ -12,19 +12,19 @@ /***********************************************************************/ #include -#include "config.h" -#include "fail.h" -#include "finalise.h" -#include "gc.h" -#include "gc_ctrl.h" -#include "major_gc.h" -#include "memory.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "roots.h" -#include "signals.h" -#include "weak.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/finalise.h" +#include "caml/gc.h" +#include "caml/gc_ctrl.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/signals.h" +#include "caml/weak.h" asize_t caml_minor_heap_size; static void *caml_young_base = NULL; @@ -226,8 +226,11 @@ void caml_empty_minor_heap (void) { value **r; + uintnat prev_alloc_words; if (caml_young_ptr != caml_young_end){ + if (caml_minor_gc_begin_hook != NULL) (*caml_minor_gc_begin_hook) (); + prev_alloc_words = caml_allocated_words; caml_in_minor_collection = 1; caml_gc_message (0x02, "<", 0); caml_oldify_local_roots(); @@ -252,8 +255,13 @@ clear_table (&caml_weak_ref_table); caml_gc_message (0x02, ">", 0); caml_in_minor_collection = 0; + caml_stat_promoted_words += caml_allocated_words - prev_alloc_words; + ++ caml_stat_minor_collections; + caml_final_empty_young (); + if (caml_minor_gc_end_hook != NULL) (*caml_minor_gc_end_hook) (); + }else{ + caml_final_empty_young (); } - caml_final_empty_young (); #ifdef DEBUG { value *p; @@ -271,12 +279,8 @@ */ CAMLexport void caml_minor_collection (void) { - intnat prev_alloc_words = caml_allocated_words; - caml_empty_minor_heap (); - caml_stat_promoted_words += caml_allocated_words - prev_alloc_words; - ++ caml_stat_minor_collections; caml_major_collection_slice (0); caml_force_major_slice = 0; diff -Nru ocaml-4.01.0/byterun/minor_gc.h ocaml-4.02.3/byterun/minor_gc.h --- ocaml-4.01.0/byterun/minor_gc.h 2013-07-17 13:50:53.000000000 +0200 +++ ocaml-4.02.3/byterun/minor_gc.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,56 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_MINOR_GC_H -#define CAML_MINOR_GC_H - - -#include "misc.h" - -CAMLextern char *caml_young_start, *caml_young_ptr; -CAMLextern char *caml_young_end, *caml_young_limit; -extern asize_t caml_minor_heap_size; -extern int caml_in_minor_collection; - -struct caml_ref_table { - value **base; - value **end; - value **threshold; - value **ptr; - value **limit; - asize_t size; - asize_t reserve; -}; -CAMLextern struct caml_ref_table caml_ref_table, caml_weak_ref_table; - -#define Is_young(val) \ - (Assert (Is_block (val)), \ - (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start) - -extern void caml_set_minor_heap_size (asize_t); /* size in bytes */ -extern void caml_empty_minor_heap (void); -CAMLextern void caml_minor_collection (void); -CAMLextern void garbage_collection (void); /* def in asmrun/signals.c */ -extern void caml_realloc_ref_table (struct caml_ref_table *); -extern void caml_alloc_table (struct caml_ref_table *, asize_t, asize_t); -extern void caml_oldify_one (value, value *); -extern void caml_oldify_mopup (void); - -#define Oldify(p) do{ \ - value __oldify__v__ = *p; \ - if (Is_block (__oldify__v__) && Is_young (__oldify__v__)){ \ - caml_oldify_one (__oldify__v__, (p)); \ - } \ - }while(0) - -#endif /* CAML_MINOR_GC_H */ diff -Nru ocaml-4.01.0/byterun/misc.c ocaml-4.02.3/byterun/misc.c --- ocaml-4.01.0/byterun/misc.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/misc.c 2015-04-12 11:03:39.000000000 +0200 @@ -12,9 +12,18 @@ /***********************************************************************/ #include -#include "config.h" -#include "misc.h" -#include "memory.h" +#include +#include +#include "caml/config.h" +#include "caml/misc.h" +#include "caml/memory.h" + +caml_timing_hook caml_major_slice_begin_hook = NULL; +caml_timing_hook caml_major_slice_end_hook = NULL; +caml_timing_hook caml_minor_gc_begin_hook = NULL; +caml_timing_hook caml_minor_gc_end_hook = NULL; +caml_timing_hook caml_finalise_begin_hook = NULL; +caml_timing_hook caml_finalise_end_hook = NULL; #ifdef DEBUG @@ -121,3 +130,39 @@ for (i = 0; i < tbl->size; i++) caml_stat_free(tbl->contents[i]); caml_stat_free(tbl->contents); } + +CAMLexport char * caml_strdup(const char * s) +{ + size_t slen = strlen(s); + char * res = caml_stat_alloc(slen + 1); + memcpy(res, s, slen + 1); + return res; +} + +CAMLexport char * caml_strconcat(int n, ...) +{ + va_list args; + char * res, * p; + size_t len; + int i; + + len = 0; + va_start(args, n); + for (i = 0; i < n; i++) { + const char * s = va_arg(args, const char *); + len += strlen(s); + } + va_end(args); + res = caml_stat_alloc(len + 1); + va_start(args, n); + p = res; + for (i = 0; i < n; i++) { + const char * s = va_arg(args, const char *); + size_t l = strlen(s); + memcpy(p, s, l); + p += l; + } + va_end(args); + *p = 0; + return res; +} diff -Nru ocaml-4.01.0/byterun/misc.h ocaml-4.02.3/byterun/misc.h --- ocaml-4.01.0/byterun/misc.h 2013-08-01 10:12:41.000000000 +0200 +++ ocaml-4.02.3/byterun/misc.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,143 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Miscellaneous macros and variables. */ - -#ifndef CAML_MISC_H -#define CAML_MISC_H - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "config.h" - -/* Standard definitions */ - -#include -#include - -/* Basic types and constants */ - -typedef size_t asize_t; - -#ifndef NULL -#define NULL 0 -#endif - -/* */ -typedef char * addr; -/* */ - -#ifdef __GNUC__ - /* Works only in GCC 2.5 and later */ - #define Noreturn __attribute__ ((noreturn)) -#else - #define Noreturn -#endif - -/* Export control (to mark primitives and to handle Windows DLL) */ - -#define CAMLexport -#define CAMLprim -#define CAMLextern extern - -/* Weak function definitions that can be overriden by external libs */ -/* Conservatively restricted to ELF and MacOSX platforms */ -#if defined(__GNUC__) && (defined (__ELF__) || defined(__APPLE__)) -#define CAMLweakdef __attribute__((weak)) -#else -#define CAMLweakdef -#endif - -/* Assertions */ - -/* */ - -#ifdef DEBUG -#define CAMLassert(x) \ - ((x) ? (void) 0 : caml_failed_assert ( #x , __FILE__, __LINE__)) -CAMLextern int caml_failed_assert (char *, char *, int); -#else -#define CAMLassert(x) ((void) 0) -#endif - -CAMLextern void caml_fatal_error (char *msg) Noreturn; -CAMLextern void caml_fatal_error_arg (char *fmt, char *arg) Noreturn; -CAMLextern void caml_fatal_error_arg2 (char *fmt1, char *arg1, - char *fmt2, char *arg2) Noreturn; - -/* Data structures */ - -struct ext_table { - int size; - int capacity; - void ** contents; -}; - -extern void caml_ext_table_init(struct ext_table * tbl, int init_capa); -extern int caml_ext_table_add(struct ext_table * tbl, void * data); -extern void caml_ext_table_free(struct ext_table * tbl, int free_entries); - -/* GC flags and messages */ - -extern uintnat caml_verb_gc; -void caml_gc_message (int, char *, uintnat); - -/* Memory routines */ - -char *caml_aligned_malloc (asize_t, int, void **); - -#ifdef DEBUG -#ifdef ARCH_SIXTYFOUR -#define Debug_tag(x) (0xD700D7D7D700D6D7ul \ - | ((uintnat) (x) << 16) \ - | ((uintnat) (x) << 48)) -#else -#define Debug_tag(x) (0xD700D6D7ul | ((uintnat) (x) << 16)) -#endif /* ARCH_SIXTYFOUR */ - -/* - 00 -> free words in minor heap - 01 -> fields of free list blocks in major heap - 03 -> heap chunks deallocated by heap shrinking - 04 -> fields deallocated by [caml_obj_truncate] - 10 -> uninitialised fields of minor objects - 11 -> uninitialised fields of major objects - 15 -> uninitialised words of [caml_aligned_malloc] blocks - 85 -> filler bytes of [caml_aligned_malloc] - - special case (byte by byte): - D7 -> uninitialised words of [caml_stat_alloc] blocks -*/ -#define Debug_free_minor Debug_tag (0x00) -#define Debug_free_major Debug_tag (0x01) -#define Debug_free_shrink Debug_tag (0x03) -#define Debug_free_truncate Debug_tag (0x04) -#define Debug_uninit_minor Debug_tag (0x10) -#define Debug_uninit_major Debug_tag (0x11) -#define Debug_uninit_align Debug_tag (0x15) -#define Debug_filler_align Debug_tag (0x85) - -#define Debug_uninit_stat 0xD7 - -extern void caml_set_fields (char *, unsigned long, unsigned long); -#endif /* DEBUG */ - - -#ifndef CAML_AVOID_CONFLICTS -#define Assert CAMLassert -#endif - -/* */ - -#endif /* CAML_MISC_H */ diff -Nru ocaml-4.01.0/byterun/mlvalues.h ocaml-4.02.3/byterun/mlvalues.h --- ocaml-4.01.0/byterun/mlvalues.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/mlvalues.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,304 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_MLVALUES_H -#define CAML_MLVALUES_H - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "config.h" -#include "misc.h" - -#ifdef __cplusplus -extern "C" { -#endif - -/* Definitions - - word: Four bytes on 32 and 16 bit architectures, - eight bytes on 64 bit architectures. - long: A C integer having the same number of bytes as a word. - val: The ML representation of something. A long or a block or a pointer - outside the heap. If it is a block, it is the (encoded) address - of an object. If it is a long, it is encoded as well. - block: Something allocated. It always has a header and some - fields or some number of bytes (a multiple of the word size). - field: A word-sized val which is part of a block. - bp: Pointer to the first byte of a block. (a char *) - op: Pointer to the first field of a block. (a value *) - hp: Pointer to the header of a block. (a char *) - int32: Four bytes on all architectures. - int64: Eight bytes on all architectures. - - Remark: A block size is always a multiple of the word size, and at least - one word plus the header. - - bosize: Size (in bytes) of the "bytes" part. - wosize: Size (in words) of the "fields" part. - bhsize: Size (in bytes) of the block with its header. - whsize: Size (in words) of the block with its header. - - hd: A header. - tag: The value of the tag field of the header. - color: The value of the color field of the header. - This is for use only by the GC. -*/ - -typedef intnat value; -typedef uintnat header_t; -typedef uintnat mlsize_t; -typedef unsigned int tag_t; /* Actually, an unsigned char */ -typedef uintnat color_t; -typedef uintnat mark_t; - -/* Longs vs blocks. */ -#define Is_long(x) (((x) & 1) != 0) -#define Is_block(x) (((x) & 1) == 0) - -/* Conversion macro names are always of the form "to_from". */ -/* Example: Val_long as in "Val from long" or "Val of long". */ -#define Val_long(x) (((intnat)(x) << 1) + 1) -#define Long_val(x) ((x) >> 1) -#define Max_long (((intnat)1 << (8 * sizeof(value) - 2)) - 1) -#define Min_long (-((intnat)1 << (8 * sizeof(value) - 2))) -#define Val_int(x) Val_long(x) -#define Int_val(x) ((int) Long_val(x)) -#define Unsigned_long_val(x) ((uintnat)(x) >> 1) -#define Unsigned_int_val(x) ((int) Unsigned_long_val(x)) - -/* Structure of the header: - -For 16-bit and 32-bit architectures: - +--------+-------+-----+ - | wosize | color | tag | - +--------+-------+-----+ -bits 31 10 9 8 7 0 - -For 64-bit architectures: - - +--------+-------+-----+ - | wosize | color | tag | - +--------+-------+-----+ -bits 63 10 9 8 7 0 - -*/ - -#define Tag_hd(hd) ((tag_t) ((hd) & 0xFF)) -#define Wosize_hd(hd) ((mlsize_t) ((hd) >> 10)) - -#define Hd_val(val) (((header_t *) (val)) [-1]) /* Also an l-value. */ -#define Hd_op(op) (Hd_val (op)) /* Also an l-value. */ -#define Hd_bp(bp) (Hd_val (bp)) /* Also an l-value. */ -#define Hd_hp(hp) (* ((header_t *) (hp))) /* Also an l-value. */ -#define Hp_val(val) ((char *) (((header_t *) (val)) - 1)) -#define Hp_op(op) (Hp_val (op)) -#define Hp_bp(bp) (Hp_val (bp)) -#define Val_op(op) ((value) (op)) -#define Val_hp(hp) ((value) (((header_t *) (hp)) + 1)) -#define Op_hp(hp) ((value *) Val_hp (hp)) -#define Bp_hp(hp) ((char *) Val_hp (hp)) - -#define Num_tags (1 << 8) -#ifdef ARCH_SIXTYFOUR -#define Max_wosize (((intnat)1 << 54) - 1) -#else -#define Max_wosize ((1 << 22) - 1) -#endif - -#define Wosize_val(val) (Wosize_hd (Hd_val (val))) -#define Wosize_op(op) (Wosize_val (op)) -#define Wosize_bp(bp) (Wosize_val (bp)) -#define Wosize_hp(hp) (Wosize_hd (Hd_hp (hp))) -#define Whsize_wosize(sz) ((sz) + 1) -#define Wosize_whsize(sz) ((sz) - 1) -#define Wosize_bhsize(sz) ((sz) / sizeof (value) - 1) -#define Bsize_wsize(sz) ((sz) * sizeof (value)) -#define Wsize_bsize(sz) ((sz) / sizeof (value)) -#define Bhsize_wosize(sz) (Bsize_wsize (Whsize_wosize (sz))) -#define Bhsize_bosize(sz) ((sz) + sizeof (header_t)) -#define Bosize_val(val) (Bsize_wsize (Wosize_val (val))) -#define Bosize_op(op) (Bosize_val (Val_op (op))) -#define Bosize_bp(bp) (Bosize_val (Val_bp (bp))) -#define Bosize_hd(hd) (Bsize_wsize (Wosize_hd (hd))) -#define Whsize_hp(hp) (Whsize_wosize (Wosize_hp (hp))) -#define Whsize_val(val) (Whsize_hp (Hp_val (val))) -#define Whsize_bp(bp) (Whsize_val (Val_bp (bp))) -#define Whsize_hd(hd) (Whsize_wosize (Wosize_hd (hd))) -#define Bhsize_hp(hp) (Bsize_wsize (Whsize_hp (hp))) -#define Bhsize_hd(hd) (Bsize_wsize (Whsize_hd (hd))) - -#ifdef ARCH_BIG_ENDIAN -#define Tag_val(val) (((unsigned char *) (val)) [-1]) - /* Also an l-value. */ -#define Tag_hp(hp) (((unsigned char *) (hp)) [sizeof(value)-1]) - /* Also an l-value. */ -#else -#define Tag_val(val) (((unsigned char *) (val)) [-sizeof(value)]) - /* Also an l-value. */ -#define Tag_hp(hp) (((unsigned char *) (hp)) [0]) - /* Also an l-value. */ -#endif - -/* The lowest tag for blocks containing no value. */ -#define No_scan_tag 251 - - -/* 1- If tag < No_scan_tag : a tuple of fields. */ - -/* Pointer to the first field. */ -#define Op_val(x) ((value *) (x)) -/* Fields are numbered from 0. */ -#define Field(x, i) (((value *)(x)) [i]) /* Also an l-value. */ - -typedef int32 opcode_t; -typedef opcode_t * code_t; - -/* NOTE: [Forward_tag] and [Infix_tag] must be just under - [No_scan_tag], with [Infix_tag] the lower one. - See [caml_oldify_one] in minor_gc.c for more details. - - NOTE: Update stdlib/obj.ml whenever you change the tags. - */ - -/* Forward_tag: forwarding pointer that the GC may silently shortcut. - See stdlib/lazy.ml. */ -#define Forward_tag 250 -#define Forward_val(v) Field(v, 0) - -/* If tag == Infix_tag : an infix header inside a closure */ -/* Infix_tag must be odd so that the infix header is scanned as an integer */ -/* Infix_tag must be 1 modulo 4 and infix headers can only occur in blocks - with tag Closure_tag (see compact.c). */ - -#define Infix_tag 249 -#define Infix_offset_hd(hd) (Bosize_hd(hd)) -#define Infix_offset_val(v) Infix_offset_hd(Hd_val(v)) - -/* Another special case: objects */ -#define Object_tag 248 -#define Class_val(val) Field((val), 0) -#define Oid_val(val) Long_val(Field((val), 1)) -CAMLextern value caml_get_public_method (value obj, value tag); -/* Called as: - caml_callback(caml_get_public_method(obj, caml_hash_variant(name)), obj) */ -/* caml_get_public_method returns 0 if tag not in the table. - Note however that tags being hashed, same tag does not necessarily mean - same method name. */ - -/* Special case of tuples of fields: closures */ -#define Closure_tag 247 -#define Code_val(val) (((code_t *) (val)) [0]) /* Also an l-value. */ - -/* This tag is used (with Forward_tag) to implement lazy values. - See major_gc.c and stdlib/lazy.ml. */ -#define Lazy_tag 246 - -/* Another special case: variants */ -CAMLextern value caml_hash_variant(char const * tag); - -/* 2- If tag >= No_scan_tag : a sequence of bytes. */ - -/* Pointer to the first byte */ -#define Bp_val(v) ((char *) (v)) -#define Val_bp(p) ((value) (p)) -/* Bytes are numbered from 0. */ -#define Byte(x, i) (((char *) (x)) [i]) /* Also an l-value. */ -#define Byte_u(x, i) (((unsigned char *) (x)) [i]) /* Also an l-value. */ - -/* Abstract things. Their contents is not traced by the GC; therefore they - must not contain any [value]. -*/ -#define Abstract_tag 251 - -/* Strings. */ -#define String_tag 252 -#define String_val(x) ((char *) Bp_val(x)) -CAMLextern mlsize_t caml_string_length (value); /* size in bytes */ - -/* Floating-point numbers. */ -#define Double_tag 253 -#define Double_wosize ((sizeof(double) / sizeof(value))) -#ifndef ARCH_ALIGN_DOUBLE -#define Double_val(v) (* (double *)(v)) -#define Store_double_val(v,d) (* (double *)(v) = (d)) -#else -CAMLextern double caml_Double_val (value); -CAMLextern void caml_Store_double_val (value,double); -#define Double_val(v) caml_Double_val(v) -#define Store_double_val(v,d) caml_Store_double_val(v,d) -#endif - -/* Arrays of floating-point numbers. */ -#define Double_array_tag 254 -#define Double_field(v,i) Double_val((value)((double *)(v) + (i))) -#define Store_double_field(v,i,d) do{ \ - mlsize_t caml__temp_i = (i); \ - double caml__temp_d = (d); \ - Store_double_val((value)((double *) (v) + caml__temp_i), caml__temp_d); \ -}while(0) -CAMLextern mlsize_t caml_array_length (value); /* size in items */ -CAMLextern int caml_is_double_array (value); /* 0 is false, 1 is true */ - - -/* Custom blocks. They contain a pointer to a "method suite" - of functions (for finalization, comparison, hashing, etc) - followed by raw data. The contents of custom blocks is not traced by - the GC; therefore, they must not contain any [value]. - See [custom.h] for operations on method suites. */ -#define Custom_tag 255 -#define Data_custom_val(v) ((void *) &Field((v), 1)) -struct custom_operations; /* defined in [custom.h] */ - -/* Int32.t, Int64.t and Nativeint.t are represented as custom blocks. */ - -#define Int32_val(v) (*((int32 *) Data_custom_val(v))) -#define Nativeint_val(v) (*((intnat *) Data_custom_val(v))) -#ifndef ARCH_ALIGN_INT64 -#define Int64_val(v) (*((int64 *) Data_custom_val(v))) -#else -CAMLextern int64 caml_Int64_val(value v); -#define Int64_val(v) caml_Int64_val(v) -#endif - -/* 3- Atoms are 0-tuples. They are statically allocated once and for all. */ - -CAMLextern header_t caml_atom_table[]; -#define Atom(tag) (Val_hp (&(caml_atom_table [(tag)]))) - -/* Booleans are integers 0 or 1 */ - -#define Val_bool(x) Val_int((x) != 0) -#define Bool_val(x) Int_val(x) -#define Val_false Val_int(0) -#define Val_true Val_int(1) -#define Val_not(x) (Val_false + Val_true - (x)) - -/* The unit value is 0 (tagged) */ - -#define Val_unit Val_int(0) - -/* List constructors */ -#define Val_emptylist Val_int(0) -#define Tag_cons 0 - -/* The table of global identifiers */ - -extern value caml_global_data; - -#ifdef __cplusplus -} -#endif - - -#endif /* CAML_MLVALUES_H */ diff -Nru ocaml-4.01.0/byterun/obj.c ocaml-4.02.3/byterun/obj.c --- ocaml-4.01.0/byterun/obj.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/obj.c 2015-04-12 11:03:39.000000000 +0200 @@ -14,16 +14,16 @@ /* Operations on objects */ #include -#include "alloc.h" -#include "fail.h" -#include "gc.h" -#include "interp.h" -#include "major_gc.h" -#include "memory.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "prims.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/gc.h" +#include "caml/interp.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/prims.h" CAMLprim value caml_static_alloc(value size) { @@ -247,3 +247,15 @@ } } #endif /*CAML_JIT*/ + +static value oo_last_id = Val_int(0); + +CAMLprim value caml_set_oo_id (value obj) { + Field(obj, 1) = oo_last_id; + oo_last_id += 2; + return obj; +} + +CAMLprim value caml_int_as_pointer (value n) { + return n - 1; +} diff -Nru ocaml-4.01.0/byterun/osdeps.h ocaml-4.02.3/byterun/osdeps.h --- ocaml-4.01.0/byterun/osdeps.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/osdeps.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,69 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2001 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Operating system - specific stuff */ - -#ifndef CAML_OSDEPS_H -#define CAML_OSDEPS_H - -#include "misc.h" - -/* Decompose the given path into a list of directories, and add them - to the given table. Return the block to be freed later. */ -extern char * caml_decompose_path(struct ext_table * tbl, char * path); - -/* Search the given file in the given list of directories. - If not found, return a copy of [name]. Result is allocated with - [caml_stat_alloc]. */ -extern char * caml_search_in_path(struct ext_table * path, char * name); - -/* Same, but search an executable name in the system path for executables. */ -CAMLextern char * caml_search_exe_in_path(char * name); - -/* Same, but search a shared library in the given path. */ -extern char * caml_search_dll_in_path(struct ext_table * path, char * name); - -/* Open a shared library and return a handle on it. - If [for_execution] is true, perform full symbol resolution and - execute initialization code so that functions from the shared library - can be called. If [for_execution] is false, functions from this - shared library will not be called, but just checked for presence, - so symbol resolution can be skipped. - If [global] is true, symbols from the shared library can be used - to resolve for other libraries to be opened later on. - Return [NULL] on error. */ -extern void * caml_dlopen(char * libname, int for_execution, int global); - -/* Close a shared library handle */ -extern void caml_dlclose(void * handle); - -/* Look up the given symbol in the given shared library. - Return [NULL] if not found, or symbol value if found. */ -extern void * caml_dlsym(void * handle, char * name); - -extern void * caml_globalsym(char * name); - -/* Return an error message describing the most recent dynlink failure. */ -extern char * caml_dlerror(void); - -/* Add to [contents] the (short) names of the files contained in - the directory named [dirname]. No entries are added for [.] and [..]. - Return 0 on success, -1 on error; set errno in the case of error. */ -extern int caml_read_directory(char * dirname, struct ext_table * contents); - -#ifdef __linux__ -/* Recover executable name from /proc/self/exe if possible */ -extern int caml_executable_name(char * name, int name_len); -#endif - -#endif /* CAML_OSDEPS_H */ diff -Nru ocaml-4.01.0/byterun/parsing.c ocaml-4.02.3/byterun/parsing.c --- ocaml-4.01.0/byterun/parsing.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/parsing.c 2015-04-12 11:03:39.000000000 +0200 @@ -15,10 +15,10 @@ #include #include -#include "config.h" -#include "mlvalues.h" -#include "memory.h" -#include "alloc.h" +#include "caml/config.h" +#include "caml/mlvalues.h" +#include "caml/memory.h" +#include "caml/alloc.h" #define ERRCODE 256 @@ -63,7 +63,7 @@ #if defined(ARCH_BIG_ENDIAN) || SIZEOF_SHORT != 2 #define Short(tbl,n) \ (*((unsigned char *)((tbl) + (n) * 2)) + \ - (*((schar *)((tbl) + (n) * 2 + 1)) << 8)) + (*((signed char *)((tbl) + (n) * 2 + 1)) << 8)) #else #define Short(tbl,n) (((short *)(tbl))[n]) #endif diff -Nru ocaml-4.01.0/byterun/prims.h ocaml-4.02.3/byterun/prims.h --- ocaml-4.01.0/byterun/prims.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/prims.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,34 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Interface with C primitives. */ - -#ifndef CAML_PRIMS_H -#define CAML_PRIMS_H - -typedef value (*c_primitive)(); - -extern c_primitive caml_builtin_cprim[]; -extern char * caml_names_of_builtin_cprim[]; - -extern struct ext_table caml_prim_table; -#ifdef DEBUG -extern struct ext_table caml_prim_name_table; -#endif - -#define Primitive(n) ((c_primitive)(caml_prim_table.contents[n])) - -extern char * caml_section_table; -extern asize_t caml_section_table_size; - -#endif /* CAML_PRIMS_H */ diff -Nru ocaml-4.01.0/byterun/printexc.c ocaml-4.02.3/byterun/printexc.c --- ocaml-4.01.0/byterun/printexc.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/printexc.c 2015-04-12 11:03:39.000000000 +0200 @@ -16,13 +16,13 @@ #include #include #include -#include "backtrace.h" -#include "callback.h" -#include "debugger.h" -#include "fail.h" -#include "misc.h" -#include "mlvalues.h" -#include "printexc.h" +#include "caml/backtrace.h" +#include "caml/callback.h" +#include "caml/debugger.h" +#include "caml/fail.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/printexc.h" struct stringbuf { char * ptr; @@ -53,8 +53,8 @@ buf.ptr = buf.data; buf.end = buf.data + sizeof(buf.data) - 1; - add_string(&buf, String_val(Field(Field(exn, 0), 0))); - if (Wosize_val(exn) >= 2) { + if (Tag_val(exn) == 0) { + add_string(&buf, String_val(Field(Field(exn, 0), 0))); /* Check for exceptions in the style of Match_failure and Assert_failure */ if (Wosize_val(exn) == 2 && Is_block(Field(exn, 1)) && @@ -71,7 +71,8 @@ if (i > start) add_string(&buf, ", "); v = Field(bucket, i); if (Is_long(v)) { - sprintf(intbuf, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v)); + snprintf(intbuf, sizeof(intbuf), + "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v)); add_string(&buf, intbuf); } else if (Tag_val(v) == String_tag) { add_char(&buf, '"'); @@ -82,7 +83,9 @@ } } add_char(&buf, ')'); - } + } else + add_string(&buf, String_val(Field(exn, 0))); + *buf.ptr = 0; /* Terminate string */ i = buf.ptr - buf.data + 1; res = malloc(i); @@ -92,7 +95,14 @@ } -void caml_fatal_uncaught_exception(value exn) +#ifdef NATIVE_CODE +# define DEBUGGER_IN_USE 0 +#else +# define DEBUGGER_IN_USE caml_debugger_in_use +#endif + +/* Default C implementation in case the OCaml one is not registered. */ +static void default_fatal_uncaught_exception(value exn) { char * msg; value * at_exit; @@ -113,13 +123,21 @@ fprintf(stderr, "Fatal error: exception %s\n", msg); free(msg); /* Display the backtrace if available */ - if (caml_backtrace_active -#ifndef NATIVE_CODE - && !caml_debugger_in_use -#endif - ) { + if (caml_backtrace_active && !DEBUGGER_IN_USE) caml_print_exception_backtrace(); - } +} + +void caml_fatal_uncaught_exception(value exn) +{ + value *handle_uncaught_exception; + + handle_uncaught_exception = + caml_named_value("Printexc.handle_uncaught_exception"); + if (handle_uncaught_exception != NULL) + /* [Printexc.handle_uncaught_exception] does not raise exception. */ + caml_callback2(*handle_uncaught_exception, exn, Val_bool(DEBUGGER_IN_USE)); + else + default_fatal_uncaught_exception(exn); /* Terminate the process */ exit(2); } diff -Nru ocaml-4.01.0/byterun/printexc.h ocaml-4.02.3/byterun/printexc.h --- ocaml-4.01.0/byterun/printexc.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/printexc.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,33 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2001 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_PRINTEXC_H -#define CAML_PRINTEXC_H - - -#include "misc.h" -#include "mlvalues.h" - -#ifdef __cplusplus -extern "C" { -#endif - - -CAMLextern char * caml_format_exception (value); -void caml_fatal_uncaught_exception (value) Noreturn; - -#ifdef __cplusplus -} -#endif - -#endif /* CAML_PRINTEXC_H */ diff -Nru ocaml-4.01.0/byterun/reverse.h ocaml-4.02.3/byterun/reverse.h --- ocaml-4.01.0/byterun/reverse.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/reverse.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,86 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Swap byte-order in 16, 32, and 64-bit integers or floats */ - -#ifndef CAML_REVERSE_H -#define CAML_REVERSE_H - -#define Reverse_16(dst,src) { \ - char * _p, * _q; \ - char _a; \ - _p = (char *) (src); \ - _q = (char *) (dst); \ - _a = _p[0]; \ - _q[0] = _p[1]; \ - _q[1] = _a; \ -} - -#define Reverse_32(dst,src) { \ - char * _p, * _q; \ - char _a, _b; \ - _p = (char *) (src); \ - _q = (char *) (dst); \ - _a = _p[0]; \ - _b = _p[1]; \ - _q[0] = _p[3]; \ - _q[1] = _p[2]; \ - _q[3] = _a; \ - _q[2] = _b; \ -} - -#define Reverse_64(dst,src) { \ - char * _p, * _q; \ - char _a, _b; \ - _p = (char *) (src); \ - _q = (char *) (dst); \ - _a = _p[0]; \ - _b = _p[1]; \ - _q[0] = _p[7]; \ - _q[1] = _p[6]; \ - _q[7] = _a; \ - _q[6] = _b; \ - _a = _p[2]; \ - _b = _p[3]; \ - _q[2] = _p[5]; \ - _q[3] = _p[4]; \ - _q[5] = _a; \ - _q[4] = _b; \ -} - -#define Perm_index(perm,i) ((perm >> (i * 4)) & 0xF) - -#define Permute_64(dst,perm_dst,src,perm_src) { \ - char * _p; \ - char _a, _b, _c, _d, _e, _f, _g, _h; \ - _p = (char *) (src); \ - _a = _p[Perm_index(perm_src, 0)]; \ - _b = _p[Perm_index(perm_src, 1)]; \ - _c = _p[Perm_index(perm_src, 2)]; \ - _d = _p[Perm_index(perm_src, 3)]; \ - _e = _p[Perm_index(perm_src, 4)]; \ - _f = _p[Perm_index(perm_src, 5)]; \ - _g = _p[Perm_index(perm_src, 6)]; \ - _h = _p[Perm_index(perm_src, 7)]; \ - _p = (char *) (dst); \ - _p[Perm_index(perm_dst, 0)] = _a; \ - _p[Perm_index(perm_dst, 1)] = _b; \ - _p[Perm_index(perm_dst, 2)] = _c; \ - _p[Perm_index(perm_dst, 3)] = _d; \ - _p[Perm_index(perm_dst, 4)] = _e; \ - _p[Perm_index(perm_dst, 5)] = _f; \ - _p[Perm_index(perm_dst, 6)] = _g; \ - _p[Perm_index(perm_dst, 7)] = _h; \ -} - -#endif /* CAML_REVERSE_H */ diff -Nru ocaml-4.01.0/byterun/roots.c ocaml-4.02.3/byterun/roots.c --- ocaml-4.01.0/byterun/roots.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/roots.c 2015-04-12 11:03:39.000000000 +0200 @@ -13,15 +13,15 @@ /* To walk the memory roots for garbage collection */ -#include "finalise.h" -#include "globroots.h" -#include "major_gc.h" -#include "memory.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "roots.h" -#include "stacks.h" +#include "caml/finalise.h" +#include "caml/globroots.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/stacks.h" CAMLexport struct caml__roots_block *caml_local_roots = NULL; diff -Nru ocaml-4.01.0/byterun/roots.h ocaml-4.02.3/byterun/roots.h --- ocaml-4.01.0/byterun/roots.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/roots.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,36 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_ROOTS_H -#define CAML_ROOTS_H - -#include "misc.h" -#include "memory.h" - -typedef void (*scanning_action) (value, value *); - -void caml_oldify_local_roots (void); -void caml_darken_all_roots (void); -void caml_do_roots (scanning_action); -#ifndef NATIVE_CODE -CAMLextern void caml_do_local_roots (scanning_action, value *, value *, - struct caml__roots_block *); -#else -CAMLextern void caml_do_local_roots(scanning_action f, char * bottom_of_stack, - uintnat last_retaddr, value * gc_regs, - struct caml__roots_block * local_roots); -#endif - -CAMLextern void (*caml_scan_roots_hook) (scanning_action); - -#endif /* CAML_ROOTS_H */ diff -Nru ocaml-4.01.0/byterun/signals_byt.c ocaml-4.02.3/byterun/signals_byt.c --- ocaml-4.01.0/byterun/signals_byt.c 2013-05-14 17:37:48.000000000 +0200 +++ ocaml-4.02.3/byterun/signals_byt.c 2015-04-12 11:03:39.000000000 +0200 @@ -15,11 +15,11 @@ #include #include -#include "config.h" -#include "memory.h" -#include "osdeps.h" -#include "signals.h" -#include "signals_machdep.h" +#include "caml/config.h" +#include "caml/memory.h" +#include "caml/osdeps.h" +#include "caml/signals.h" +#include "caml/signals_machdep.h" #ifndef NSIG #define NSIG 64 diff -Nru ocaml-4.01.0/byterun/signals.c ocaml-4.02.3/byterun/signals.c --- ocaml-4.01.0/byterun/signals.c 2013-05-14 17:48:50.000000000 +0200 +++ ocaml-4.02.3/byterun/signals.c 2015-04-12 11:03:39.000000000 +0200 @@ -15,17 +15,17 @@ #include #include -#include "alloc.h" -#include "callback.h" -#include "config.h" -#include "fail.h" -#include "memory.h" -#include "misc.h" -#include "mlvalues.h" -#include "roots.h" -#include "signals.h" -#include "signals_machdep.h" -#include "sys.h" +#include "caml/alloc.h" +#include "caml/callback.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/roots.h" +#include "caml/signals.h" +#include "caml/signals_machdep.h" +#include "caml/sys.h" #ifndef NSIG #define NSIG 64 diff -Nru ocaml-4.01.0/byterun/signals.h ocaml-4.02.3/byterun/signals.h --- ocaml-4.01.0/byterun/signals.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/signals.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,57 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_SIGNALS_H -#define CAML_SIGNALS_H - -#ifndef CAML_NAME_SPACE -#include "compatibility.h" -#endif -#include "misc.h" -#include "mlvalues.h" - -#ifdef __cplusplus -extern "C" { -#endif - -/* */ -CAMLextern intnat volatile caml_signals_are_pending; -CAMLextern intnat volatile caml_pending_signals[]; -CAMLextern int volatile caml_something_to_do; -extern int volatile caml_force_major_slice; -/* */ - -CAMLextern void caml_enter_blocking_section (void); -CAMLextern void caml_leave_blocking_section (void); - -/* */ -void caml_urge_major_slice (void); -CAMLextern int caml_convert_signal_number (int); -CAMLextern int caml_rev_convert_signal_number (int); -void caml_execute_signal(int signal_number, int in_signal_handler); -void caml_record_signal(int signal_number); -void caml_process_pending_signals(void); -void caml_process_event(void); -int caml_set_signal_action(int signo, int action); - -CAMLextern void (*caml_enter_blocking_section_hook)(void); -CAMLextern void (*caml_leave_blocking_section_hook)(void); -CAMLextern int (*caml_try_leave_blocking_section_hook)(void); -CAMLextern void (* volatile caml_async_action_hook)(void); -/* */ - -#ifdef __cplusplus -} -#endif - -#endif /* CAML_SIGNALS_H */ diff -Nru ocaml-4.01.0/byterun/signals_machdep.h ocaml-4.02.3/byterun/signals_machdep.h --- ocaml-4.01.0/byterun/signals_machdep.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/signals_machdep.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,60 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Processor-specific operation: atomic "read and clear" */ - -#ifndef CAML_SIGNALS_MACHDEP_H -#define CAML_SIGNALS_MACHDEP_H - -#if defined(__GNUC__) && defined(__i386__) - -#define Read_and_clear(dst,src) \ - asm("xorl %0, %0; xchgl %0, %1" \ - : "=r" (dst), "=m" (src) \ - : "m" (src)) - -#elif defined(__GNUC__) && defined(__x86_64__) - -#define Read_and_clear(dst,src) \ - asm("xorq %0, %0; xchgq %0, %1" \ - : "=r" (dst), "=m" (src) \ - : "m" (src)) - -#elif defined(__GNUC__) && defined(__ppc__) - -#define Read_and_clear(dst,src) \ - asm("0: lwarx %0, 0, %1\n\t" \ - "stwcx. %2, 0, %1\n\t" \ - "bne- 0b" \ - : "=&r" (dst) \ - : "r" (&(src)), "r" (0) \ - : "cr0", "memory") - -#elif defined(__GNUC__) && defined(__ppc64__) - -#define Read_and_clear(dst,src) \ - asm("0: ldarx %0, 0, %1\n\t" \ - "stdcx. %2, 0, %1\n\t" \ - "bne- 0b" \ - : "=&r" (dst) \ - : "r" (&(src)), "r" (0) \ - : "cr0", "memory") - -#else - -/* Default, non-atomic implementation */ -#define Read_and_clear(dst,src) ((dst) = (src), (src) = 0) - -#endif - -#endif /* CAML_SIGNALS_MACHDEP_H */ diff -Nru ocaml-4.01.0/byterun/stacks.c ocaml-4.02.3/byterun/stacks.c --- ocaml-4.01.0/byterun/stacks.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/stacks.c 2015-04-12 11:03:39.000000000 +0200 @@ -14,11 +14,11 @@ /* To initialize and resize the stacks */ #include -#include "config.h" -#include "fail.h" -#include "misc.h" -#include "mlvalues.h" -#include "stacks.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/stacks.h" CAMLexport value * caml_stack_low; CAMLexport value * caml_stack_high; diff -Nru ocaml-4.01.0/byterun/stacks.h ocaml-4.02.3/byterun/stacks.h --- ocaml-4.01.0/byterun/stacks.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/stacks.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,41 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* structure of the stacks */ - -#ifndef CAML_STACKS_H -#define CAML_STACKS_H - - -#include "misc.h" -#include "mlvalues.h" -#include "memory.h" - -CAMLextern value * caml_stack_low; -CAMLextern value * caml_stack_high; -CAMLextern value * caml_stack_threshold; -CAMLextern value * caml_extern_sp; -CAMLextern value * caml_trapsp; -CAMLextern value * caml_trap_barrier; - -#define Trap_pc(tp) (((code_t *)(tp))[0]) -#define Trap_link(tp) (((value **)(tp))[1]) - -void caml_init_stack (uintnat init_max_size); -void caml_realloc_stack (asize_t required_size); -void caml_change_max_stack_size (uintnat new_max_size); -uintnat caml_stack_usage (void); - -CAMLextern uintnat (*caml_stack_usage_hook)(void); - -#endif /* CAML_STACKS_H */ diff -Nru ocaml-4.01.0/byterun/startup.c ocaml-4.02.3/byterun/startup.c --- ocaml-4.01.0/byterun/startup.c 2013-08-01 11:18:15.000000000 +0200 +++ ocaml-4.02.3/byterun/startup.c 2015-04-12 11:03:39.000000000 +0200 @@ -17,41 +17,41 @@ #include #include #include -#include "config.h" +#include "caml/config.h" #ifdef HAS_UNISTD #include #endif #ifdef _WIN32 #include #endif -#include "alloc.h" -#include "backtrace.h" -#include "callback.h" -#include "custom.h" -#include "debugger.h" -#include "dynlink.h" -#include "exec.h" -#include "fail.h" -#include "fix_code.h" -#include "freelist.h" -#include "gc_ctrl.h" -#include "instrtrace.h" -#include "interp.h" -#include "intext.h" -#include "io.h" -#include "memory.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "osdeps.h" -#include "prims.h" -#include "printexc.h" -#include "reverse.h" -#include "signals.h" -#include "stacks.h" -#include "sys.h" -#include "startup.h" -#include "version.h" +#include "caml/alloc.h" +#include "caml/backtrace.h" +#include "caml/callback.h" +#include "caml/custom.h" +#include "caml/debugger.h" +#include "caml/dynlink.h" +#include "caml/exec.h" +#include "caml/fail.h" +#include "caml/fix_code.h" +#include "caml/freelist.h" +#include "caml/gc_ctrl.h" +#include "caml/instrtrace.h" +#include "caml/interp.h" +#include "caml/intext.h" +#include "caml/io.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/osdeps.h" +#include "caml/prims.h" +#include "caml/printexc.h" +#include "caml/reverse.h" +#include "caml/signals.h" +#include "caml/stacks.h" +#include "caml/sys.h" +#include "caml/startup.h" +#include "caml/version.h" #ifndef O_BINARY #define O_BINARY 0 @@ -246,10 +246,10 @@ #endif case 'v': if (!strcmp (argv[i], "-version")){ - printf ("The OCaml runtime, version " OCAML_VERSION "\n"); + printf ("The OCaml runtime, version " OCAML_VERSION_STRING "\n"); exit (0); }else if (!strcmp (argv[i], "-vnum")){ - printf (OCAML_VERSION "\n"); + printf (OCAML_VERSION_STRING "\n"); exit (0); }else{ caml_verb_gc = 0x001+0x004+0x008+0x010+0x020; @@ -350,9 +350,7 @@ value res; char * shared_lib_path, * shared_libs, * req_prims; char * exe_name; -#ifdef __linux__ static char proc_self_exe[256]; -#endif /* Machine-dependent initialization of the floating-point hardware so that it behaves as much as possible as specified in IEEE */ @@ -369,12 +367,19 @@ #endif parse_camlrunparam(); pos = 0; + + /* First, try argv[0] (when ocamlrun is called by a bytecode program) */ exe_name = argv[0]; -#ifdef __linux__ - if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) - exe_name = proc_self_exe; -#endif fd = caml_attempt_open(&exe_name, &trail, 0); + + /* Should we really do that at all? The current executable is ocamlrun + itself, it's never a bytecode program. */ + if (fd < 0 + && caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) { + exe_name = proc_self_exe; + fd = caml_attempt_open(&exe_name, &trail, 0); + } + if (fd < 0) { pos = parse_command_line(argv); if (argv[pos] == 0) @@ -425,7 +430,6 @@ caml_oldify_one (caml_global_data, &caml_global_data); caml_oldify_mopup (); /* Initialize system libraries */ - caml_init_exceptions(); caml_sys_init(exe_name, argv + pos); #ifdef _WIN32 /* Start a thread to handle signals */ @@ -455,11 +459,9 @@ char **argv) { value res; - char* cds_file; + char * cds_file; char * exe_name; -#ifdef __linux__ static char proc_self_exe[256]; -#endif caml_init_ieee_floats(); #ifdef _MSC_VER @@ -471,15 +473,12 @@ #endif cds_file = getenv("CAML_DEBUG_FILE"); if (cds_file != NULL) { - caml_cds_file = caml_stat_alloc(strlen(cds_file) + 1); - strcpy(caml_cds_file, cds_file); + caml_cds_file = caml_strdup(cds_file); } parse_camlrunparam(); exe_name = argv[0]; -#ifdef __linux__ if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) exe_name = proc_self_exe; -#endif caml_external_raise = NULL; /* Initialize the abstract machine */ caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init, @@ -514,7 +513,6 @@ caml_section_table = section_table; caml_section_table_size = section_table_size; /* Initialize system libraries */ - caml_init_exceptions(); caml_sys_init(exe_name, argv); /* Execute the program */ caml_debugger(PROGRAM_START); diff -Nru ocaml-4.01.0/byterun/startup.h ocaml-4.02.3/byterun/startup.h --- ocaml-4.01.0/byterun/startup.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/startup.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,38 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2001 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_STARTUP_H -#define CAML_STARTUP_H - -#include "mlvalues.h" -#include "exec.h" - -CAMLextern void caml_main(char **argv); - -CAMLextern void caml_startup_code( - code_t code, asize_t code_size, - char *data, asize_t data_size, - char *section_table, asize_t section_table_size, - char **argv); - -enum { FILE_NOT_FOUND = -1, BAD_BYTECODE = -2 }; - -extern int caml_attempt_open(char **name, struct exec_trailer *trail, - int do_open_script); -extern void caml_read_section_descriptors(int fd, struct exec_trailer *trail); -extern int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, - char *name); -extern int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name); - - -#endif /* CAML_STARTUP_H */ diff -Nru ocaml-4.01.0/byterun/str.c ocaml-4.02.3/byterun/str.c --- ocaml-4.01.0/byterun/str.c 2012-12-19 17:22:30.000000000 +0100 +++ ocaml-4.02.3/byterun/str.c 2015-04-12 11:03:39.000000000 +0200 @@ -15,10 +15,12 @@ #include #include -#include "alloc.h" -#include "fail.h" -#include "mlvalues.h" -#include "misc.h" +#include +#include +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/mlvalues.h" +#include "caml/misc.h" #ifdef HAS_LOCALE #include #endif @@ -68,7 +70,7 @@ intnat res; unsigned char b1, b2; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 1) caml_array_bound_error(); + if (idx < 0 || idx + 1 >= caml_string_length(str)) caml_array_bound_error(); b1 = Byte_u(str, idx); b2 = Byte_u(str, idx + 1); #ifdef ARCH_BIG_ENDIAN @@ -84,7 +86,7 @@ intnat res; unsigned char b1, b2, b3, b4; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 3) caml_array_bound_error(); + if (idx < 0 || idx + 3 >= caml_string_length(str)) caml_array_bound_error(); b1 = Byte_u(str, idx); b2 = Byte_u(str, idx + 1); b3 = Byte_u(str, idx + 2); @@ -97,19 +99,12 @@ return caml_copy_int32(res); } -#ifdef ARCH_INT64_TYPE -#include "int64_native.h" -#else -#include "int64_emul.h" -#endif - CAMLprim value caml_string_get64(value str, value index) { - uint32 reshi; - uint32 reslo; + uint64 res; unsigned char b1, b2, b3, b4, b5, b6, b7, b8; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 7) caml_array_bound_error(); + if (idx < 0 || idx + 7 >= caml_string_length(str)) caml_array_bound_error(); b1 = Byte_u(str, idx); b2 = Byte_u(str, idx + 1); b3 = Byte_u(str, idx + 2); @@ -119,13 +114,17 @@ b7 = Byte_u(str, idx + 6); b8 = Byte_u(str, idx + 7); #ifdef ARCH_BIG_ENDIAN - reshi = b1 << 24 | b2 << 16 | b3 << 8 | b4; - reslo = b5 << 24 | b6 << 16 | b7 << 8 | b8; + res = (uint64) b1 << 56 | (uint64) b2 << 48 + | (uint64) b3 << 40 | (uint64) b4 << 32 + | (uint64) b5 << 24 | (uint64) b6 << 16 + | (uint64) b7 << 8 | (uint64) b8; #else - reshi = b8 << 24 | b7 << 16 | b6 << 8 | b5; - reslo = b4 << 24 | b3 << 16 | b2 << 8 | b1; + res = (uint64) b8 << 56 | (uint64) b7 << 48 + | (uint64) b6 << 40 | (uint64) b5 << 32 + | (uint64) b4 << 24 | (uint64) b3 << 16 + | (uint64) b2 << 8 | (uint64) b1; #endif - return caml_copy_int64(I64_literal(reshi,reslo)); + return caml_copy_int64(res); } CAMLprim value caml_string_set16(value str, value index, value newval) @@ -133,7 +132,7 @@ unsigned char b1, b2; intnat val; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 1) caml_array_bound_error(); + if (idx < 0 || idx + 1 >= caml_string_length(str)) caml_array_bound_error(); val = Long_val(newval); #ifdef ARCH_BIG_ENDIAN b1 = 0xFF & val >> 8; @@ -152,7 +151,7 @@ unsigned char b1, b2, b3, b4; intnat val; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 3) caml_array_bound_error(); + if (idx < 0 || idx + 3 >= caml_string_length(str)) caml_array_bound_error(); val = Int32_val(newval); #ifdef ARCH_BIG_ENDIAN b1 = 0xFF & val >> 24; @@ -175,30 +174,28 @@ CAMLprim value caml_string_set64(value str, value index, value newval) { unsigned char b1, b2, b3, b4, b5, b6, b7, b8; - uint32 lo,hi; int64 val; intnat idx = Long_val(index); - if (idx < 0 || idx >= caml_string_length(str) - 7) caml_array_bound_error(); + if (idx < 0 || idx + 7 >= caml_string_length(str)) caml_array_bound_error(); val = Int64_val(newval); - I64_split(val,hi,lo); #ifdef ARCH_BIG_ENDIAN - b1 = 0xFF & hi >> 24; - b2 = 0xFF & hi >> 16; - b3 = 0xFF & hi >> 8; - b4 = 0xFF & hi; - b5 = 0xFF & lo >> 24; - b6 = 0xFF & lo >> 16; - b7 = 0xFF & lo >> 8; - b8 = 0xFF & lo; + b1 = 0xFF & val >> 56; + b2 = 0xFF & val >> 48; + b3 = 0xFF & val >> 40; + b4 = 0xFF & val >> 32; + b5 = 0xFF & val >> 24; + b6 = 0xFF & val >> 16; + b7 = 0xFF & val >> 8; + b8 = 0xFF & val; #else - b8 = 0xFF & hi >> 24; - b7 = 0xFF & hi >> 16; - b6 = 0xFF & hi >> 8; - b5 = 0xFF & hi; - b4 = 0xFF & lo >> 24; - b3 = 0xFF & lo >> 16; - b2 = 0xFF & lo >> 8; - b1 = 0xFF & lo; + b8 = 0xFF & val >> 56; + b7 = 0xFF & val >> 48; + b6 = 0xFF & val >> 40; + b5 = 0xFF & val >> 32; + b4 = 0xFF & val >> 24; + b3 = 0xFF & val >> 16; + b2 = 0xFF & val >> 8; + b1 = 0xFF & val; #endif Byte_u(str, idx) = b1; Byte_u(str, idx + 1) = b2; @@ -299,3 +296,68 @@ int pos = Int_val(n); return Val_int(Byte_u(bv, pos >> 3) & (1 << (pos & 7))); } + +CAMLexport value caml_alloc_sprintf(const char * format, ...) +{ + va_list args; + char buf[64]; + int n; + value res; + +#ifndef _WIN32 + /* C99-compliant implementation */ + va_start(args, format); + /* "vsnprintf(dest, sz, format, args)" writes at most "sz" characters + into "dest", including the terminating '\0'. + It returns the number of characters of the formatted string, + excluding the terminating '\0'. */ + n = vsnprintf(buf, sizeof(buf), format, args); + va_end(args); + /* Allocate a Caml string with length "n" as computed by vsnprintf. */ + res = caml_alloc_string(n); + if (n < sizeof(buf)) { + /* All output characters were written to buf, including the + terminating '\0'. Just copy them to the result. */ + memcpy(String_val(res), buf, n); + } else { + /* Re-do the formatting, outputting directly in the Caml string. + Note that caml_alloc_string left room for a '\0' at position n, + so the size passed to vsnprintf is n+1. */ + va_start(args, format); + vsnprintf(String_val(res), n + 1, format, args); + va_end(args); + } + return res; +#else + /* Implementation specific to the Microsoft CRT library */ + va_start(args, format); + /* "_vsnprintf(dest, sz, format, args)" writes at most "sz" characters + into "dest". Let "len" be the number of characters of the formatted + string. + If "len" < "sz", a null terminator was appended, and "len" is returned. + If "len" == "sz", no null termination, and "len" is returned. + If "len" > "sz", a negative value is returned. */ + n = _vsnprintf(buf, sizeof(buf), format, args); + va_end(args); + if (n >= 0 && n <= sizeof(buf)) { + /* All output characters were written to buf. + "n" is the actual length of the output. + Copy the characters to a Caml string of length n. */ + res = caml_alloc_string(n); + memcpy(String_val(res), buf, n); + } else { + /* Determine actual length of output, excluding final '\0' */ + va_start(args, format); + n = _vscprintf(format, args); + va_end(args); + res = caml_alloc_string(n); + /* Re-do the formatting, outputting directly in the Caml string. + Note that caml_alloc_string left room for a '\0' at position n, + so the size passed to _vsnprintf is n+1. */ + va_start(args, format); + _vsnprintf(String_val(res), n + 1, format, args); + va_end(args); + } + return res; +#endif +} diff -Nru ocaml-4.01.0/byterun/sys.c ocaml-4.02.3/byterun/sys.c --- ocaml-4.01.0/byterun/sys.c 2012-11-29 10:55:00.000000000 +0100 +++ ocaml-4.02.3/byterun/sys.c 2015-04-12 11:03:39.000000000 +0200 @@ -25,7 +25,7 @@ #if !_WIN32 #include #endif -#include "config.h" +#include "caml/config.h" #ifdef HAS_UNISTD #include #endif @@ -39,15 +39,15 @@ #ifdef HAS_GETTIMEOFDAY #include #endif -#include "alloc.h" -#include "debugger.h" -#include "fail.h" -#include "instruct.h" -#include "mlvalues.h" -#include "osdeps.h" -#include "signals.h" -#include "stacks.h" -#include "sys.h" +#include "caml/alloc.h" +#include "caml/debugger.h" +#include "caml/fail.h" +#include "caml/instruct.h" +#include "caml/mlvalues.h" +#include "caml/osdeps.h" +#include "caml/signals.h" +#include "caml/stacks.h" +#include "caml/sys.h" static char * error_message(void) { @@ -125,8 +125,7 @@ int fd, flags, perm; char * p; - p = caml_stat_alloc(caml_string_length(path) + 1); - strcpy(p, String_val(path)); + p = caml_strdup(String_val(path)); flags = caml_convert_flag_list(vflags, sys_open_flags); perm = Int_val(vperm); /* open on a named FIFO can block (PR#1533) */ @@ -145,46 +144,107 @@ CAMLprim value caml_sys_close(value fd) { + caml_enter_blocking_section(); close(Int_val(fd)); + caml_leave_blocking_section(); return Val_unit; } CAMLprim value caml_sys_file_exists(value name) { +#ifdef _WIN32 + struct _stati64 st; +#else struct stat st; - return Val_bool(stat(String_val(name), &st) == 0); +#endif + char * p; + int ret; + + p = caml_strdup(String_val(name)); + caml_enter_blocking_section(); +#ifdef _WIN32 + ret = _stati64(p, &st); +#else + ret = stat(p, &st); +#endif + caml_leave_blocking_section(); + caml_stat_free(p); + + return Val_bool(ret == 0); } CAMLprim value caml_sys_is_directory(value name) { + CAMLparam1(name); +#ifdef _WIN32 + struct _stati64 st; +#else struct stat st; - if (stat(String_val(name), &st) == -1) caml_sys_error(name); +#endif + char * p; + int ret; + + p = caml_strdup(String_val(name)); + caml_enter_blocking_section(); +#ifdef _WIN32 + ret = _stati64(p, &st); +#else + ret = stat(p, &st); +#endif + caml_leave_blocking_section(); + caml_stat_free(p); + + if (ret == -1) caml_sys_error(name); #ifdef S_ISDIR - return Val_bool(S_ISDIR(st.st_mode)); + CAMLreturn(Val_bool(S_ISDIR(st.st_mode))); #else - return Val_bool(st.st_mode & S_IFDIR); + CAMLreturn(Val_bool(st.st_mode & S_IFDIR)); #endif } CAMLprim value caml_sys_remove(value name) { + CAMLparam1(name); + char * p; int ret; - ret = unlink(String_val(name)); + p = caml_strdup(String_val(name)); + caml_enter_blocking_section(); + ret = unlink(p); + caml_leave_blocking_section(); + caml_stat_free(p); if (ret != 0) caml_sys_error(name); - return Val_unit; + CAMLreturn(Val_unit); } CAMLprim value caml_sys_rename(value oldname, value newname) { - if (rename(String_val(oldname), String_val(newname)) != 0) + char * p_old; + char * p_new; + int ret; + p_old = caml_strdup(String_val(oldname)); + p_new = caml_strdup(String_val(newname)); + caml_enter_blocking_section(); + ret = rename(p_old, p_new); + caml_leave_blocking_section(); + caml_stat_free(p_new); + caml_stat_free(p_old); + if (ret != 0) caml_sys_error(NO_ARG); return Val_unit; } CAMLprim value caml_sys_chdir(value dirname) { - if (chdir(String_val(dirname)) != 0) caml_sys_error(dirname); - return Val_unit; + CAMLparam1(dirname); + char * p; + int ret; + p = caml_strdup(String_val(dirname)); + caml_enter_blocking_section(); + ret = chdir(p); + caml_leave_blocking_section(); + caml_stat_free(p); + if (ret != 0) caml_sys_error(dirname); + CAMLreturn(Val_unit); } CAMLprim value caml_sys_getcwd(value unit) @@ -208,7 +268,7 @@ } char * caml_exe_name; -static char ** caml_main_argv; +char ** caml_main_argv; CAMLprim value caml_sys_get_argv(value unit) { @@ -244,11 +304,8 @@ CAMLparam1 (command); int status, retcode; char *buf; - intnat len; - len = caml_string_length (command); - buf = caml_stat_alloc (len + 1); - memmove (buf, String_val (command), len + 1); + buf = caml_strdup(String_val(command)); caml_enter_blocking_section (); status = system(buf); caml_leave_blocking_section (); @@ -385,9 +442,16 @@ CAMLparam1(path); CAMLlocal1(result); struct ext_table tbl; + char * p; + int ret; caml_ext_table_init(&tbl, 50); - if (caml_read_directory(String_val(path), &tbl) == -1){ + p = caml_strdup(String_val(path)); + caml_enter_blocking_section(); + ret = caml_read_directory(p, &tbl); + caml_leave_blocking_section(); + caml_stat_free(p); + if (ret == -1){ caml_ext_table_free(&tbl, 1); caml_sys_error(path); } diff -Nru ocaml-4.01.0/byterun/sys.h ocaml-4.02.3/byterun/sys.h --- ocaml-4.01.0/byterun/sys.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/sys.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,28 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -#ifndef CAML_SYS_H -#define CAML_SYS_H - -#include "misc.h" - -#define NO_ARG Val_int(0) - -CAMLextern void caml_sys_error (value); -CAMLextern void caml_sys_io_error (value); -extern void caml_sys_init (char * exe_name, char ** argv); -CAMLextern value caml_sys_exit (value); - -extern char * caml_exe_name; - -#endif /* CAML_SYS_H */ diff -Nru ocaml-4.01.0/byterun/terminfo.c ocaml-4.02.3/byterun/terminfo.c --- ocaml-4.01.0/byterun/terminfo.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/terminfo.c 2015-04-12 11:03:39.000000000 +0200 @@ -13,11 +13,11 @@ /* Read and output terminal commands */ -#include "config.h" -#include "alloc.h" -#include "fail.h" -#include "io.h" -#include "mlvalues.h" +#include "caml/config.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/io.h" +#include "caml/mlvalues.h" #define Uninitialised (Val_int(0)) #define Bad_term (Val_int(1)) diff -Nru ocaml-4.01.0/byterun/ui.h ocaml-4.02.3/byterun/ui.h --- ocaml-4.01.0/byterun/ui.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/ui.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,26 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Function declarations for non-Unix user interfaces */ - -#ifndef CAML_UI_H -#define CAML_UI_H - -#include "config.h" - -void ui_exit (int return_code); -int ui_read (int file_desc, char *buf, unsigned int length); -int ui_write (int file_desc, char *buf, unsigned int length); -void ui_print_stderr (char *format, void *arg); - -#endif /* CAML_UI_H */ diff -Nru ocaml-4.01.0/byterun/unix.c ocaml-4.02.3/byterun/unix.c --- ocaml-4.01.0/byterun/unix.c 2013-03-09 23:38:52.000000000 +0100 +++ ocaml-4.02.3/byterun/unix.c 2015-06-02 17:16:56.000000000 +0200 @@ -22,9 +22,9 @@ #include #include #include -#include "config.h" +#include "caml/config.h" #ifdef SUPPORT_DYNAMIC_LINKING -#ifdef __CYGWIN32__ +#ifdef __CYGWIN__ #include "flexdll.h" #else #include @@ -38,9 +38,9 @@ #else #include #endif -#include "memory.h" -#include "misc.h" -#include "osdeps.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/osdeps.h" #ifndef S_ISREG #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) @@ -49,11 +49,10 @@ char * caml_decompose_path(struct ext_table * tbl, char * path) { char * p, * q; - int n; + size_t n; if (path == NULL) return NULL; - p = caml_stat_alloc(strlen(path) + 1); - strcpy(p, path); + p = caml_strdup(path); q = p; while (1) { for (n = 0; q[n] != 0 && q[n] != ':'; n++) /*nothing*/; @@ -68,7 +67,7 @@ char * caml_search_in_path(struct ext_table * path, char * name) { - char * p, * fullname; + char * p, * dir, * fullname; int i; struct stat st; @@ -76,21 +75,18 @@ if (*p == '/') goto not_found; } for (i = 0; i < path->size; i++) { - fullname = caml_stat_alloc(strlen((char *)(path->contents[i])) + - strlen(name) + 2); - strcpy(fullname, (char *)(path->contents[i])); - if (fullname[0] != 0) strcat(fullname, "/"); - strcat(fullname, name); - if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname; + dir = path->contents[i]; + if (dir[0] == 0) dir = "."; /* empty path component = current dir */ + fullname = caml_strconcat(3, dir, "/", name); + if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) + return fullname; caml_stat_free(fullname); } not_found: - fullname = caml_stat_alloc(strlen(name) + 1); - strcpy(fullname, name); - return fullname; + return caml_strdup(name); } -#ifdef __CYGWIN32__ +#ifdef __CYGWIN__ /* Cygwin needs special treatment because of the implicit ".exe" at the end of executable file names */ @@ -107,31 +103,28 @@ static char * cygwin_search_exe_in_path(struct ext_table * path, char * name) { - char * p, * fullname; + char * p, * dir, * fullname; int i; for (p = name; *p != 0; p++) { if (*p == '/' || *p == '\\') goto not_found; } for (i = 0; i < path->size; i++) { - fullname = caml_stat_alloc(strlen((char *)(path->contents[i])) + - strlen(name) + 6); - strcpy(fullname, (char *)(path->contents[i])); - strcat(fullname, "/"); - strcat(fullname, name); + dir = path->contents[i]; + if (dir[0] == 0) dir = "."; /* empty path component = current dir */ + fullname = caml_strconcat(3, dir, "/", name); if (cygwin_file_exists(fullname)) return fullname; - strcat(fullname, ".exe"); + caml_stat_free(fullname); + fullname = caml_strconcat(4, dir, "/", name, ".exe"); if (cygwin_file_exists(fullname)) return fullname; caml_stat_free(fullname); } not_found: - fullname = caml_stat_alloc(strlen(name) + 5); - strcpy(fullname, name); - if (cygwin_file_exists(fullname)) return fullname; - strcat(fullname, ".exe"); + if (cygwin_file_exists(name)) return caml_strdup(name); + fullname = caml_strconcat(2, name, ".exe"); if (cygwin_file_exists(fullname)) return fullname; - strcpy(fullname, name); - return fullname; + caml_stat_free(fullname); + return caml_strdup(name); } #endif @@ -144,7 +137,7 @@ caml_ext_table_init(&path, 8); tofree = caml_decompose_path(&path, getenv("PATH")); -#ifndef __CYGWIN32__ +#ifndef __CYGWIN__ res = caml_search_in_path(&path, name); #else res = cygwin_search_exe_in_path(&path, name); @@ -156,17 +149,17 @@ char * caml_search_dll_in_path(struct ext_table * path, char * name) { - char * dllname = caml_stat_alloc(strlen(name) + 4); + char * dllname; char * res; - strcpy(dllname, name); - strcat(dllname, ".so"); + + dllname = caml_strconcat(2, name, ".so"); res = caml_search_in_path(path, dllname); caml_stat_free(dllname); return res; } #ifdef SUPPORT_DYNAMIC_LINKING -#ifdef __CYGWIN32__ +#ifdef __CYGWIN__ /* Use flexdll */ void * caml_dlopen(char * libname, int for_execution, int global) @@ -286,7 +279,6 @@ #else struct direct * e; #endif - char * p; d = opendir(dirname); if (d == NULL) return -1; @@ -294,9 +286,7 @@ e = readdir(d); if (e == NULL) break; if (strcmp(e->d_name, ".") == 0 || strcmp(e->d_name, "..") == 0) continue; - p = caml_stat_alloc(strlen(e->d_name) + 1); - strcpy(p, e->d_name); - caml_ext_table_add(contents, p); + caml_ext_table_add(contents, caml_strdup(e->d_name)); } closedir(d); return 0; @@ -321,4 +311,11 @@ return 0; } +#else + +int caml_executable_name(char * name, int name_len) +{ + return -1; +} + #endif diff -Nru ocaml-4.01.0/byterun/weak.c ocaml-4.02.3/byterun/weak.c --- ocaml-4.01.0/byterun/weak.c 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/weak.c 2015-04-12 11:03:39.000000000 +0200 @@ -15,11 +15,11 @@ #include -#include "alloc.h" -#include "fail.h" -#include "major_gc.h" -#include "memory.h" -#include "mlvalues.h" +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" value caml_weak_list_head = 0; diff -Nru ocaml-4.01.0/byterun/weak.h ocaml-4.02.3/byterun/weak.h --- ocaml-4.01.0/byterun/weak.h 2012-10-15 19:50:56.000000000 +0200 +++ ocaml-4.02.3/byterun/weak.h 1970-01-01 01:00:00.000000000 +0100 @@ -1,24 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* Operations on weak arrays */ - -#ifndef CAML_WEAK_H -#define CAML_WEAK_H - -#include "mlvalues.h" - -extern value caml_weak_list_head; -extern value caml_weak_none; - -#endif /* CAML_WEAK_H */ diff -Nru ocaml-4.01.0/byterun/win32.c ocaml-4.02.3/byterun/win32.c --- ocaml-4.01.0/byterun/win32.c 2013-06-06 13:39:51.000000000 +0200 +++ ocaml-4.02.3/byterun/win32.c 2015-06-04 21:59:00.000000000 +0200 @@ -16,6 +16,7 @@ #include #include #include +#include #include #include #include @@ -24,12 +25,13 @@ #include #include #include -#include "fail.h" -#include "memory.h" -#include "misc.h" -#include "osdeps.h" -#include "signals.h" -#include "sys.h" +#include "caml/address_class.h" +#include "caml/fail.h" +#include "caml/memory.h" +#include "caml/misc.h" +#include "caml/osdeps.h" +#include "caml/signals.h" +#include "caml/sys.h" #include @@ -43,8 +45,7 @@ int n; if (path == NULL) return NULL; - p = caml_stat_alloc(strlen(path) + 1); - strcpy(p, path); + p = caml_strdup(path); q = p; while (1) { for (n = 0; q[n] != 0 && q[n] != ';'; n++) /*nothing*/; @@ -59,7 +60,7 @@ char * caml_search_in_path(struct ext_table * path, char * name) { - char * p, * fullname; + char * p, * dir, * fullname; int i; struct stat st; @@ -67,56 +68,55 @@ if (*p == '/' || *p == '\\') goto not_found; } for (i = 0; i < path->size; i++) { - fullname = caml_stat_alloc(strlen((char *)(path->contents[i])) + - strlen(name) + 2); - strcpy(fullname, (char *)(path->contents[i])); - strcat(fullname, "\\"); - strcat(fullname, name); + dir = path->contents[i]; + if (dir[0] == 0) continue; + /* not sure what empty path components mean under Windows */ + fullname = caml_strconcat(3, dir, "\\", name); caml_gc_message(0x100, "Searching %s\n", (uintnat) fullname); - if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname; + if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) + return fullname; caml_stat_free(fullname); } not_found: caml_gc_message(0x100, "%s not found in search path\n", (uintnat) name); - fullname = caml_stat_alloc(strlen(name) + 1); - strcpy(fullname, name); - return fullname; + return caml_strdup(name); } CAMLexport char * caml_search_exe_in_path(char * name) { char * fullname, * filepart; - DWORD pathlen, retcode; + size_t fullnamelen; + DWORD retcode; - pathlen = strlen(name) + 1; - if (pathlen < 256) pathlen = 256; + fullnamelen = strlen(name) + 1; + if (fullnamelen < 256) fullnamelen = 256; while (1) { - fullname = caml_stat_alloc(pathlen); + fullname = caml_stat_alloc(fullnamelen); retcode = SearchPath(NULL, /* use system search path */ name, ".exe", /* add .exe extension if needed */ - pathlen, + fullnamelen, fullname, &filepart); if (retcode == 0) { caml_gc_message(0x100, "%s not found in search path\n", (uintnat) name); - strcpy(fullname, name); - break; + caml_stat_free(fullname); + return caml_strdup(name); } - if (retcode < pathlen) break; + if (retcode < fullnamelen) + return fullname; caml_stat_free(fullname); - pathlen = retcode + 1; + fullnamelen = retcode + 1; } - return fullname; } char * caml_search_dll_in_path(struct ext_table * path, char * name) { - char * dllname = caml_stat_alloc(strlen(name) + 5); + char * dllname; char * res; - strcpy(dllname, name); - strcat(dllname, ".dll"); + + dllname = caml_strconcat(2, name, ".dll"); res = caml_search_in_path(path, dllname); caml_stat_free(dllname); return res; @@ -235,27 +235,27 @@ static void expand_pattern(char * pat) { + char * prefix, * p, * name; int handle; struct _finddata_t ffblk; - int preflen; + size_t i; handle = _findfirst(pat, &ffblk); if (handle == -1) { store_argument(pat); /* a la Bourne shell */ return; } - for (preflen = strlen(pat); preflen > 0; preflen--) { - char c = pat[preflen - 1]; - if (c == '\\' || c == '/' || c == ':') break; + prefix = caml_strdup(pat); + for (i = strlen(prefix); i > 0; i--) { + char c = prefix[i - 1]; + if (c == '\\' || c == '/' || c == ':') { prefix[i] = 0; break; } } do { - char * name = malloc(preflen + strlen(ffblk.name) + 1); - if (name == NULL) out_of_memory(); - memcpy(name, pat, preflen); - strcpy(name + preflen, ffblk.name); + name = caml_strconcat(2, prefix, ffblk.name); store_argument(name); } while (_findnext(handle, &ffblk) != -1); _findclose(handle); + caml_stat_free(prefix); } @@ -278,7 +278,7 @@ int caml_read_directory(char * dirname, struct ext_table * contents) { - int dirnamelen; + size_t dirnamelen; char * template; #if _MSC_VER <= 1200 int h; @@ -286,28 +286,27 @@ intptr_t h; #endif struct _finddata_t fileinfo; - char * p; dirnamelen = strlen(dirname); - template = caml_stat_alloc(dirnamelen + 5); - strcpy(template, dirname); - switch (dirname[dirnamelen - 1]) { - case '/': case '\\': case ':': - strcat(template, "*.*"); break; - default: - strcat(template, "\\*.*"); - } + if (dirnamelen > 0 && + (dirname[dirnamelen - 1] == '/' + || dirname[dirnamelen - 1] == '\\' + || dirname[dirnamelen - 1] == ':')) + template = caml_strconcat(2, dirname, "*.*"); + else + template = caml_strconcat(2, dirname, "\\*.*"); h = _findfirst(template, &fileinfo); - caml_stat_free(template); - if (h == -1) return errno == ENOENT ? 0 : -1; + if (h == -1) { + caml_stat_free(template); + return errno == ENOENT ? 0 : -1; + } do { if (strcmp(fileinfo.name, ".") != 0 && strcmp(fileinfo.name, "..") != 0) { - p = caml_stat_alloc(strlen(fileinfo.name) + 1); - strcpy(p, fileinfo.name); - caml_ext_table_add(contents, p); + caml_ext_table_add(contents, caml_strdup(fileinfo.name)); } } while (_findnext(h, &fileinfo) == 0); _findclose(h); + caml_stat_free(template); return 0; } @@ -420,14 +419,8 @@ caml_raise_stack_overflow(); } -extern char * caml_code_area_start, * caml_code_area_end; CAMLextern int caml_is_in_code(void *); -#define Is_in_code_area(pc) \ - ( ((char *)(pc) >= caml_code_area_start && \ - (char *)(pc) <= caml_code_area_end) \ - || (Classify_addr(pc) & In_code_area) ) - static LONG CALLBACK caml_UnhandledExceptionFilter (EXCEPTION_POINTERS* exn_info) { @@ -502,3 +495,42 @@ } #endif + + +/* Recover executable name */ + +int caml_executable_name(char * name, int name_len) +{ + int retcode; + + int ret = GetModuleFileName(NULL, name, name_len); + if (0 == ret || ret >= name_len) return -1; + return 0; +} + +/* snprintf emulation */ + +int caml_snprintf(char * buf, size_t size, const char * format, ...) +{ + int len; + va_list args; + + if (size > 0) { + va_start(args, format); + len = _vsnprintf(buf, size, format, args); + va_end(args); + if (len >= 0 && len < size) { + /* [len] characters were stored in [buf], + a null-terminator was appended. */ + return len; + } + /* [size] characters were stored in [buf], without null termination. + Put a null terminator, truncating the output. */ + buf[size - 1] = 0; + } + /* Compute the actual length of output, excluding null terminator */ + va_start(args, format); + len = _vscprintf(format, args); + va_end(args); + return len; +} diff -Nru ocaml-4.01.0/camlp4/boot/Camlp4Ast.ml ocaml-4.02.3/camlp4/boot/Camlp4Ast.ml --- ocaml-4.01.0/camlp4/boot/Camlp4Ast.ml 2013-08-30 13:39:33.000000000 +0200 +++ ocaml-4.02.3/camlp4/boot/Camlp4Ast.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,6219 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = - struct - module Loc = Loc; - module Ast = - struct - include (Sig.MakeCamlp4Ast Loc); - value safe_string_escaped s = - if ((String.length s) > 2) && ((s.[0] = '\\') && (s.[1] = '$')) - then s - else String.escaped s; - end; - include Ast; - external loc_of_ctyp : ctyp -> Loc.t = "%field0"; - external loc_of_patt : patt -> Loc.t = "%field0"; - external loc_of_expr : expr -> Loc.t = "%field0"; - external loc_of_module_type : module_type -> Loc.t = "%field0"; - external loc_of_module_expr : module_expr -> Loc.t = "%field0"; - external loc_of_sig_item : sig_item -> Loc.t = "%field0"; - external loc_of_str_item : str_item -> Loc.t = "%field0"; - external loc_of_class_type : class_type -> Loc.t = "%field0"; - external loc_of_class_sig_item : class_sig_item -> Loc.t = "%field0"; - external loc_of_class_expr : class_expr -> Loc.t = "%field0"; - external loc_of_class_str_item : class_str_item -> Loc.t = "%field0"; - external loc_of_with_constr : with_constr -> Loc.t = "%field0"; - external loc_of_binding : binding -> Loc.t = "%field0"; - external loc_of_rec_binding : rec_binding -> Loc.t = "%field0"; - external loc_of_module_binding : module_binding -> Loc.t = "%field0"; - external loc_of_match_case : match_case -> Loc.t = "%field0"; - external loc_of_ident : ident -> Loc.t = "%field0"; - value ghost = Loc.ghost; - value rec is_module_longident = - fun - [ Ast.IdAcc _ _ i -> is_module_longident i - | Ast.IdApp _ i1 i2 -> - (is_module_longident i1) && (is_module_longident i2) - | Ast.IdUid _ _ -> True - | _ -> False ]; - value ident_of_expr = - let error () = - invalid_arg "ident_of_expr: this expression is not an identifier" in - let rec self = - fun - [ Ast.ExApp _loc e1 e2 -> Ast.IdApp _loc (self e1) (self e2) - | Ast.ExAcc _loc e1 e2 -> Ast.IdAcc _loc (self e1) (self e2) - | Ast.ExId _ (Ast.IdLid _ _) -> error () - | Ast.ExId _ i -> if is_module_longident i then i else error () - | _ -> error () ] - in - fun [ Ast.ExId _ i -> i | Ast.ExApp _ _ _ -> error () | t -> self t ]; - value ident_of_ctyp = - let error () = - invalid_arg "ident_of_ctyp: this type is not an identifier" in - let rec self = - fun - [ Ast.TyApp _loc t1 t2 -> Ast.IdApp _loc (self t1) (self t2) - | Ast.TyId _ (Ast.IdLid _ _) -> error () - | Ast.TyId _ i -> if is_module_longident i then i else error () - | _ -> error () ] - in fun [ Ast.TyId _ i -> i | t -> self t ]; - value ident_of_patt = - let error () = - invalid_arg "ident_of_patt: this pattern is not an identifier" in - let rec self = - fun - [ Ast.PaApp _loc p1 p2 -> Ast.IdApp _loc (self p1) (self p2) - | Ast.PaId _ (Ast.IdLid _ _) -> error () - | Ast.PaId _ i -> if is_module_longident i then i else error () - | _ -> error () ] - in fun [ Ast.PaId _ i -> i | p -> self p ]; - value rec is_irrefut_patt = - fun - [ Ast.PaId _ (Ast.IdLid _ _) -> True - | Ast.PaId _ (Ast.IdUid _ "()") -> True - | Ast.PaAny _ -> True - | Ast.PaNil _ -> True - | (* why not *) Ast.PaAli _ x y -> - (is_irrefut_patt x) && (is_irrefut_patt y) - | Ast.PaRec _ p -> is_irrefut_patt p - | Ast.PaEq _ _ p -> is_irrefut_patt p - | Ast.PaSem _ p1 p2 -> (is_irrefut_patt p1) && (is_irrefut_patt p2) - | Ast.PaCom _ p1 p2 -> (is_irrefut_patt p1) && (is_irrefut_patt p2) - | Ast.PaOrp _ p1 p2 -> (is_irrefut_patt p1) && (is_irrefut_patt p2) - | (* could be more fine grained *) Ast.PaApp _ p1 p2 -> - (is_irrefut_patt p1) && (is_irrefut_patt p2) - | Ast.PaTyc _ p _ -> is_irrefut_patt p - | Ast.PaTup _ pl -> is_irrefut_patt pl - | Ast.PaOlb _ _ (Ast.PaNil _) -> True - | Ast.PaOlb _ _ p -> is_irrefut_patt p - | Ast.PaOlbi _ _ p _ -> is_irrefut_patt p - | Ast.PaLab _ _ (Ast.PaNil _) -> True - | Ast.PaLab _ _ p -> is_irrefut_patt p - | Ast.PaLaz _ p -> is_irrefut_patt p - | Ast.PaId _ _ -> False - | (* here one need to know the arity of constructors *) Ast.PaMod _ _ - -> True - | Ast.PaVrn _ _ | Ast.PaStr _ _ | Ast.PaRng _ _ _ | Ast.PaFlo _ _ | - Ast.PaNativeInt _ _ | Ast.PaInt64 _ _ | Ast.PaInt32 _ _ | - Ast.PaInt _ _ | Ast.PaChr _ _ | Ast.PaTyp _ _ | Ast.PaArr _ _ | - Ast.PaAnt _ _ -> False ]; - value rec is_constructor = - fun - [ Ast.IdAcc _ _ i -> is_constructor i - | Ast.IdUid _ _ -> True - | Ast.IdLid _ _ | Ast.IdApp _ _ _ -> False - | Ast.IdAnt _ _ -> assert False ]; - value is_patt_constructor = - fun - [ Ast.PaId _ i -> is_constructor i - | Ast.PaVrn _ _ -> True - | _ -> False ]; - value rec is_expr_constructor = - fun - [ Ast.ExId _ i -> is_constructor i - | Ast.ExAcc _ e1 e2 -> - (is_expr_constructor e1) && (is_expr_constructor e2) - | Ast.ExVrn _ _ -> True - | _ -> False ]; - value rec tyOr_of_list = - fun - [ [] -> Ast.TyNil ghost - | [ t ] -> t - | [ t :: ts ] -> - let _loc = loc_of_ctyp t in Ast.TyOr _loc t (tyOr_of_list ts) ]; - value rec tyAnd_of_list = - fun - [ [] -> Ast.TyNil ghost - | [ t ] -> t - | [ t :: ts ] -> - let _loc = loc_of_ctyp t in Ast.TyAnd _loc t (tyAnd_of_list ts) ]; - value rec tySem_of_list = - fun - [ [] -> Ast.TyNil ghost - | [ t ] -> t - | [ t :: ts ] -> - let _loc = loc_of_ctyp t in Ast.TySem _loc t (tySem_of_list ts) ]; - value rec tyCom_of_list = - fun - [ [] -> Ast.TyNil ghost - | [ t ] -> t - | [ t :: ts ] -> - let _loc = loc_of_ctyp t in Ast.TyCom _loc t (tyCom_of_list ts) ]; - value rec tyAmp_of_list = - fun - [ [] -> Ast.TyNil ghost - | [ t ] -> t - | [ t :: ts ] -> - let _loc = loc_of_ctyp t in Ast.TyAmp _loc t (tyAmp_of_list ts) ]; - value rec tySta_of_list = - fun - [ [] -> Ast.TyNil ghost - | [ t ] -> t - | [ t :: ts ] -> - let _loc = loc_of_ctyp t in Ast.TySta _loc t (tySta_of_list ts) ]; - value rec stSem_of_list = - fun - [ [] -> Ast.StNil ghost - | [ t ] -> t - | [ t :: ts ] -> - let _loc = loc_of_str_item t in Ast.StSem _loc t (stSem_of_list ts) ]; - value rec sgSem_of_list = - fun - [ [] -> Ast.SgNil ghost - | [ t ] -> t - | [ t :: ts ] -> - let _loc = loc_of_sig_item t in Ast.SgSem _loc t (sgSem_of_list ts) ]; - value rec biAnd_of_list = - fun - [ [] -> Ast.BiNil ghost - | [ b ] -> b - | [ b :: bs ] -> - let _loc = loc_of_binding b in Ast.BiAnd _loc b (biAnd_of_list bs) ]; - value rec rbSem_of_list = - fun - [ [] -> Ast.RbNil ghost - | [ b ] -> b - | [ b :: bs ] -> - let _loc = loc_of_rec_binding b - in Ast.RbSem _loc b (rbSem_of_list bs) ]; - value rec wcAnd_of_list = - fun - [ [] -> Ast.WcNil ghost - | [ w ] -> w - | [ w :: ws ] -> - let _loc = loc_of_with_constr w - in Ast.WcAnd _loc w (wcAnd_of_list ws) ]; - value rec idAcc_of_list = - fun - [ [] -> assert False - | [ i ] -> i - | [ i :: is ] -> - let _loc = loc_of_ident i in Ast.IdAcc _loc i (idAcc_of_list is) ]; - value rec idApp_of_list = - fun - [ [] -> assert False - | [ i ] -> i - | [ i :: is ] -> - let _loc = loc_of_ident i in Ast.IdApp _loc i (idApp_of_list is) ]; - value rec mcOr_of_list = - fun - [ [] -> Ast.McNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_match_case x in Ast.McOr _loc x (mcOr_of_list xs) ]; - value rec mbAnd_of_list = - fun - [ [] -> Ast.MbNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_module_binding x - in Ast.MbAnd _loc x (mbAnd_of_list xs) ]; - value rec meApp_of_list = - fun - [ [] -> assert False - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_module_expr x - in Ast.MeApp _loc x (meApp_of_list xs) ]; - value rec ceAnd_of_list = - fun - [ [] -> Ast.CeNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_class_expr x - in Ast.CeAnd _loc x (ceAnd_of_list xs) ]; - value rec ctAnd_of_list = - fun - [ [] -> Ast.CtNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_class_type x - in Ast.CtAnd _loc x (ctAnd_of_list xs) ]; - value rec cgSem_of_list = - fun - [ [] -> Ast.CgNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_class_sig_item x - in Ast.CgSem _loc x (cgSem_of_list xs) ]; - value rec crSem_of_list = - fun - [ [] -> Ast.CrNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_class_str_item x - in Ast.CrSem _loc x (crSem_of_list xs) ]; - value rec paSem_of_list = - fun - [ [] -> Ast.PaNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_patt x in Ast.PaSem _loc x (paSem_of_list xs) ]; - value rec paCom_of_list = - fun - [ [] -> Ast.PaNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_patt x in Ast.PaCom _loc x (paCom_of_list xs) ]; - value rec exSem_of_list = - fun - [ [] -> Ast.ExNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_expr x in Ast.ExSem _loc x (exSem_of_list xs) ]; - value rec exCom_of_list = - fun - [ [] -> Ast.ExNil ghost - | [ x ] -> x - | [ x :: xs ] -> - let _loc = loc_of_expr x in Ast.ExCom _loc x (exCom_of_list xs) ]; - value ty_of_stl = - fun - [ (_loc, s, []) -> Ast.TyId _loc (Ast.IdUid _loc s) - | (_loc, s, tl) -> - Ast.TyOf _loc (Ast.TyId _loc (Ast.IdUid _loc s)) (tyAnd_of_list tl) ]; - value ty_of_sbt = - fun - [ (_loc, s, True, t) -> - Ast.TyCol _loc (Ast.TyId _loc (Ast.IdLid _loc s)) - (Ast.TyMut _loc t) - | (_loc, s, False, t) -> - Ast.TyCol _loc (Ast.TyId _loc (Ast.IdLid _loc s)) t ]; - value bi_of_pe (p, e) = let _loc = loc_of_patt p in Ast.BiEq _loc p e; - value sum_type_of_list l = tyOr_of_list (List.map ty_of_stl l); - value record_type_of_list l = tySem_of_list (List.map ty_of_sbt l); - value binding_of_pel l = biAnd_of_list (List.map bi_of_pe l); - value rec pel_of_binding = - fun - [ Ast.BiAnd _ b1 b2 -> (pel_of_binding b1) @ (pel_of_binding b2) - | Ast.BiEq _ p e -> [ (p, e) ] - | _ -> assert False ]; - value rec list_of_binding x acc = - match x with - [ Ast.BiAnd _ b1 b2 -> list_of_binding b1 (list_of_binding b2 acc) - | t -> [ t :: acc ] ]; - value rec list_of_rec_binding x acc = - match x with - [ Ast.RbSem _ b1 b2 -> - list_of_rec_binding b1 (list_of_rec_binding b2 acc) - | t -> [ t :: acc ] ]; - value rec list_of_with_constr x acc = - match x with - [ Ast.WcAnd _ w1 w2 -> - list_of_with_constr w1 (list_of_with_constr w2 acc) - | t -> [ t :: acc ] ]; - value rec list_of_ctyp x acc = - match x with - [ Ast.TyNil _ -> acc - | Ast.TyAmp _ x y | Ast.TyCom _ x y | Ast.TySta _ x y | Ast.TySem _ x y - | Ast.TyAnd _ x y | Ast.TyOr _ x y -> - list_of_ctyp x (list_of_ctyp y acc) - | x -> [ x :: acc ] ]; - value rec list_of_patt x acc = - match x with - [ Ast.PaNil _ -> acc - | Ast.PaCom _ x y | Ast.PaSem _ x y -> - list_of_patt x (list_of_patt y acc) - | x -> [ x :: acc ] ]; - value rec list_of_expr x acc = - match x with - [ Ast.ExNil _ -> acc - | Ast.ExCom _ x y | Ast.ExSem _ x y -> - list_of_expr x (list_of_expr y acc) - | x -> [ x :: acc ] ]; - value rec list_of_str_item x acc = - match x with - [ Ast.StNil _ -> acc - | Ast.StSem _ x y -> list_of_str_item x (list_of_str_item y acc) - | x -> [ x :: acc ] ]; - value rec list_of_sig_item x acc = - match x with - [ Ast.SgNil _ -> acc - | Ast.SgSem _ x y -> list_of_sig_item x (list_of_sig_item y acc) - | x -> [ x :: acc ] ]; - value rec list_of_class_sig_item x acc = - match x with - [ Ast.CgNil _ -> acc - | Ast.CgSem _ x y -> - list_of_class_sig_item x (list_of_class_sig_item y acc) - | x -> [ x :: acc ] ]; - value rec list_of_class_str_item x acc = - match x with - [ Ast.CrNil _ -> acc - | Ast.CrSem _ x y -> - list_of_class_str_item x (list_of_class_str_item y acc) - | x -> [ x :: acc ] ]; - value rec list_of_class_type x acc = - match x with - [ Ast.CtAnd _ x y -> list_of_class_type x (list_of_class_type y acc) - | x -> [ x :: acc ] ]; - value rec list_of_class_expr x acc = - match x with - [ Ast.CeAnd _ x y -> list_of_class_expr x (list_of_class_expr y acc) - | x -> [ x :: acc ] ]; - value rec list_of_module_expr x acc = - match x with - [ Ast.MeApp _ x y -> list_of_module_expr x (list_of_module_expr y acc) - | x -> [ x :: acc ] ]; - value rec list_of_match_case x acc = - match x with - [ Ast.McNil _ -> acc - | Ast.McOr _ x y -> list_of_match_case x (list_of_match_case y acc) - | x -> [ x :: acc ] ]; - value rec list_of_ident x acc = - match x with - [ Ast.IdAcc _ x y | Ast.IdApp _ x y -> - list_of_ident x (list_of_ident y acc) - | x -> [ x :: acc ] ]; - value rec list_of_module_binding x acc = - match x with - [ Ast.MbAnd _ x y -> - list_of_module_binding x (list_of_module_binding y acc) - | x -> [ x :: acc ] ]; - module Meta = - struct - module type META_LOC = - sig - value meta_loc_patt : Loc.t -> Loc.t -> Ast.patt; - value meta_loc_expr : Loc.t -> Loc.t -> Ast.expr; - end; - module MetaLoc = - struct - value meta_loc_patt _loc location = - let (a, b, c, d, e, f, g, h) = Loc.to_tuple location - in - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Loc") - (Ast.IdLid _loc "of_tuple"))) - (Ast.PaTup _loc - (Ast.PaCom _loc - (Ast.PaStr _loc (Ast.safe_string_escaped a)) - (Ast.PaCom _loc - (Ast.PaCom _loc - (Ast.PaCom _loc - (Ast.PaCom _loc - (Ast.PaCom _loc - (Ast.PaCom _loc - (Ast.PaInt _loc (string_of_int b)) - (Ast.PaInt _loc (string_of_int c))) - (Ast.PaInt _loc (string_of_int d))) - (Ast.PaInt _loc (string_of_int e))) - (Ast.PaInt _loc (string_of_int f))) - (Ast.PaInt _loc (string_of_int g))) - (if h - then Ast.PaId _loc (Ast.IdUid _loc "True") - else Ast.PaId _loc (Ast.IdUid _loc "False"))))); - value meta_loc_expr _loc location = - let (a, b, c, d, e, f, g, h) = Loc.to_tuple location - in - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Loc") - (Ast.IdLid _loc "of_tuple"))) - (Ast.ExTup _loc - (Ast.ExCom _loc - (Ast.ExStr _loc (Ast.safe_string_escaped a)) - (Ast.ExCom _loc - (Ast.ExCom _loc - (Ast.ExCom _loc - (Ast.ExCom _loc - (Ast.ExCom _loc - (Ast.ExCom _loc - (Ast.ExInt _loc (string_of_int b)) - (Ast.ExInt _loc (string_of_int c))) - (Ast.ExInt _loc (string_of_int d))) - (Ast.ExInt _loc (string_of_int e))) - (Ast.ExInt _loc (string_of_int f))) - (Ast.ExInt _loc (string_of_int g))) - (if h - then Ast.ExId _loc (Ast.IdUid _loc "True") - else Ast.ExId _loc (Ast.IdUid _loc "False"))))); - end; - module MetaGhostLoc = - struct - value meta_loc_patt _loc _ = - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Loc") - (Ast.IdLid _loc "ghost")); - value meta_loc_expr _loc _ = - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Loc") - (Ast.IdLid _loc "ghost")); - end; - module MetaLocVar = - struct - value meta_loc_patt _loc _ = - Ast.PaId _loc (Ast.IdLid _loc Loc.name.val); - value meta_loc_expr _loc _ = - Ast.ExId _loc (Ast.IdLid _loc Loc.name.val); - end; - module Make (MetaLoc : META_LOC) = - struct - open MetaLoc; - value meta_loc = meta_loc_expr; - module Expr = - struct - value meta_string _loc s = - Ast.ExStr _loc (safe_string_escaped s); - value meta_int _loc s = Ast.ExInt _loc s; - value meta_float _loc s = Ast.ExFlo _loc s; - value meta_char _loc s = Ast.ExChr _loc (String.escaped s); - value meta_bool _loc = - fun - [ False -> Ast.ExId _loc (Ast.IdUid _loc "False") - | True -> Ast.ExId _loc (Ast.IdUid _loc "True") ]; - value rec meta_list mf_a _loc = - fun - [ [] -> Ast.ExId _loc (Ast.IdUid _loc "[]") - | [ x :: xs ] -> - Ast.ExApp _loc - (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdUid _loc "::")) - (mf_a _loc x)) - (meta_list mf_a _loc xs) ]; - value rec meta_binding _loc = - fun - [ Ast.BiAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.BiEq x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BiEq"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_expr _loc x2) - | Ast.BiAnd x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BiAnd"))) - (meta_loc _loc x0)) - (meta_binding _loc x1)) - (meta_binding _loc x2) - | Ast.BiNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BiNil"))) - (meta_loc _loc x0) ] - and meta_class_expr _loc = - fun - [ Ast.CeAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.CeEq x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeEq"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1)) - (meta_class_expr _loc x2) - | Ast.CeAnd x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeAnd"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1)) - (meta_class_expr _loc x2) - | Ast.CeTyc x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeTyc"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1)) - (meta_class_type _loc x2) - | Ast.CeStr x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeStr"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_class_str_item _loc x2) - | Ast.CeLet x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeLet"))) - (meta_loc _loc x0)) - (meta_rec_flag _loc x1)) - (meta_binding _loc x2)) - (meta_class_expr _loc x3) - | Ast.CeFun x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeFun"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_class_expr _loc x2) - | Ast.CeCon x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeCon"))) - (meta_loc _loc x0)) - (meta_virtual_flag _loc x1)) - (meta_ident _loc x2)) - (meta_ctyp _loc x3) - | Ast.CeApp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeApp"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1)) - (meta_expr _loc x2) - | Ast.CeNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeNil"))) - (meta_loc _loc x0) ] - and meta_class_sig_item _loc = - fun - [ Ast.CgAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.CgVir x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgVir"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_private_flag _loc x2)) - (meta_ctyp _loc x3) - | Ast.CgVal x0 x1 x2 x3 x4 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgVal"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_mutable_flag _loc x2)) - (meta_virtual_flag _loc x3)) - (meta_ctyp _loc x4) - | Ast.CgMth x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgMth"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_private_flag _loc x2)) - (meta_ctyp _loc x3) - | Ast.CgInh x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgInh"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1) - | Ast.CgSem x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgSem"))) - (meta_loc _loc x0)) - (meta_class_sig_item _loc x1)) - (meta_class_sig_item _loc x2) - | Ast.CgCtr x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgCtr"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.CgNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgNil"))) - (meta_loc _loc x0) ] - and meta_class_str_item _loc = - fun - [ Ast.CrAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.CrVvr x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrVvr"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_mutable_flag _loc x2)) - (meta_ctyp _loc x3) - | Ast.CrVir x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrVir"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_private_flag _loc x2)) - (meta_ctyp _loc x3) - | Ast.CrVal x0 x1 x2 x3 x4 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrVal"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_override_flag _loc x2)) - (meta_mutable_flag _loc x3)) - (meta_expr _loc x4) - | Ast.CrMth x0 x1 x2 x3 x4 x5 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc - (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrMth"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_override_flag _loc x2)) - (meta_private_flag _loc x3)) - (meta_expr _loc x4)) - (meta_ctyp _loc x5) - | Ast.CrIni x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrIni"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.CrInh x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrInh"))) - (meta_loc _loc x0)) - (meta_override_flag _loc x1)) - (meta_class_expr _loc x2)) - (meta_string _loc x3) - | Ast.CrCtr x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrCtr"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.CrSem x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrSem"))) - (meta_loc _loc x0)) - (meta_class_str_item _loc x1)) - (meta_class_str_item _loc x2) - | Ast.CrNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrNil"))) - (meta_loc _loc x0) ] - and meta_class_type _loc = - fun - [ Ast.CtAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.CtEq x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtEq"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1)) - (meta_class_type _loc x2) - | Ast.CtCol x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtCol"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1)) - (meta_class_type _loc x2) - | Ast.CtAnd x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtAnd"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1)) - (meta_class_type _loc x2) - | Ast.CtSig x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtSig"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_class_sig_item _loc x2) - | Ast.CtFun x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtFun"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_class_type _loc x2) - | Ast.CtCon x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtCon"))) - (meta_loc _loc x0)) - (meta_virtual_flag _loc x1)) - (meta_ident _loc x2)) - (meta_ctyp _loc x3) - | Ast.CtNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtNil"))) - (meta_loc _loc x0) ] - and meta_ctyp _loc = - fun - [ Ast.TyAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.TyPkg x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyPkg"))) - (meta_loc _loc x0)) - (meta_module_type _loc x1) - | Ast.TyOfAmp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyOfAmp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyAmp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAmp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyVrnInfSup x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrnInfSup"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyVrnInf x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrnInf"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyVrnSup x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrnSup"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyVrnEq x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrnEq"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TySta x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TySta"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyTup x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyTup"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyMut x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyMut"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyPrv x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyPrv"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyOr x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyOr"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyAnd x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAnd"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyOf x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyOf"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TySum x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TySum"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyCom x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyCom"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TySem x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TySem"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyCol x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyCol"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyRec x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyRec"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyVrn x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrn"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.TyAnM x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAnM"))) - (meta_loc _loc x0) - | Ast.TyAnP x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAnP"))) - (meta_loc _loc x0) - | Ast.TyQuM x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyQuM"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.TyQuP x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyQuP"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.TyQuo x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyQuo"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.TyTypePol x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyTypePol"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyPol x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyPol"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyOlb x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyOlb"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyObj x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyObj"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_row_var_flag _loc x2) - | Ast.TyDcl x0 x1 x2 x3 x4 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyDcl"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_list meta_ctyp _loc x2)) - (meta_ctyp _loc x3)) - (meta_list - (fun _loc (x1, x2) -> - Ast.ExTup _loc - (Ast.ExCom _loc (meta_ctyp _loc x1) - (meta_ctyp _loc x2))) - _loc x4) - | Ast.TyMan x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyMan"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyId x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.TyLab x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyLab"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyCls x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyCls"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.TyArr x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyArr"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyApp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyApp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyAny x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAny"))) - (meta_loc _loc x0) - | Ast.TyAli x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAli"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyNil"))) - (meta_loc _loc x0) ] - and meta_direction_flag _loc = - fun - [ Ast.DiAnt x0 -> Ast.ExAnt _loc x0 - | Ast.DiDownto -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "DiDownto")) - | Ast.DiTo -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "DiTo")) ] - and meta_expr _loc = - fun - [ Ast.ExPkg x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExPkg"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1) - | Ast.ExFUN x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExFUN"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.ExOpI x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExOpI"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_expr _loc x2) - | Ast.ExWhi x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExWhi"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExVrn x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExVrn"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExTyc x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExTyc"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_ctyp _loc x2) - | Ast.ExCom x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExCom"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExTup x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExTup"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExTry x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExTry"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_match_case _loc x2) - | Ast.ExStr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExStr"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExSte x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExSte"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExSnd x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExSnd"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_string _loc x2) - | Ast.ExSeq x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExSeq"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExRec x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExRec"))) - (meta_loc _loc x0)) - (meta_rec_binding _loc x1)) - (meta_expr _loc x2) - | Ast.ExOvr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExOvr"))) - (meta_loc _loc x0)) - (meta_rec_binding _loc x1) - | Ast.ExOlb x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExOlb"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.ExObj x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExObj"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_class_str_item _loc x2) - | Ast.ExNew x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExNew"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.ExMat x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExMat"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_match_case _loc x2) - | Ast.ExLmd x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExLmd"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_expr _loc x2)) - (meta_expr _loc x3) - | Ast.ExLet x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExLet"))) - (meta_loc _loc x0)) - (meta_rec_flag _loc x1)) - (meta_binding _loc x2)) - (meta_expr _loc x3) - | Ast.ExLaz x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExLaz"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExLab x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExLab"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.ExNativeInt x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExNativeInt"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExInt64 x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExInt64"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExInt32 x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExInt32"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExInt x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExInt"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExIfe x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExIfe"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2)) - (meta_expr _loc x3) - | Ast.ExFun x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExFun"))) - (meta_loc _loc x0)) - (meta_match_case _loc x1) - | Ast.ExFor x0 x1 x2 x3 x4 x5 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc - (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExFor"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2)) - (meta_expr _loc x3)) - (meta_direction_flag _loc x4)) - (meta_expr _loc x5) - | Ast.ExFlo x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExFlo"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExCoe x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExCoe"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_ctyp _loc x2)) - (meta_ctyp _loc x3) - | Ast.ExChr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExChr"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExAss x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAss"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExAsr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAsr"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExAsf x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAsf"))) - (meta_loc _loc x0) - | Ast.ExSem x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExSem"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExArr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExArr"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExAre x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAre"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExApp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExApp"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.ExAcc x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAcc"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExId x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.ExNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExNil"))) - (meta_loc _loc x0) ] - and meta_ident _loc = - fun - [ Ast.IdAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.IdUid x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "IdUid"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.IdLid x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "IdLid"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.IdApp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "IdApp"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_ident _loc x2) - | Ast.IdAcc x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "IdAcc"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_ident _loc x2) ] - and meta_match_case _loc = - fun - [ Ast.McAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.McArr x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "McArr"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_expr _loc x2)) - (meta_expr _loc x3) - | Ast.McOr x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "McOr"))) - (meta_loc _loc x0)) - (meta_match_case _loc x1)) - (meta_match_case _loc x2) - | Ast.McNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "McNil"))) - (meta_loc _loc x0) ] - and meta_meta_bool _loc = - fun - [ Ast.BAnt x0 -> Ast.ExAnt _loc x0 - | Ast.BFalse -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BFalse")) - | Ast.BTrue -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BTrue")) ] - and meta_meta_list mf_a _loc = - fun - [ Ast.LAnt x0 -> Ast.ExAnt _loc x0 - | Ast.LCons x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "LCons"))) - (mf_a _loc x0)) - (meta_meta_list mf_a _loc x1) - | Ast.LNil -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "LNil")) ] - and meta_meta_option mf_a _loc = - fun - [ Ast.OAnt x0 -> Ast.ExAnt _loc x0 - | Ast.OSome x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "OSome"))) - (mf_a _loc x0) - | Ast.ONone -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ONone")) ] - and meta_module_binding _loc = - fun - [ Ast.MbAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.MbCol x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MbCol"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2) - | Ast.MbColEq x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MbColEq"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2)) - (meta_module_expr _loc x3) - | Ast.MbAnd x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MbAnd"))) - (meta_loc _loc x0)) - (meta_module_binding _loc x1)) - (meta_module_binding _loc x2) - | Ast.MbNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MbNil"))) - (meta_loc _loc x0) ] - and meta_module_expr _loc = - fun - [ Ast.MeAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.MePkg x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MePkg"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.MeTyc x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeTyc"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1)) - (meta_module_type _loc x2) - | Ast.MeStr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeStr"))) - (meta_loc _loc x0)) - (meta_str_item _loc x1) - | Ast.MeFun x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeFun"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2)) - (meta_module_expr _loc x3) - | Ast.MeApp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeApp"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1)) - (meta_module_expr _loc x2) - | Ast.MeId x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.MeNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeNil"))) - (meta_loc _loc x0) ] - and meta_module_type _loc = - fun - [ Ast.MtAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.MtOf x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtOf"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1) - | Ast.MtWit x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtWit"))) - (meta_loc _loc x0)) - (meta_module_type _loc x1)) - (meta_with_constr _loc x2) - | Ast.MtSig x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtSig"))) - (meta_loc _loc x0)) - (meta_sig_item _loc x1) - | Ast.MtQuo x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtQuo"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.MtFun x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtFun"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2)) - (meta_module_type _loc x3) - | Ast.MtId x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.MtNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtNil"))) - (meta_loc _loc x0) ] - and meta_mutable_flag _loc = - fun - [ Ast.MuAnt x0 -> Ast.ExAnt _loc x0 - | Ast.MuNil -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MuNil")) - | Ast.MuMutable -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MuMutable")) ] - and meta_override_flag _loc = - fun - [ Ast.OvAnt x0 -> Ast.ExAnt _loc x0 - | Ast.OvNil -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "OvNil")) - | Ast.OvOverride -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "OvOverride")) ] - and meta_patt _loc = - fun - [ Ast.PaMod x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaMod"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaLaz x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaLaz"))) - (meta_loc _loc x0)) - (meta_patt _loc x1) - | Ast.PaVrn x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaVrn"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaTyp x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaTyp"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.PaTyc x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaTyc"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_ctyp _loc x2) - | Ast.PaTup x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaTup"))) - (meta_loc _loc x0)) - (meta_patt _loc x1) - | Ast.PaStr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaStr"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaEq x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaEq"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_patt _loc x2) - | Ast.PaRec x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaRec"))) - (meta_loc _loc x0)) - (meta_patt _loc x1) - | Ast.PaRng x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaRng"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaOrp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaOrp"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaOlbi x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaOlbi"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_patt _loc x2)) - (meta_expr _loc x3) - | Ast.PaOlb x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaOlb"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_patt _loc x2) - | Ast.PaLab x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaLab"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_patt _loc x2) - | Ast.PaFlo x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaFlo"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaNativeInt x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaNativeInt"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaInt64 x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaInt64"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaInt32 x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaInt32"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaInt x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaInt"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaChr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaChr"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaSem x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaSem"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaCom x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaCom"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaArr x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaArr"))) - (meta_loc _loc x0)) - (meta_patt _loc x1) - | Ast.PaApp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaApp"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaAny x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaAny"))) - (meta_loc _loc x0) - | Ast.PaAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.PaAli x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaAli"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaId x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.PaNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaNil"))) - (meta_loc _loc x0) ] - and meta_private_flag _loc = - fun - [ Ast.PrAnt x0 -> Ast.ExAnt _loc x0 - | Ast.PrNil -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PrNil")) - | Ast.PrPrivate -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PrPrivate")) ] - and meta_rec_binding _loc = - fun - [ Ast.RbAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.RbEq x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RbEq"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_expr _loc x2) - | Ast.RbSem x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RbSem"))) - (meta_loc _loc x0)) - (meta_rec_binding _loc x1)) - (meta_rec_binding _loc x2) - | Ast.RbNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RbNil"))) - (meta_loc _loc x0) ] - and meta_rec_flag _loc = - fun - [ Ast.ReAnt x0 -> Ast.ExAnt _loc x0 - | Ast.ReNil -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ReNil")) - | Ast.ReRecursive -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ReRecursive")) ] - and meta_row_var_flag _loc = - fun - [ Ast.RvAnt x0 -> Ast.ExAnt _loc x0 - | Ast.RvNil -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RvNil")) - | Ast.RvRowVar -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RvRowVar")) ] - and meta_sig_item _loc = - fun - [ Ast.SgAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.SgVal x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgVal"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2) - | Ast.SgTyp x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgTyp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.SgOpn x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgOpn"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.SgMty x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgMty"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2) - | Ast.SgRecMod x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgRecMod"))) - (meta_loc _loc x0)) - (meta_module_binding _loc x1) - | Ast.SgMod x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgMod"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2) - | Ast.SgInc x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgInc"))) - (meta_loc _loc x0)) - (meta_module_type _loc x1) - | Ast.SgExt x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgExt"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2)) - (meta_meta_list meta_string _loc x3) - | Ast.SgExc x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgExc"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.SgDir x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgDir"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.SgSem x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgSem"))) - (meta_loc _loc x0)) - (meta_sig_item _loc x1)) - (meta_sig_item _loc x2) - | Ast.SgClt x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgClt"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1) - | Ast.SgCls x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgCls"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1) - | Ast.SgNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgNil"))) - (meta_loc _loc x0) ] - and meta_str_item _loc = - fun - [ Ast.StAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.StVal x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StVal"))) - (meta_loc _loc x0)) - (meta_rec_flag _loc x1)) - (meta_binding _loc x2) - | Ast.StTyp x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StTyp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.StOpn x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StOpn"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.StMty x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StMty"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2) - | Ast.StRecMod x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StRecMod"))) - (meta_loc _loc x0)) - (meta_module_binding _loc x1) - | Ast.StMod x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StMod"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_expr _loc x2) - | Ast.StInc x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StInc"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1) - | Ast.StExt x0 x1 x2 x3 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StExt"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2)) - (meta_meta_list meta_string _loc x3) - | Ast.StExp x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StExp"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.StExc x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StExc"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_meta_option meta_ident _loc x2) - | Ast.StDir x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StDir"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.StSem x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StSem"))) - (meta_loc _loc x0)) - (meta_str_item _loc x1)) - (meta_str_item _loc x2) - | Ast.StClt x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StClt"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1) - | Ast.StCls x0 x1 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StCls"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1) - | Ast.StNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StNil"))) - (meta_loc _loc x0) ] - and meta_virtual_flag _loc = - fun - [ Ast.ViAnt x0 -> Ast.ExAnt _loc x0 - | Ast.ViNil -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ViNil")) - | Ast.ViVirtual -> - Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ViVirtual")) ] - and meta_with_constr _loc = - fun - [ Ast.WcAnt x0 x1 -> Ast.ExAnt x0 x1 - | Ast.WcAnd x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcAnd"))) - (meta_loc _loc x0)) - (meta_with_constr _loc x1)) - (meta_with_constr _loc x2) - | Ast.WcMoS x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcMoS"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_ident _loc x2) - | Ast.WcTyS x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcTyS"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.WcMod x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcMod"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_ident _loc x2) - | Ast.WcTyp x0 x1 x2 -> - Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcTyp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.WcNil x0 -> - Ast.ExApp _loc - (Ast.ExId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcNil"))) - (meta_loc _loc x0) ]; - end; - value meta_loc = meta_loc_patt; - module Patt = - struct - value meta_string _loc s = - Ast.PaStr _loc (safe_string_escaped s); - value meta_int _loc s = Ast.PaInt _loc s; - value meta_float _loc s = Ast.PaFlo _loc s; - value meta_char _loc s = Ast.PaChr _loc (String.escaped s); - value meta_bool _loc = - fun - [ False -> Ast.PaId _loc (Ast.IdUid _loc "False") - | True -> Ast.PaId _loc (Ast.IdUid _loc "True") ]; - value rec meta_list mf_a _loc = - fun - [ [] -> Ast.PaId _loc (Ast.IdUid _loc "[]") - | [ x :: xs ] -> - Ast.PaApp _loc - (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdUid _loc "::")) - (mf_a _loc x)) - (meta_list mf_a _loc xs) ]; - value rec meta_binding _loc = - fun - [ Ast.BiAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.BiEq x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BiEq"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_expr _loc x2) - | Ast.BiAnd x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BiAnd"))) - (meta_loc _loc x0)) - (meta_binding _loc x1)) - (meta_binding _loc x2) - | Ast.BiNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BiNil"))) - (meta_loc _loc x0) ] - and meta_class_expr _loc = - fun - [ Ast.CeAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.CeEq x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeEq"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1)) - (meta_class_expr _loc x2) - | Ast.CeAnd x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeAnd"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1)) - (meta_class_expr _loc x2) - | Ast.CeTyc x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeTyc"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1)) - (meta_class_type _loc x2) - | Ast.CeStr x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeStr"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_class_str_item _loc x2) - | Ast.CeLet x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeLet"))) - (meta_loc _loc x0)) - (meta_rec_flag _loc x1)) - (meta_binding _loc x2)) - (meta_class_expr _loc x3) - | Ast.CeFun x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeFun"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_class_expr _loc x2) - | Ast.CeCon x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeCon"))) - (meta_loc _loc x0)) - (meta_virtual_flag _loc x1)) - (meta_ident _loc x2)) - (meta_ctyp _loc x3) - | Ast.CeApp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeApp"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1)) - (meta_expr _loc x2) - | Ast.CeNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CeNil"))) - (meta_loc _loc x0) ] - and meta_class_sig_item _loc = - fun - [ Ast.CgAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.CgVir x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgVir"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_private_flag _loc x2)) - (meta_ctyp _loc x3) - | Ast.CgVal x0 x1 x2 x3 x4 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgVal"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_mutable_flag _loc x2)) - (meta_virtual_flag _loc x3)) - (meta_ctyp _loc x4) - | Ast.CgMth x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgMth"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_private_flag _loc x2)) - (meta_ctyp _loc x3) - | Ast.CgInh x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgInh"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1) - | Ast.CgSem x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgSem"))) - (meta_loc _loc x0)) - (meta_class_sig_item _loc x1)) - (meta_class_sig_item _loc x2) - | Ast.CgCtr x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgCtr"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.CgNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CgNil"))) - (meta_loc _loc x0) ] - and meta_class_str_item _loc = - fun - [ Ast.CrAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.CrVvr x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrVvr"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_mutable_flag _loc x2)) - (meta_ctyp _loc x3) - | Ast.CrVir x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrVir"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_private_flag _loc x2)) - (meta_ctyp _loc x3) - | Ast.CrVal x0 x1 x2 x3 x4 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrVal"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_override_flag _loc x2)) - (meta_mutable_flag _loc x3)) - (meta_expr _loc x4) - | Ast.CrMth x0 x1 x2 x3 x4 x5 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc - (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrMth"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_override_flag _loc x2)) - (meta_private_flag _loc x3)) - (meta_expr _loc x4)) - (meta_ctyp _loc x5) - | Ast.CrIni x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrIni"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.CrInh x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrInh"))) - (meta_loc _loc x0)) - (meta_override_flag _loc x1)) - (meta_class_expr _loc x2)) - (meta_string _loc x3) - | Ast.CrCtr x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrCtr"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.CrSem x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrSem"))) - (meta_loc _loc x0)) - (meta_class_str_item _loc x1)) - (meta_class_str_item _loc x2) - | Ast.CrNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CrNil"))) - (meta_loc _loc x0) ] - and meta_class_type _loc = - fun - [ Ast.CtAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.CtEq x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtEq"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1)) - (meta_class_type _loc x2) - | Ast.CtCol x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtCol"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1)) - (meta_class_type _loc x2) - | Ast.CtAnd x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtAnd"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1)) - (meta_class_type _loc x2) - | Ast.CtSig x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtSig"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_class_sig_item _loc x2) - | Ast.CtFun x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtFun"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_class_type _loc x2) - | Ast.CtCon x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtCon"))) - (meta_loc _loc x0)) - (meta_virtual_flag _loc x1)) - (meta_ident _loc x2)) - (meta_ctyp _loc x3) - | Ast.CtNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "CtNil"))) - (meta_loc _loc x0) ] - and meta_ctyp _loc = - fun - [ Ast.TyAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.TyPkg x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyPkg"))) - (meta_loc _loc x0)) - (meta_module_type _loc x1) - | Ast.TyOfAmp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyOfAmp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyAmp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAmp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyVrnInfSup x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrnInfSup"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyVrnInf x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrnInf"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyVrnSup x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrnSup"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyVrnEq x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrnEq"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TySta x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TySta"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyTup x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyTup"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyMut x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyMut"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyPrv x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyPrv"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyOr x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyOr"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyAnd x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAnd"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyOf x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyOf"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TySum x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TySum"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyCom x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyCom"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TySem x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TySem"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyCol x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyCol"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyRec x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyRec"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.TyVrn x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyVrn"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.TyAnM x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAnM"))) - (meta_loc _loc x0) - | Ast.TyAnP x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAnP"))) - (meta_loc _loc x0) - | Ast.TyQuM x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyQuM"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.TyQuP x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyQuP"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.TyQuo x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyQuo"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.TyTypePol x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyTypePol"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyPol x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyPol"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyOlb x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyOlb"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyObj x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyObj"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_row_var_flag _loc x2) - | Ast.TyDcl x0 x1 x2 x3 x4 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyDcl"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_list meta_ctyp _loc x2)) - (meta_ctyp _loc x3)) - (meta_list - (fun _loc (x1, x2) -> - Ast.PaTup _loc - (Ast.PaCom _loc (meta_ctyp _loc x1) - (meta_ctyp _loc x2))) - _loc x4) - | Ast.TyMan x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyMan"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyId x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.TyLab x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyLab"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyCls x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyCls"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.TyArr x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyArr"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyApp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyApp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyAny x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAny"))) - (meta_loc _loc x0) - | Ast.TyAli x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyAli"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.TyNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "TyNil"))) - (meta_loc _loc x0) ] - and meta_direction_flag _loc = - fun - [ Ast.DiAnt x0 -> Ast.PaAnt _loc x0 - | Ast.DiDownto -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "DiDownto")) - | Ast.DiTo -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "DiTo")) ] - and meta_expr _loc = - fun - [ Ast.ExPkg x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExPkg"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1) - | Ast.ExFUN x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExFUN"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.ExOpI x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExOpI"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_expr _loc x2) - | Ast.ExWhi x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExWhi"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExVrn x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExVrn"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExTyc x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExTyc"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_ctyp _loc x2) - | Ast.ExCom x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExCom"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExTup x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExTup"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExTry x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExTry"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_match_case _loc x2) - | Ast.ExStr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExStr"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExSte x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExSte"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExSnd x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExSnd"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_string _loc x2) - | Ast.ExSeq x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExSeq"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExRec x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExRec"))) - (meta_loc _loc x0)) - (meta_rec_binding _loc x1)) - (meta_expr _loc x2) - | Ast.ExOvr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExOvr"))) - (meta_loc _loc x0)) - (meta_rec_binding _loc x1) - | Ast.ExOlb x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExOlb"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.ExObj x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExObj"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_class_str_item _loc x2) - | Ast.ExNew x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExNew"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.ExMat x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExMat"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_match_case _loc x2) - | Ast.ExLmd x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExLmd"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_expr _loc x2)) - (meta_expr _loc x3) - | Ast.ExLet x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExLet"))) - (meta_loc _loc x0)) - (meta_rec_flag _loc x1)) - (meta_binding _loc x2)) - (meta_expr _loc x3) - | Ast.ExLaz x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExLaz"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExLab x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExLab"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.ExNativeInt x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExNativeInt"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExInt64 x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExInt64"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExInt32 x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExInt32"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExInt x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExInt"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExIfe x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExIfe"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2)) - (meta_expr _loc x3) - | Ast.ExFun x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExFun"))) - (meta_loc _loc x0)) - (meta_match_case _loc x1) - | Ast.ExFor x0 x1 x2 x3 x4 x5 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc - (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExFor"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2)) - (meta_expr _loc x3)) - (meta_direction_flag _loc x4)) - (meta_expr _loc x5) - | Ast.ExFlo x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExFlo"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExCoe x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExCoe"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_ctyp _loc x2)) - (meta_ctyp _loc x3) - | Ast.ExChr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExChr"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.ExAss x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAss"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExAsr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAsr"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExAsf x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAsf"))) - (meta_loc _loc x0) - | Ast.ExSem x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExSem"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExArr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExArr"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.ExAre x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAre"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExApp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExApp"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.ExAcc x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExAcc"))) - (meta_loc _loc x0)) - (meta_expr _loc x1)) - (meta_expr _loc x2) - | Ast.ExId x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.ExNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ExNil"))) - (meta_loc _loc x0) ] - and meta_ident _loc = - fun - [ Ast.IdAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.IdUid x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "IdUid"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.IdLid x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "IdLid"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.IdApp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "IdApp"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_ident _loc x2) - | Ast.IdAcc x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "IdAcc"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_ident _loc x2) ] - and meta_match_case _loc = - fun - [ Ast.McAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.McArr x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "McArr"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_expr _loc x2)) - (meta_expr _loc x3) - | Ast.McOr x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "McOr"))) - (meta_loc _loc x0)) - (meta_match_case _loc x1)) - (meta_match_case _loc x2) - | Ast.McNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "McNil"))) - (meta_loc _loc x0) ] - and meta_meta_bool _loc = - fun - [ Ast.BAnt x0 -> Ast.PaAnt _loc x0 - | Ast.BFalse -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BFalse")) - | Ast.BTrue -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "BTrue")) ] - and meta_meta_list mf_a _loc = - fun - [ Ast.LAnt x0 -> Ast.PaAnt _loc x0 - | Ast.LCons x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "LCons"))) - (mf_a _loc x0)) - (meta_meta_list mf_a _loc x1) - | Ast.LNil -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "LNil")) ] - and meta_meta_option mf_a _loc = - fun - [ Ast.OAnt x0 -> Ast.PaAnt _loc x0 - | Ast.OSome x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "OSome"))) - (mf_a _loc x0) - | Ast.ONone -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ONone")) ] - and meta_module_binding _loc = - fun - [ Ast.MbAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.MbCol x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MbCol"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2) - | Ast.MbColEq x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MbColEq"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2)) - (meta_module_expr _loc x3) - | Ast.MbAnd x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MbAnd"))) - (meta_loc _loc x0)) - (meta_module_binding _loc x1)) - (meta_module_binding _loc x2) - | Ast.MbNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MbNil"))) - (meta_loc _loc x0) ] - and meta_module_expr _loc = - fun - [ Ast.MeAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.MePkg x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MePkg"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.MeTyc x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeTyc"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1)) - (meta_module_type _loc x2) - | Ast.MeStr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeStr"))) - (meta_loc _loc x0)) - (meta_str_item _loc x1) - | Ast.MeFun x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeFun"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2)) - (meta_module_expr _loc x3) - | Ast.MeApp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeApp"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1)) - (meta_module_expr _loc x2) - | Ast.MeId x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.MeNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MeNil"))) - (meta_loc _loc x0) ] - and meta_module_type _loc = - fun - [ Ast.MtAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.MtOf x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtOf"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1) - | Ast.MtWit x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtWit"))) - (meta_loc _loc x0)) - (meta_module_type _loc x1)) - (meta_with_constr _loc x2) - | Ast.MtSig x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtSig"))) - (meta_loc _loc x0)) - (meta_sig_item _loc x1) - | Ast.MtQuo x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtQuo"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.MtFun x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtFun"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2)) - (meta_module_type _loc x3) - | Ast.MtId x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.MtNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MtNil"))) - (meta_loc _loc x0) ] - and meta_mutable_flag _loc = - fun - [ Ast.MuAnt x0 -> Ast.PaAnt _loc x0 - | Ast.MuNil -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MuNil")) - | Ast.MuMutable -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "MuMutable")) ] - and meta_override_flag _loc = - fun - [ Ast.OvAnt x0 -> Ast.PaAnt _loc x0 - | Ast.OvNil -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "OvNil")) - | Ast.OvOverride -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "OvOverride")) ] - and meta_patt _loc = - fun - [ Ast.PaMod x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaMod"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaLaz x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaLaz"))) - (meta_loc _loc x0)) - (meta_patt _loc x1) - | Ast.PaVrn x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaVrn"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaTyp x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaTyp"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.PaTyc x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaTyc"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_ctyp _loc x2) - | Ast.PaTup x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaTup"))) - (meta_loc _loc x0)) - (meta_patt _loc x1) - | Ast.PaStr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaStr"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaEq x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaEq"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_patt _loc x2) - | Ast.PaRec x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaRec"))) - (meta_loc _loc x0)) - (meta_patt _loc x1) - | Ast.PaRng x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaRng"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaOrp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaOrp"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaOlbi x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaOlbi"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_patt _loc x2)) - (meta_expr _loc x3) - | Ast.PaOlb x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaOlb"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_patt _loc x2) - | Ast.PaLab x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaLab"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_patt _loc x2) - | Ast.PaFlo x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaFlo"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaNativeInt x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaNativeInt"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaInt64 x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaInt64"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaInt32 x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaInt32"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaInt x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaInt"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaChr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaChr"))) - (meta_loc _loc x0)) - (meta_string _loc x1) - | Ast.PaSem x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaSem"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaCom x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaCom"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaArr x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaArr"))) - (meta_loc _loc x0)) - (meta_patt _loc x1) - | Ast.PaApp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaApp"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaAny x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaAny"))) - (meta_loc _loc x0) - | Ast.PaAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.PaAli x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaAli"))) - (meta_loc _loc x0)) - (meta_patt _loc x1)) - (meta_patt _loc x2) - | Ast.PaId x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaId"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.PaNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PaNil"))) - (meta_loc _loc x0) ] - and meta_private_flag _loc = - fun - [ Ast.PrAnt x0 -> Ast.PaAnt _loc x0 - | Ast.PrNil -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PrNil")) - | Ast.PrPrivate -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "PrPrivate")) ] - and meta_rec_binding _loc = - fun - [ Ast.RbAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.RbEq x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RbEq"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_expr _loc x2) - | Ast.RbSem x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RbSem"))) - (meta_loc _loc x0)) - (meta_rec_binding _loc x1)) - (meta_rec_binding _loc x2) - | Ast.RbNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RbNil"))) - (meta_loc _loc x0) ] - and meta_rec_flag _loc = - fun - [ Ast.ReAnt x0 -> Ast.PaAnt _loc x0 - | Ast.ReNil -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ReNil")) - | Ast.ReRecursive -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ReRecursive")) ] - and meta_row_var_flag _loc = - fun - [ Ast.RvAnt x0 -> Ast.PaAnt _loc x0 - | Ast.RvNil -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RvNil")) - | Ast.RvRowVar -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "RvRowVar")) ] - and meta_sig_item _loc = - fun - [ Ast.SgAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.SgVal x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgVal"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2) - | Ast.SgTyp x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgTyp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.SgOpn x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgOpn"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.SgMty x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgMty"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2) - | Ast.SgRecMod x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgRecMod"))) - (meta_loc _loc x0)) - (meta_module_binding _loc x1) - | Ast.SgMod x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgMod"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2) - | Ast.SgInc x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgInc"))) - (meta_loc _loc x0)) - (meta_module_type _loc x1) - | Ast.SgExt x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgExt"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2)) - (meta_meta_list meta_string _loc x3) - | Ast.SgExc x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgExc"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.SgDir x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgDir"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.SgSem x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgSem"))) - (meta_loc _loc x0)) - (meta_sig_item _loc x1)) - (meta_sig_item _loc x2) - | Ast.SgClt x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgClt"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1) - | Ast.SgCls x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgCls"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1) - | Ast.SgNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "SgNil"))) - (meta_loc _loc x0) ] - and meta_str_item _loc = - fun - [ Ast.StAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.StVal x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StVal"))) - (meta_loc _loc x0)) - (meta_rec_flag _loc x1)) - (meta_binding _loc x2) - | Ast.StTyp x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StTyp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1) - | Ast.StOpn x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StOpn"))) - (meta_loc _loc x0)) - (meta_ident _loc x1) - | Ast.StMty x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StMty"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_type _loc x2) - | Ast.StRecMod x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StRecMod"))) - (meta_loc _loc x0)) - (meta_module_binding _loc x1) - | Ast.StMod x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StMod"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_module_expr _loc x2) - | Ast.StInc x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StInc"))) - (meta_loc _loc x0)) - (meta_module_expr _loc x1) - | Ast.StExt x0 x1 x2 x3 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StExt"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_ctyp _loc x2)) - (meta_meta_list meta_string _loc x3) - | Ast.StExp x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StExp"))) - (meta_loc _loc x0)) - (meta_expr _loc x1) - | Ast.StExc x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StExc"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_meta_option meta_ident _loc x2) - | Ast.StDir x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StDir"))) - (meta_loc _loc x0)) - (meta_string _loc x1)) - (meta_expr _loc x2) - | Ast.StSem x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StSem"))) - (meta_loc _loc x0)) - (meta_str_item _loc x1)) - (meta_str_item _loc x2) - | Ast.StClt x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StClt"))) - (meta_loc _loc x0)) - (meta_class_type _loc x1) - | Ast.StCls x0 x1 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StCls"))) - (meta_loc _loc x0)) - (meta_class_expr _loc x1) - | Ast.StNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "StNil"))) - (meta_loc _loc x0) ] - and meta_virtual_flag _loc = - fun - [ Ast.ViAnt x0 -> Ast.PaAnt _loc x0 - | Ast.ViNil -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ViNil")) - | Ast.ViVirtual -> - Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "ViVirtual")) ] - and meta_with_constr _loc = - fun - [ Ast.WcAnt x0 x1 -> Ast.PaAnt x0 x1 - | Ast.WcAnd x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcAnd"))) - (meta_loc _loc x0)) - (meta_with_constr _loc x1)) - (meta_with_constr _loc x2) - | Ast.WcMoS x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcMoS"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_ident _loc x2) - | Ast.WcTyS x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcTyS"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.WcMod x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcMod"))) - (meta_loc _loc x0)) - (meta_ident _loc x1)) - (meta_ident _loc x2) - | Ast.WcTyp x0 x1 x2 -> - Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcTyp"))) - (meta_loc _loc x0)) - (meta_ctyp _loc x1)) - (meta_ctyp _loc x2) - | Ast.WcNil x0 -> - Ast.PaApp _loc - (Ast.PaId _loc - (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") - (Ast.IdUid _loc "WcNil"))) - (meta_loc _loc x0) ]; - end; - end; - end; - class map = - object ((o : 'self_type)) - method string : string -> string = o#unknown; - method list : - ! 'a 'a_out. ('self_type -> 'a -> 'a_out) -> list 'a -> list 'a_out = - fun _f_a -> - fun - [ [] -> [] - | [ _x :: _x_i1 ] -> - let _x = _f_a o _x in - let _x_i1 = o#list _f_a _x_i1 in [ _x :: _x_i1 ] ]; - method with_constr : with_constr -> with_constr = - fun - [ WcNil _x -> let _x = o#loc _x in WcNil _x - | WcTyp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in WcTyp _x _x_i1 _x_i2 - | WcMod _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#ident _x_i2 in WcMod _x _x_i1 _x_i2 - | WcTyS _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in WcTyS _x _x_i1 _x_i2 - | WcMoS _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#ident _x_i2 in WcMoS _x _x_i1 _x_i2 - | WcAnd _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#with_constr _x_i1 in - let _x_i2 = o#with_constr _x_i2 in WcAnd _x _x_i1 _x_i2 - | WcAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in WcAnt _x _x_i1 ]; - method virtual_flag : virtual_flag -> virtual_flag = - fun - [ ViVirtual -> ViVirtual - | ViNil -> ViNil - | ViAnt _x -> let _x = o#string _x in ViAnt _x ]; - method str_item : str_item -> str_item = - fun - [ StNil _x -> let _x = o#loc _x in StNil _x - | StCls _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in StCls _x _x_i1 - | StClt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in StClt _x _x_i1 - | StSem _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#str_item _x_i1 in - let _x_i2 = o#str_item _x_i2 in StSem _x _x_i1 _x_i2 - | StDir _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in StDir _x _x_i1 _x_i2 - | StExc _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#meta_option (fun o -> o#ident) _x_i2 - in StExc _x _x_i1 _x_i2 - | StExp _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in StExp _x _x_i1 - | StExt _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in - let _x_i3 = o#meta_list (fun o -> o#string) _x_i3 - in StExt _x _x_i1 _x_i2 _x_i3 - | StInc _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in StInc _x _x_i1 - | StMod _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_expr _x_i2 in StMod _x _x_i1 _x_i2 - | StRecMod _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#module_binding _x_i1 in StRecMod _x _x_i1 - | StMty _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in StMty _x _x_i1 _x_i2 - | StOpn _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in StOpn _x _x_i1 - | StTyp _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in StTyp _x _x_i1 - | StVal _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#rec_flag _x_i1 in - let _x_i2 = o#binding _x_i2 in StVal _x _x_i1 _x_i2 - | StAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in StAnt _x _x_i1 ]; - method sig_item : sig_item -> sig_item = - fun - [ SgNil _x -> let _x = o#loc _x in SgNil _x - | SgCls _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in SgCls _x _x_i1 - | SgClt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in SgClt _x _x_i1 - | SgSem _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#sig_item _x_i1 in - let _x_i2 = o#sig_item _x_i2 in SgSem _x _x_i1 _x_i2 - | SgDir _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in SgDir _x _x_i1 _x_i2 - | SgExc _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in SgExc _x _x_i1 - | SgExt _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in - let _x_i3 = o#meta_list (fun o -> o#string) _x_i3 - in SgExt _x _x_i1 _x_i2 _x_i3 - | SgInc _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#module_type _x_i1 in SgInc _x _x_i1 - | SgMod _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in SgMod _x _x_i1 _x_i2 - | SgRecMod _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#module_binding _x_i1 in SgRecMod _x _x_i1 - | SgMty _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in SgMty _x _x_i1 _x_i2 - | SgOpn _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in SgOpn _x _x_i1 - | SgTyp _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in SgTyp _x _x_i1 - | SgVal _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in SgVal _x _x_i1 _x_i2 - | SgAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in SgAnt _x _x_i1 ]; - method row_var_flag : row_var_flag -> row_var_flag = - fun - [ RvRowVar -> RvRowVar - | RvNil -> RvNil - | RvAnt _x -> let _x = o#string _x in RvAnt _x ]; - method rec_flag : rec_flag -> rec_flag = - fun - [ ReRecursive -> ReRecursive - | ReNil -> ReNil - | ReAnt _x -> let _x = o#string _x in ReAnt _x ]; - method rec_binding : rec_binding -> rec_binding = - fun - [ RbNil _x -> let _x = o#loc _x in RbNil _x - | RbSem _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#rec_binding _x_i1 in - let _x_i2 = o#rec_binding _x_i2 in RbSem _x _x_i1 _x_i2 - | RbEq _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#expr _x_i2 in RbEq _x _x_i1 _x_i2 - | RbAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in RbAnt _x _x_i1 ]; - method private_flag : private_flag -> private_flag = - fun - [ PrPrivate -> PrPrivate - | PrNil -> PrNil - | PrAnt _x -> let _x = o#string _x in PrAnt _x ]; - method patt : patt -> patt = - fun - [ PaNil _x -> let _x = o#loc _x in PaNil _x - | PaId _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in PaId _x _x_i1 - | PaAli _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaAli _x _x_i1 _x_i2 - | PaAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaAnt _x _x_i1 - | PaAny _x -> let _x = o#loc _x in PaAny _x - | PaApp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaApp _x _x_i1 _x_i2 - | PaArr _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaArr _x _x_i1 - | PaCom _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaCom _x _x_i1 _x_i2 - | PaSem _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaSem _x _x_i1 _x_i2 - | PaChr _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaChr _x _x_i1 - | PaInt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaInt _x _x_i1 - | PaInt32 _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaInt32 _x _x_i1 - | PaInt64 _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaInt64 _x _x_i1 - | PaNativeInt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaNativeInt _x _x_i1 - | PaFlo _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaFlo _x _x_i1 - | PaLab _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#patt _x_i2 in PaLab _x _x_i1 _x_i2 - | PaOlb _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#patt _x_i2 in PaOlb _x _x_i1 _x_i2 - | PaOlbi _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#patt _x_i2 in - let _x_i3 = o#expr _x_i3 in PaOlbi _x _x_i1 _x_i2 _x_i3 - | PaOrp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaOrp _x _x_i1 _x_i2 - | PaRng _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaRng _x _x_i1 _x_i2 - | PaRec _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaRec _x _x_i1 - | PaEq _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#patt _x_i2 in PaEq _x _x_i1 _x_i2 - | PaStr _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaStr _x _x_i1 - | PaTup _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaTup _x _x_i1 - | PaTyc _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#ctyp _x_i2 in PaTyc _x _x_i1 _x_i2 - | PaTyp _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in PaTyp _x _x_i1 - | PaVrn _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaVrn _x _x_i1 - | PaLaz _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaLaz _x _x_i1 - | PaMod _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaMod _x _x_i1 ]; - method override_flag : override_flag -> override_flag = - fun - [ OvOverride -> OvOverride - | OvNil -> OvNil - | OvAnt _x -> let _x = o#string _x in OvAnt _x ]; - method mutable_flag : mutable_flag -> mutable_flag = - fun - [ MuMutable -> MuMutable - | MuNil -> MuNil - | MuAnt _x -> let _x = o#string _x in MuAnt _x ]; - method module_type : module_type -> module_type = - fun - [ MtNil _x -> let _x = o#loc _x in MtNil _x - | MtId _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in MtId _x _x_i1 - | MtFun _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in - let _x_i3 = o#module_type _x_i3 in MtFun _x _x_i1 _x_i2 _x_i3 - | MtQuo _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in MtQuo _x _x_i1 - | MtSig _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#sig_item _x_i1 in MtSig _x _x_i1 - | MtWit _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#module_type _x_i1 in - let _x_i2 = o#with_constr _x_i2 in MtWit _x _x_i1 _x_i2 - | MtOf _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in MtOf _x _x_i1 - | MtAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in MtAnt _x _x_i1 ]; - method module_expr : module_expr -> module_expr = - fun - [ MeNil _x -> let _x = o#loc _x in MeNil _x - | MeId _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in MeId _x _x_i1 - | MeApp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in - let _x_i2 = o#module_expr _x_i2 in MeApp _x _x_i1 _x_i2 - | MeFun _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in - let _x_i3 = o#module_expr _x_i3 in MeFun _x _x_i1 _x_i2 _x_i3 - | MeStr _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#str_item _x_i1 in MeStr _x _x_i1 - | MeTyc _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in - let _x_i2 = o#module_type _x_i2 in MeTyc _x _x_i1 _x_i2 - | MePkg _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in MePkg _x _x_i1 - | MeAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in MeAnt _x _x_i1 ]; - method module_binding : module_binding -> module_binding = - fun - [ MbNil _x -> let _x = o#loc _x in MbNil _x - | MbAnd _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#module_binding _x_i1 in - let _x_i2 = o#module_binding _x_i2 in MbAnd _x _x_i1 _x_i2 - | MbColEq _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in - let _x_i3 = o#module_expr _x_i3 in MbColEq _x _x_i1 _x_i2 _x_i3 - | MbCol _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in MbCol _x _x_i1 _x_i2 - | MbAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in MbAnt _x _x_i1 ]; - method meta_option : - ! (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2007 Institut National de Recherche en Informatique et *) - (* en Automatique. All rights reserved. This file is distributed under *) - (* the terms of the GNU Library General Public License, with the special *) - (* exception on linking described in LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Note: when you modify these types you must increment - ast magic numbers defined in Camlp4_config.ml. *) - 'a 'a_out. - ('self_type -> 'a -> 'a_out) -> - meta_option 'a -> meta_option 'a_out = - fun _f_a -> - fun - [ ONone -> ONone - | OSome _x -> let _x = _f_a o _x in OSome _x - | OAnt _x -> let _x = o#string _x in OAnt _x ]; - method meta_list : - ! 'a 'a_out. - ('self_type -> 'a -> 'a_out) -> meta_list 'a -> meta_list 'a_out = - fun _f_a -> - fun - [ LNil -> LNil - | LCons _x _x_i1 -> - let _x = _f_a o _x in - let _x_i1 = o#meta_list _f_a _x_i1 in LCons _x _x_i1 - | LAnt _x -> let _x = o#string _x in LAnt _x ]; - method meta_bool : meta_bool -> meta_bool = - fun - [ BTrue -> BTrue - | BFalse -> BFalse - | BAnt _x -> let _x = o#string _x in BAnt _x ]; - method match_case : match_case -> match_case = - fun - [ McNil _x -> let _x = o#loc _x in McNil _x - | McOr _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#match_case _x_i1 in - let _x_i2 = o#match_case _x_i2 in McOr _x _x_i1 _x_i2 - | McArr _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#expr _x_i2 in - let _x_i3 = o#expr _x_i3 in McArr _x _x_i1 _x_i2 _x_i3 - | McAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in McAnt _x _x_i1 ]; - method loc : loc -> loc = o#unknown; - method ident : ident -> ident = - fun - [ IdAcc _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#ident _x_i2 in IdAcc _x _x_i1 _x_i2 - | IdApp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#ident _x_i2 in IdApp _x _x_i1 _x_i2 - | IdLid _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in IdLid _x _x_i1 - | IdUid _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in IdUid _x _x_i1 - | IdAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in IdAnt _x _x_i1 ]; - method expr : expr -> expr = - fun - [ ExNil _x -> let _x = o#loc _x in ExNil _x - | ExId _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in ExId _x _x_i1 - | ExAcc _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExAcc _x _x_i1 _x_i2 - | ExAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExAnt _x _x_i1 - | ExApp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExApp _x _x_i1 _x_i2 - | ExAre _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExAre _x _x_i1 _x_i2 - | ExArr _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExArr _x _x_i1 - | ExSem _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExSem _x _x_i1 _x_i2 - | ExAsf _x -> let _x = o#loc _x in ExAsf _x - | ExAsr _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExAsr _x _x_i1 - | ExAss _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExAss _x _x_i1 _x_i2 - | ExChr _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExChr _x _x_i1 - | ExCoe _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#ctyp _x_i2 in - let _x_i3 = o#ctyp _x_i3 in ExCoe _x _x_i1 _x_i2 _x_i3 - | ExFlo _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExFlo _x _x_i1 - | ExFor _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in - let _x_i3 = o#expr _x_i3 in - let _x_i4 = o#direction_flag _x_i4 in - let _x_i5 = o#expr _x_i5 - in ExFor _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 - | ExFun _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#match_case _x_i1 in ExFun _x _x_i1 - | ExIfe _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in - let _x_i3 = o#expr _x_i3 in ExIfe _x _x_i1 _x_i2 _x_i3 - | ExInt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExInt _x _x_i1 - | ExInt32 _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExInt32 _x _x_i1 - | ExInt64 _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExInt64 _x _x_i1 - | ExNativeInt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExNativeInt _x _x_i1 - | ExLab _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in ExLab _x _x_i1 _x_i2 - | ExLaz _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExLaz _x _x_i1 - | ExLet _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#rec_flag _x_i1 in - let _x_i2 = o#binding _x_i2 in - let _x_i3 = o#expr _x_i3 in ExLet _x _x_i1 _x_i2 _x_i3 - | ExLmd _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_expr _x_i2 in - let _x_i3 = o#expr _x_i3 in ExLmd _x _x_i1 _x_i2 _x_i3 - | ExMat _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#match_case _x_i2 in ExMat _x _x_i1 _x_i2 - | ExNew _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in ExNew _x _x_i1 - | ExObj _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#class_str_item _x_i2 in ExObj _x _x_i1 _x_i2 - | ExOlb _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in ExOlb _x _x_i1 _x_i2 - | ExOvr _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#rec_binding _x_i1 in ExOvr _x _x_i1 - | ExRec _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#rec_binding _x_i1 in - let _x_i2 = o#expr _x_i2 in ExRec _x _x_i1 _x_i2 - | ExSeq _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExSeq _x _x_i1 - | ExSnd _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#string _x_i2 in ExSnd _x _x_i1 _x_i2 - | ExSte _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExSte _x _x_i1 _x_i2 - | ExStr _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExStr _x _x_i1 - | ExTry _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#match_case _x_i2 in ExTry _x _x_i1 _x_i2 - | ExTup _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in ExTup _x _x_i1 - | ExCom _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExCom _x _x_i1 _x_i2 - | ExTyc _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#ctyp _x_i2 in ExTyc _x _x_i1 _x_i2 - | ExVrn _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExVrn _x _x_i1 - | ExWhi _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExWhi _x _x_i1 _x_i2 - | ExOpI _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#expr _x_i2 in ExOpI _x _x_i1 _x_i2 - | ExFUN _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in ExFUN _x _x_i1 _x_i2 - | ExPkg _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in ExPkg _x _x_i1 ]; - method direction_flag : direction_flag -> direction_flag = - fun - [ DiTo -> DiTo - | DiDownto -> DiDownto - | DiAnt _x -> let _x = o#string _x in DiAnt _x ]; - method ctyp : ctyp -> ctyp = - fun - [ TyNil _x -> let _x = o#loc _x in TyNil _x - | TyAli _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyAli _x _x_i1 _x_i2 - | TyAny _x -> let _x = o#loc _x in TyAny _x - | TyApp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyApp _x _x_i1 _x_i2 - | TyArr _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyArr _x _x_i1 _x_i2 - | TyCls _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in TyCls _x _x_i1 - | TyLab _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyLab _x _x_i1 _x_i2 - | TyId _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ident _x_i1 in TyId _x _x_i1 - | TyMan _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyMan _x _x_i1 _x_i2 - | TyDcl _x _x_i1 _x_i2 _x_i3 _x_i4 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#list (fun o -> o#ctyp) _x_i2 in - let _x_i3 = o#ctyp _x_i3 in - let _x_i4 = - o#list - (fun o (_x, _x_i1) -> - let _x = o#ctyp _x in - let _x_i1 = o#ctyp _x_i1 in (_x, _x_i1)) - _x_i4 - in TyDcl _x _x_i1 _x_i2 _x_i3 _x_i4 - | TyObj _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#row_var_flag _x_i2 in TyObj _x _x_i1 _x_i2 - | TyOlb _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyOlb _x _x_i1 _x_i2 - | TyPol _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyPol _x _x_i1 _x_i2 - | TyTypePol _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyTypePol _x _x_i1 _x_i2 - | TyQuo _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyQuo _x _x_i1 - | TyQuP _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyQuP _x _x_i1 - | TyQuM _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyQuM _x _x_i1 - | TyAnP _x -> let _x = o#loc _x in TyAnP _x - | TyAnM _x -> let _x = o#loc _x in TyAnM _x - | TyVrn _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyVrn _x _x_i1 - | TyRec _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyRec _x _x_i1 - | TyCol _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyCol _x _x_i1 _x_i2 - | TySem _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TySem _x _x_i1 _x_i2 - | TyCom _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyCom _x _x_i1 _x_i2 - | TySum _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TySum _x _x_i1 - | TyOf _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyOf _x _x_i1 _x_i2 - | TyAnd _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyAnd _x _x_i1 _x_i2 - | TyOr _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyOr _x _x_i1 _x_i2 - | TyPrv _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyPrv _x _x_i1 - | TyMut _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyMut _x _x_i1 - | TyTup _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#ctyp _x_i1 in TyTup _x _x_i1 - | TySta _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TySta _x _x_i1 _x_i2 - | TyVrnEq _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyVrnEq _x _x_i1 - | TyVrnSup _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyVrnSup _x _x_i1 - | TyVrnInf _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyVrnInf _x _x_i1 - | TyVrnInfSup _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyVrnInfSup _x _x_i1 _x_i2 - | TyAmp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyAmp _x _x_i1 _x_i2 - | TyOfAmp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyOfAmp _x _x_i1 _x_i2 - | TyPkg _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#module_type _x_i1 in TyPkg _x _x_i1 - | TyAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyAnt _x _x_i1 ]; - method class_type : class_type -> class_type = - fun - [ CtNil _x -> let _x = o#loc _x in CtNil _x - | CtCon _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#virtual_flag _x_i1 in - let _x_i2 = o#ident _x_i2 in - let _x_i3 = o#ctyp _x_i3 in CtCon _x _x_i1 _x_i2 _x_i3 - | CtFun _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#class_type _x_i2 in CtFun _x _x_i1 _x_i2 - | CtSig _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#class_sig_item _x_i2 in CtSig _x _x_i1 _x_i2 - | CtAnd _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in - let _x_i2 = o#class_type _x_i2 in CtAnd _x _x_i1 _x_i2 - | CtCol _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in - let _x_i2 = o#class_type _x_i2 in CtCol _x _x_i1 _x_i2 - | CtEq _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in - let _x_i2 = o#class_type _x_i2 in CtEq _x _x_i1 _x_i2 - | CtAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in CtAnt _x _x_i1 ]; - method class_str_item : class_str_item -> class_str_item = - fun - [ CrNil _x -> let _x = o#loc _x in CrNil _x - | CrSem _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_str_item _x_i1 in - let _x_i2 = o#class_str_item _x_i2 in CrSem _x _x_i1 _x_i2 - | CrCtr _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in CrCtr _x _x_i1 _x_i2 - | CrInh _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#override_flag _x_i1 in - let _x_i2 = o#class_expr _x_i2 in - let _x_i3 = o#string _x_i3 in CrInh _x _x_i1 _x_i2 _x_i3 - | CrIni _x _x_i1 -> - let _x = o#loc _x in let _x_i1 = o#expr _x_i1 in CrIni _x _x_i1 - | CrMth _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#override_flag _x_i2 in - let _x_i3 = o#private_flag _x_i3 in - let _x_i4 = o#expr _x_i4 in - let _x_i5 = o#ctyp _x_i5 - in CrMth _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 - | CrVal _x _x_i1 _x_i2 _x_i3 _x_i4 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#override_flag _x_i2 in - let _x_i3 = o#mutable_flag _x_i3 in - let _x_i4 = o#expr _x_i4 in CrVal _x _x_i1 _x_i2 _x_i3 _x_i4 - | CrVir _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#private_flag _x_i2 in - let _x_i3 = o#ctyp _x_i3 in CrVir _x _x_i1 _x_i2 _x_i3 - | CrVvr _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#mutable_flag _x_i2 in - let _x_i3 = o#ctyp _x_i3 in CrVvr _x _x_i1 _x_i2 _x_i3 - | CrAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in CrAnt _x _x_i1 ]; - method class_sig_item : class_sig_item -> class_sig_item = - fun - [ CgNil _x -> let _x = o#loc _x in CgNil _x - | CgCtr _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in CgCtr _x _x_i1 _x_i2 - | CgSem _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_sig_item _x_i1 in - let _x_i2 = o#class_sig_item _x_i2 in CgSem _x _x_i1 _x_i2 - | CgInh _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in CgInh _x _x_i1 - | CgMth _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#private_flag _x_i2 in - let _x_i3 = o#ctyp _x_i3 in CgMth _x _x_i1 _x_i2 _x_i3 - | CgVal _x _x_i1 _x_i2 _x_i3 _x_i4 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#mutable_flag _x_i2 in - let _x_i3 = o#virtual_flag _x_i3 in - let _x_i4 = o#ctyp _x_i4 in CgVal _x _x_i1 _x_i2 _x_i3 _x_i4 - | CgVir _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#private_flag _x_i2 in - let _x_i3 = o#ctyp _x_i3 in CgVir _x _x_i1 _x_i2 _x_i3 - | CgAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in CgAnt _x _x_i1 ]; - method class_expr : class_expr -> class_expr = - fun - [ CeNil _x -> let _x = o#loc _x in CeNil _x - | CeApp _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in - let _x_i2 = o#expr _x_i2 in CeApp _x _x_i1 _x_i2 - | CeCon _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#virtual_flag _x_i1 in - let _x_i2 = o#ident _x_i2 in - let _x_i3 = o#ctyp _x_i3 in CeCon _x _x_i1 _x_i2 _x_i3 - | CeFun _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#class_expr _x_i2 in CeFun _x _x_i1 _x_i2 - | CeLet _x _x_i1 _x_i2 _x_i3 -> - let _x = o#loc _x in - let _x_i1 = o#rec_flag _x_i1 in - let _x_i2 = o#binding _x_i2 in - let _x_i3 = o#class_expr _x_i3 in CeLet _x _x_i1 _x_i2 _x_i3 - | CeStr _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#class_str_item _x_i2 in CeStr _x _x_i1 _x_i2 - | CeTyc _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in - let _x_i2 = o#class_type _x_i2 in CeTyc _x _x_i1 _x_i2 - | CeAnd _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in - let _x_i2 = o#class_expr _x_i2 in CeAnd _x _x_i1 _x_i2 - | CeEq _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in - let _x_i2 = o#class_expr _x_i2 in CeEq _x _x_i1 _x_i2 - | CeAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in CeAnt _x _x_i1 ]; - method binding : binding -> binding = - fun - [ BiNil _x -> let _x = o#loc _x in BiNil _x - | BiAnd _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#binding _x_i1 in - let _x_i2 = o#binding _x_i2 in BiAnd _x _x_i1 _x_i2 - | BiEq _x _x_i1 _x_i2 -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#expr _x_i2 in BiEq _x _x_i1 _x_i2 - | BiAnt _x _x_i1 -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in BiAnt _x _x_i1 ]; - method unknown : ! 'a. 'a -> 'a = fun x -> x; - end; - class fold = - object ((o : 'self_type)) - method string : string -> 'self_type = o#unknown; - method list : - ! 'a. ('self_type -> 'a -> 'self_type) -> list 'a -> 'self_type = - fun _f_a -> - fun - [ [] -> o - | [ _x :: _x_i1 ] -> - let o = _f_a o _x in let o = o#list _f_a _x_i1 in o ]; - method with_constr : with_constr -> 'self_type = - fun - [ WcNil _x -> let o = o#loc _x in o - | WcTyp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | WcMod _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#ident _x_i2 in o - | WcTyS _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | WcMoS _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#ident _x_i2 in o - | WcAnd _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#with_constr _x_i1 in let o = o#with_constr _x_i2 in o - | WcAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method virtual_flag : virtual_flag -> 'self_type = - fun - [ ViVirtual -> o - | ViNil -> o - | ViAnt _x -> let o = o#string _x in o ]; - method str_item : str_item -> 'self_type = - fun - [ StNil _x -> let o = o#loc _x in o - | StCls _x _x_i1 -> - let o = o#loc _x in let o = o#class_expr _x_i1 in o - | StClt _x _x_i1 -> - let o = o#loc _x in let o = o#class_type _x_i1 in o - | StSem _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#str_item _x_i1 in let o = o#str_item _x_i2 in o - | StDir _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | StExc _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in - let o = o#meta_option (fun o -> o#ident) _x_i2 in o - | StExp _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o - | StExt _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#ctyp _x_i2 in - let o = o#meta_list (fun o -> o#string) _x_i3 in o - | StInc _x _x_i1 -> - let o = o#loc _x in let o = o#module_expr _x_i1 in o - | StMod _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#module_expr _x_i2 in o - | StRecMod _x _x_i1 -> - let o = o#loc _x in let o = o#module_binding _x_i1 in o - | StMty _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#module_type _x_i2 in o - | StOpn _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | StTyp _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | StVal _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#rec_flag _x_i1 in let o = o#binding _x_i2 in o - | StAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method sig_item : sig_item -> 'self_type = - fun - [ SgNil _x -> let o = o#loc _x in o - | SgCls _x _x_i1 -> - let o = o#loc _x in let o = o#class_type _x_i1 in o - | SgClt _x _x_i1 -> - let o = o#loc _x in let o = o#class_type _x_i1 in o - | SgSem _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#sig_item _x_i1 in let o = o#sig_item _x_i2 in o - | SgDir _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | SgExc _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | SgExt _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#ctyp _x_i2 in - let o = o#meta_list (fun o -> o#string) _x_i3 in o - | SgInc _x _x_i1 -> - let o = o#loc _x in let o = o#module_type _x_i1 in o - | SgMod _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#module_type _x_i2 in o - | SgRecMod _x _x_i1 -> - let o = o#loc _x in let o = o#module_binding _x_i1 in o - | SgMty _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#module_type _x_i2 in o - | SgOpn _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | SgTyp _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | SgVal _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o - | SgAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method row_var_flag : row_var_flag -> 'self_type = - fun - [ RvRowVar -> o - | RvNil -> o - | RvAnt _x -> let o = o#string _x in o ]; - method rec_flag : rec_flag -> 'self_type = - fun - [ ReRecursive -> o - | ReNil -> o - | ReAnt _x -> let o = o#string _x in o ]; - method rec_binding : rec_binding -> 'self_type = - fun - [ RbNil _x -> let o = o#loc _x in o - | RbSem _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#rec_binding _x_i1 in let o = o#rec_binding _x_i2 in o - | RbEq _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#expr _x_i2 in o - | RbAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method private_flag : private_flag -> 'self_type = - fun - [ PrPrivate -> o - | PrNil -> o - | PrAnt _x -> let o = o#string _x in o ]; - method patt : patt -> 'self_type = - fun - [ PaNil _x -> let o = o#loc _x in o - | PaId _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | PaAli _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | PaAny _x -> let o = o#loc _x in o - | PaApp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaArr _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o - | PaCom _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaSem _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaChr _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | PaInt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | PaInt32 _x _x_i1 -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaInt64 _x _x_i1 -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaNativeInt _x _x_i1 -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaFlo _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | PaLab _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#patt _x_i2 in o - | PaOlb _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#patt _x_i2 in o - | PaOlbi _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#patt _x_i2 in let o = o#expr _x_i3 in o - | PaOrp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaRng _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaRec _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o - | PaEq _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#patt _x_i2 in o - | PaStr _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | PaTup _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o - | PaTyc _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#ctyp _x_i2 in o - | PaTyp _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | PaVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | PaLaz _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o - | PaMod _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method override_flag : override_flag -> 'self_type = - fun - [ OvOverride -> o - | OvNil -> o - | OvAnt _x -> let o = o#string _x in o ]; - method mutable_flag : mutable_flag -> 'self_type = - fun - [ MuMutable -> o - | MuNil -> o - | MuAnt _x -> let o = o#string _x in o ]; - method module_type : module_type -> 'self_type = - fun - [ MtNil _x -> let o = o#loc _x in o - | MtId _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | MtFun _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in let o = o#module_type _x_i3 in o - | MtQuo _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | MtSig _x _x_i1 -> - let o = o#loc _x in let o = o#sig_item _x_i1 in o - | MtWit _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#module_type _x_i1 in let o = o#with_constr _x_i2 in o - | MtOf _x _x_i1 -> - let o = o#loc _x in let o = o#module_expr _x_i1 in o - | MtAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method module_expr : module_expr -> 'self_type = - fun - [ MeNil _x -> let o = o#loc _x in o - | MeId _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | MeApp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#module_expr _x_i1 in let o = o#module_expr _x_i2 in o - | MeFun _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in let o = o#module_expr _x_i3 in o - | MeStr _x _x_i1 -> - let o = o#loc _x in let o = o#str_item _x_i1 in o - | MeTyc _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#module_expr _x_i1 in let o = o#module_type _x_i2 in o - | MePkg _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o - | MeAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method module_binding : module_binding -> 'self_type = - fun - [ MbNil _x -> let o = o#loc _x in o - | MbAnd _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#module_binding _x_i1 in - let o = o#module_binding _x_i2 in o - | MbColEq _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in let o = o#module_expr _x_i3 in o - | MbCol _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#module_type _x_i2 in o - | MbAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method meta_option : - ! 'a. - ('self_type -> 'a -> 'self_type) -> meta_option 'a -> 'self_type = - fun _f_a -> - fun - [ ONone -> o - | OSome _x -> let o = _f_a o _x in o - | OAnt _x -> let o = o#string _x in o ]; - method meta_list : - ! 'a. - ('self_type -> 'a -> 'self_type) -> meta_list 'a -> 'self_type = - fun _f_a -> - fun - [ LNil -> o - | LCons _x _x_i1 -> - let o = _f_a o _x in let o = o#meta_list _f_a _x_i1 in o - | LAnt _x -> let o = o#string _x in o ]; - method meta_bool : meta_bool -> 'self_type = - fun - [ BTrue -> o - | BFalse -> o - | BAnt _x -> let o = o#string _x in o ]; - method match_case : match_case -> 'self_type = - fun - [ McNil _x -> let o = o#loc _x in o - | McOr _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#match_case _x_i1 in let o = o#match_case _x_i2 in o - | McArr _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#patt _x_i1 in - let o = o#expr _x_i2 in let o = o#expr _x_i3 in o - | McAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method loc : loc -> 'self_type = o#unknown; - method ident : ident -> 'self_type = - fun - [ IdAcc _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#ident _x_i2 in o - | IdApp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#ident _x_i2 in o - | IdLid _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | IdUid _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | IdAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method expr : expr -> 'self_type = - fun - [ ExNil _x -> let o = o#loc _x in o - | ExId _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | ExAcc _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | ExApp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExAre _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExArr _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o - | ExSem _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExAsf _x -> let o = o#loc _x in o - | ExAsr _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o - | ExAss _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExChr _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | ExCoe _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#expr _x_i1 in - let o = o#ctyp _x_i2 in let o = o#ctyp _x_i3 in o - | ExFlo _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | ExFor _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#expr _x_i2 in - let o = o#expr _x_i3 in - let o = o#direction_flag _x_i4 in let o = o#expr _x_i5 in o - | ExFun _x _x_i1 -> - let o = o#loc _x in let o = o#match_case _x_i1 in o - | ExIfe _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#expr _x_i1 in - let o = o#expr _x_i2 in let o = o#expr _x_i3 in o - | ExInt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | ExInt32 _x _x_i1 -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExInt64 _x _x_i1 -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExNativeInt _x _x_i1 -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExLab _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | ExLaz _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o - | ExLet _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#rec_flag _x_i1 in - let o = o#binding _x_i2 in let o = o#expr _x_i3 in o - | ExLmd _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_expr _x_i2 in let o = o#expr _x_i3 in o - | ExMat _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#match_case _x_i2 in o - | ExNew _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | ExObj _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#class_str_item _x_i2 in o - | ExOlb _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | ExOvr _x _x_i1 -> - let o = o#loc _x in let o = o#rec_binding _x_i1 in o - | ExRec _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#rec_binding _x_i1 in let o = o#expr _x_i2 in o - | ExSeq _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o - | ExSnd _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#string _x_i2 in o - | ExSte _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExStr _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | ExTry _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#match_case _x_i2 in o - | ExTup _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o - | ExCom _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExTyc _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#ctyp _x_i2 in o - | ExVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | ExWhi _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExOpI _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#expr _x_i2 in o - | ExFUN _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | ExPkg _x _x_i1 -> - let o = o#loc _x in let o = o#module_expr _x_i1 in o ]; - method direction_flag : direction_flag -> 'self_type = - fun - [ DiTo -> o - | DiDownto -> o - | DiAnt _x -> let o = o#string _x in o ]; - method ctyp : ctyp -> 'self_type = - fun - [ TyNil _x -> let o = o#loc _x in o - | TyAli _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyAny _x -> let o = o#loc _x in o - | TyApp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyArr _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyCls _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | TyLab _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o - | TyId _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | TyMan _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyDcl _x _x_i1 _x_i2 _x_i3 _x_i4 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#list (fun o -> o#ctyp) _x_i2 in - let o = o#ctyp _x_i3 in - let o = - o#list - (fun o (_x, _x_i1) -> - let o = o#ctyp _x in let o = o#ctyp _x_i1 in o) - _x_i4 - in o - | TyObj _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#row_var_flag _x_i2 in o - | TyOlb _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o - | TyPol _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyTypePol _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyQuo _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | TyQuP _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | TyQuM _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | TyAnP _x -> let o = o#loc _x in o - | TyAnM _x -> let o = o#loc _x in o - | TyVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o - | TyRec _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyCol _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TySem _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyCom _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TySum _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyOf _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyAnd _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyOr _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyPrv _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyMut _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyTup _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TySta _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyVrnEq _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyVrnSup _x _x_i1 -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyVrnInf _x _x_i1 -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyVrnInfSup _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyAmp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyOfAmp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyPkg _x _x_i1 -> - let o = o#loc _x in let o = o#module_type _x_i1 in o - | TyAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method class_type : class_type -> 'self_type = - fun - [ CtNil _x -> let o = o#loc _x in o - | CtCon _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#virtual_flag _x_i1 in - let o = o#ident _x_i2 in let o = o#ctyp _x_i3 in o - | CtFun _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#class_type _x_i2 in o - | CtSig _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#class_sig_item _x_i2 in o - | CtAnd _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_type _x_i1 in let o = o#class_type _x_i2 in o - | CtCol _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_type _x_i1 in let o = o#class_type _x_i2 in o - | CtEq _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_type _x_i1 in let o = o#class_type _x_i2 in o - | CtAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method class_str_item : class_str_item -> 'self_type = - fun - [ CrNil _x -> let o = o#loc _x in o - | CrSem _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_str_item _x_i1 in - let o = o#class_str_item _x_i2 in o - | CrCtr _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | CrInh _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#override_flag _x_i1 in - let o = o#class_expr _x_i2 in let o = o#string _x_i3 in o - | CrIni _x _x_i1 -> let o = o#loc _x in let o = o#expr _x_i1 in o - | CrMth _x _x_i1 _x_i2 _x_i3 _x_i4 _x_i5 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#override_flag _x_i2 in - let o = o#private_flag _x_i3 in - let o = o#expr _x_i4 in let o = o#ctyp _x_i5 in o - | CrVal _x _x_i1 _x_i2 _x_i3 _x_i4 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#override_flag _x_i2 in - let o = o#mutable_flag _x_i3 in let o = o#expr _x_i4 in o - | CrVir _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#private_flag _x_i2 in let o = o#ctyp _x_i3 in o - | CrVvr _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#mutable_flag _x_i2 in let o = o#ctyp _x_i3 in o - | CrAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method class_sig_item : class_sig_item -> 'self_type = - fun - [ CgNil _x -> let o = o#loc _x in o - | CgCtr _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | CgSem _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_sig_item _x_i1 in - let o = o#class_sig_item _x_i2 in o - | CgInh _x _x_i1 -> - let o = o#loc _x in let o = o#class_type _x_i1 in o - | CgMth _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#private_flag _x_i2 in let o = o#ctyp _x_i3 in o - | CgVal _x _x_i1 _x_i2 _x_i3 _x_i4 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#mutable_flag _x_i2 in - let o = o#virtual_flag _x_i3 in let o = o#ctyp _x_i4 in o - | CgVir _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#private_flag _x_i2 in let o = o#ctyp _x_i3 in o - | CgAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method class_expr : class_expr -> 'self_type = - fun - [ CeNil _x -> let o = o#loc _x in o - | CeApp _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_expr _x_i1 in let o = o#expr _x_i2 in o - | CeCon _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#virtual_flag _x_i1 in - let o = o#ident _x_i2 in let o = o#ctyp _x_i3 in o - | CeFun _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#class_expr _x_i2 in o - | CeLet _x _x_i1 _x_i2 _x_i3 -> - let o = o#loc _x in - let o = o#rec_flag _x_i1 in - let o = o#binding _x_i2 in let o = o#class_expr _x_i3 in o - | CeStr _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#class_str_item _x_i2 in o - | CeTyc _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_expr _x_i1 in let o = o#class_type _x_i2 in o - | CeAnd _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_expr _x_i1 in let o = o#class_expr _x_i2 in o - | CeEq _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#class_expr _x_i1 in let o = o#class_expr _x_i2 in o - | CeAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method binding : binding -> 'self_type = - fun - [ BiNil _x -> let o = o#loc _x in o - | BiAnd _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#binding _x_i1 in let o = o#binding _x_i2 in o - | BiEq _x _x_i1 _x_i2 -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#expr _x_i2 in o - | BiAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; - method unknown : ! 'a. 'a -> 'self_type = fun _ -> o; - end; - value map_expr f = - object inherit map as super; method expr = fun x -> f (super#expr x); - end; - value map_patt f = - object inherit map as super; method patt = fun x -> f (super#patt x); - end; - value map_ctyp f = - object inherit map as super; method ctyp = fun x -> f (super#ctyp x); - end; - value map_str_item f = - object - inherit map as super; - method str_item = fun x -> f (super#str_item x); - end; - value map_sig_item f = - object - inherit map as super; - method sig_item = fun x -> f (super#sig_item x); - end; - value map_loc f = - object inherit map as super; method loc = fun x -> f (super#loc x); end; - end; - diff -Nru ocaml-4.01.0/camlp4/boot/camlp4boot.ml ocaml-4.02.3/camlp4/boot/camlp4boot.ml --- ocaml-4.01.0/camlp4/boot/camlp4boot.ml 2013-08-30 13:39:33.000000000 +0200 +++ ocaml-4.02.3/camlp4/boot/camlp4boot.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,16057 +0,0 @@ -module R = - struct - open Camlp4 - - (* -*- camlp4r -*- *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2002-2006 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 OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - module Id = - struct - let name = "Camlp4OCamlRevisedParser" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - open Sig - - include Syntax - - (* Camlp4_config.constructors_arity.val := True; *) - let _ = Camlp4_config.constructors_arity := false - - let help_sequences () = - (Printf.eprintf - "\ -New syntax:\ -\n (e1; e2; ... ; en) OR begin e1; e2; ... ; en end\ -\n while e do e1; e2; ... ; en done\ -\n for v = v1 to/downto v2 do e1; e2; ... ; en done\ -\nOld syntax (still supported):\ -\n do {e1; e2; ... ; en}\ -\n while e do {e1; e2; ... ; en}\ -\n for v = v1 to/downto v2 do {e1; e2; ... ; en}\ -\nVery old (no more supported) syntax:\ -\n do e1; e2; ... ; en-1; return en\ -\n while e do e1; e2; ... ; en; done\ -\n for v = v1 to/downto v2 do e1; e2; ... ; en; done\ -\n"; - flush stderr; - exit 1) - - let _ = - Options.add "-help_seq" (Arg.Unit help_sequences) - "Print explanations about new sequences and exit." - - let _ = Gram.Entry.clear a_CHAR - - let _ = Gram.Entry.clear a_FLOAT - - let _ = Gram.Entry.clear a_INT - - let _ = Gram.Entry.clear a_INT32 - - let _ = Gram.Entry.clear a_INT64 - - let _ = Gram.Entry.clear a_LABEL - - let _ = Gram.Entry.clear a_LIDENT - - let _ = Gram.Entry.clear a_NATIVEINT - - let _ = Gram.Entry.clear a_OPTLABEL - - let _ = Gram.Entry.clear a_STRING - - let _ = Gram.Entry.clear a_UIDENT - - let _ = Gram.Entry.clear a_ident - - let _ = Gram.Entry.clear amp_ctyp - - let _ = Gram.Entry.clear and_ctyp - - let _ = Gram.Entry.clear match_case - - let _ = Gram.Entry.clear match_case0 - - let _ = Gram.Entry.clear match_case_quot - - let _ = Gram.Entry.clear binding - - let _ = Gram.Entry.clear binding_quot - - let _ = Gram.Entry.clear rec_binding_quot - - let _ = Gram.Entry.clear class_declaration - - let _ = Gram.Entry.clear class_description - - let _ = Gram.Entry.clear class_expr - - let _ = Gram.Entry.clear class_expr_quot - - let _ = Gram.Entry.clear class_fun_binding - - let _ = Gram.Entry.clear class_fun_def - - let _ = Gram.Entry.clear class_info_for_class_expr - - let _ = Gram.Entry.clear class_info_for_class_type - - let _ = Gram.Entry.clear class_longident - - let _ = Gram.Entry.clear class_longident_and_param - - let _ = Gram.Entry.clear class_name_and_param - - let _ = Gram.Entry.clear class_sig_item - - let _ = Gram.Entry.clear class_sig_item_quot - - let _ = Gram.Entry.clear class_signature - - let _ = Gram.Entry.clear class_str_item - - let _ = Gram.Entry.clear class_str_item_quot - - let _ = Gram.Entry.clear class_structure - - let _ = Gram.Entry.clear class_type - - let _ = Gram.Entry.clear class_type_declaration - - let _ = Gram.Entry.clear class_type_longident - - let _ = Gram.Entry.clear class_type_longident_and_param - - let _ = Gram.Entry.clear class_type_plus - - let _ = Gram.Entry.clear class_type_quot - - let _ = Gram.Entry.clear comma_ctyp - - let _ = Gram.Entry.clear comma_expr - - let _ = Gram.Entry.clear comma_ipatt - - let _ = Gram.Entry.clear comma_patt - - let _ = Gram.Entry.clear comma_type_parameter - - let _ = Gram.Entry.clear constrain - - let _ = Gram.Entry.clear constructor_arg_list - - let _ = Gram.Entry.clear constructor_declaration - - let _ = Gram.Entry.clear constructor_declarations - - let _ = Gram.Entry.clear ctyp - - let _ = Gram.Entry.clear ctyp_quot - - let _ = Gram.Entry.clear cvalue_binding - - let _ = Gram.Entry.clear direction_flag - - let _ = Gram.Entry.clear dummy - - let _ = Gram.Entry.clear eq_expr - - let _ = Gram.Entry.clear expr - - let _ = Gram.Entry.clear expr_eoi - - let _ = Gram.Entry.clear expr_quot - - let _ = Gram.Entry.clear field_expr - - let _ = Gram.Entry.clear field_expr_list - - let _ = Gram.Entry.clear fun_binding - - let _ = Gram.Entry.clear fun_def - - let _ = Gram.Entry.clear ident - - let _ = Gram.Entry.clear ident_quot - - let _ = Gram.Entry.clear implem - - let _ = Gram.Entry.clear interf - - let _ = Gram.Entry.clear ipatt - - let _ = Gram.Entry.clear ipatt_tcon - - let _ = Gram.Entry.clear label - - let _ = Gram.Entry.clear label_declaration - - let _ = Gram.Entry.clear label_declaration_list - - let _ = Gram.Entry.clear label_expr_list - - let _ = Gram.Entry.clear label_expr - - let _ = Gram.Entry.clear label_ipatt - - let _ = Gram.Entry.clear label_ipatt_list - - let _ = Gram.Entry.clear label_longident - - let _ = Gram.Entry.clear label_patt - - let _ = Gram.Entry.clear label_patt_list - - let _ = Gram.Entry.clear labeled_ipatt - - let _ = Gram.Entry.clear let_binding - - let _ = Gram.Entry.clear meth_list - - let _ = Gram.Entry.clear meth_decl - - let _ = Gram.Entry.clear module_binding - - let _ = Gram.Entry.clear module_binding0 - - let _ = Gram.Entry.clear module_binding_quot - - let _ = Gram.Entry.clear module_declaration - - let _ = Gram.Entry.clear module_expr - - let _ = Gram.Entry.clear module_expr_quot - - let _ = Gram.Entry.clear module_longident - - let _ = Gram.Entry.clear module_longident_with_app - - let _ = Gram.Entry.clear module_rec_declaration - - let _ = Gram.Entry.clear module_type - - let _ = Gram.Entry.clear module_type_quot - - let _ = Gram.Entry.clear more_ctyp - - let _ = Gram.Entry.clear name_tags - - let _ = Gram.Entry.clear opt_as_lident - - let _ = Gram.Entry.clear opt_class_self_patt - - let _ = Gram.Entry.clear opt_class_self_type - - let _ = Gram.Entry.clear opt_comma_ctyp - - let _ = Gram.Entry.clear opt_dot_dot - - let _ = Gram.Entry.clear opt_eq_ctyp - - let _ = Gram.Entry.clear opt_expr - - let _ = Gram.Entry.clear opt_meth_list - - let _ = Gram.Entry.clear opt_mutable - - let _ = Gram.Entry.clear opt_polyt - - let _ = Gram.Entry.clear opt_private - - let _ = Gram.Entry.clear opt_rec - - let _ = Gram.Entry.clear opt_virtual - - let _ = Gram.Entry.clear opt_when_expr - - let _ = Gram.Entry.clear patt - - let _ = Gram.Entry.clear patt_as_patt_opt - - let _ = Gram.Entry.clear patt_eoi - - let _ = Gram.Entry.clear patt_quot - - let _ = Gram.Entry.clear patt_tcon - - let _ = Gram.Entry.clear phrase - - let _ = Gram.Entry.clear poly_type - - let _ = Gram.Entry.clear row_field - - let _ = Gram.Entry.clear sem_expr - - let _ = Gram.Entry.clear sem_expr_for_list - - let _ = Gram.Entry.clear sem_patt - - let _ = Gram.Entry.clear sem_patt_for_list - - let _ = Gram.Entry.clear semi - - let _ = Gram.Entry.clear sequence - - let _ = Gram.Entry.clear sig_item - - let _ = Gram.Entry.clear sig_item_quot - - let _ = Gram.Entry.clear sig_items - - let _ = Gram.Entry.clear star_ctyp - - let _ = Gram.Entry.clear str_item - - let _ = Gram.Entry.clear str_item_quot - - let _ = Gram.Entry.clear str_items - - let _ = Gram.Entry.clear top_phrase - - let _ = Gram.Entry.clear type_constraint - - let _ = Gram.Entry.clear type_declaration - - let _ = Gram.Entry.clear type_ident_and_parameters - - let _ = Gram.Entry.clear type_kind - - let _ = Gram.Entry.clear type_longident - - let _ = Gram.Entry.clear type_longident_and_parameters - - let _ = Gram.Entry.clear type_parameter - - let _ = Gram.Entry.clear type_parameters - - let _ = Gram.Entry.clear typevars - - let _ = Gram.Entry.clear use_file - - let _ = Gram.Entry.clear val_longident - - let _ = Gram.Entry.clear value_let - - let _ = Gram.Entry.clear value_val - - let _ = Gram.Entry.clear with_constr - - let _ = Gram.Entry.clear with_constr_quot - - let neg_string n = - let len = String.length n - in - if (len > 0) && (n.[0] = '-') - then String.sub n 1 (len - 1) - else "-" ^ n - - let mkumin _loc f arg = - match arg with - | Ast.ExInt (_, n) -> Ast.ExInt (_loc, (neg_string n)) - | Ast.ExInt32 (_, n) -> Ast.ExInt32 (_loc, (neg_string n)) - | Ast.ExInt64 (_, n) -> Ast.ExInt64 (_loc, (neg_string n)) - | Ast.ExNativeInt (_, n) -> Ast.ExNativeInt (_loc, (neg_string n)) - | Ast.ExFlo (_, n) -> Ast.ExFlo (_loc, (neg_string n)) - | _ -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdLid (_loc, ("~" ^ f))))), arg) - - let mklistexp _loc last = - let rec loop top = - function - | [] -> - (match last with - | Some e -> e - | None -> Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) - | e1 :: el -> - let _loc = - if top then _loc else Loc.merge (Ast.loc_of_expr e1) _loc - in - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), e1)), - (loop false el)) - in loop true - - let mkassert _loc = - function - | Ast.ExId (_, (Ast.IdUid (_, "False"))) -> Ast.ExAsf _loc - | (* this case takes care about - the special assert false node *) - e -> Ast.ExAsr (_loc, e) - - let append_eLem el e = el @ [ e ] - - let mk_anti ?(c = "") n s = "\\$" ^ (n ^ (c ^ (":" ^ s))) - - let mksequence _loc = - function - | (Ast.ExSem (_, _, _) | Ast.ExAnt (_, _) as e) -> - Ast.ExSeq (_loc, e) - | e -> e - - let mksequence' _loc = - function - | (Ast.ExSem (_, _, _) as e) -> Ast.ExSeq (_loc, e) - | e -> e - - let rec lid_of_ident = - function - | Ast.IdAcc (_, _, i) -> lid_of_ident i - | Ast.IdLid (_, lid) -> lid - | _ -> assert false - - let module_type_app mt1 mt2 = - match (mt1, mt2) with - | (Ast.MtId (_loc, i1), Ast.MtId (_, i2)) -> - Ast.MtId (_loc, (Ast.IdApp (_loc, i1, i2))) - | _ -> raise Stream.Failure - - let module_type_acc mt1 mt2 = - match (mt1, mt2) with - | (Ast.MtId (_loc, i1), Ast.MtId (_, i2)) -> - Ast.MtId (_loc, (Ast.IdAcc (_loc, i1, i2))) - | _ -> raise Stream.Failure - - let bigarray_get _loc arr arg = - let coords = - match arg with - | Ast.ExTup (_, (Ast.ExCom (_, e1, e2))) | Ast.ExCom (_, e1, e2) - -> Ast.list_of_expr e1 (Ast.list_of_expr e2 []) - | _ -> [ arg ] - in - match coords with - | [ c1 ] -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Array1")), - (Ast.IdLid (_loc, "get")))))))), - arr)), - c1) - | [ c1; c2 ] -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Array2")), - (Ast.IdLid (_loc, "get")))))))), - arr)), - c1)), - c2) - | [ c1; c2; c3 ] -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Bigarray")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Array3")), - (Ast.IdLid (_loc, "get")))))))), - arr)), - c1)), - c2)), - c3) - | (* | coords -> <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> ] *) - coords -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Genarray")), - (Ast.IdLid (_loc, "get")))))))), - arr)), - (Ast.ExArr (_loc, (Ast.exSem_of_list coords)))) - - let bigarray_set _loc var newval = - match var with - | Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Bigarray")), - (Ast.IdAcc (_, (Ast.IdUid (_, "Array1")), - (Ast.IdLid (_, "get")))))))), - arr)), - c1) -> - Some - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Array1")), - (Ast.IdLid (_loc, "set")))))))), - arr)), - c1)), - newval)) - | Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Bigarray")), - (Ast.IdAcc (_, (Ast.IdUid (_, "Array2")), - (Ast.IdLid (_, "get")))))))), - arr)), - c1)), - c2) -> - Some - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Bigarray")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Array2")), - (Ast.IdLid (_loc, "set")))))))), - arr)), - c1)), - c2)), - newval)) - | Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Bigarray")), - (Ast.IdAcc (_, (Ast.IdUid (_, "Array3")), - (Ast.IdLid (_, "get")))))))), - arr)), - c1)), - c2)), - c3) -> - Some - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Bigarray")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Array3")), - (Ast.IdLid (_loc, "set")))))))), - arr)), - c1)), - c2)), - c3)), - newval)) - | Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Bigarray")), - (Ast.IdAcc (_, (Ast.IdUid (_, "Genarray")), - (Ast.IdLid (_, "get")))))))), - arr)), - (Ast.ExArr (_, coords))) -> - Some - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Bigarray")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Genarray")), - (Ast.IdLid (_loc, "set")))))))), - arr)), - (Ast.ExArr (_loc, coords)))), - newval)) - | _ -> None - - let stopped_at _loc = Some (Loc.move_line 1 _loc) - - (* FIXME be more precise *) - let rec generalized_type_of_type = - function - | Ast.TyArr (_, t1, t2) -> - let (tl, rt) = generalized_type_of_type t2 in ((t1 :: tl), rt) - | t -> ([], t) - - let symbolchar = - let list = - [ '$'; '!'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; - '>'; '?'; '@'; '^'; '|'; '~'; '\\' ] in - let rec loop s i = - if i == (String.length s) - then true - else if List.mem s.[i] list then loop s (i + 1) else false - in loop - - let setup_op_parser entry p = - Gram.Entry.setup_parser entry - (fun (__strm : _ Stream.t) -> - match Stream.peek __strm with - | Some (((KEYWORD x | SYMBOL x), ti)) when p x -> - (Stream.junk __strm; - let _loc = Gram.token_location ti - in Ast.ExId (_loc, (Ast.IdLid (_loc, x)))) - | _ -> raise Stream.Failure) - - let _ = - let list = [ '!'; '?'; '~' ] in - let excl = [ "!="; "??" ] - in - setup_op_parser prefixop - (fun x -> - (not (List.mem x excl)) && - (((String.length x) >= 2) && - ((List.mem x.[0] list) && (symbolchar x 1)))) - - let _ = - let list_ok = - [ "<"; ">"; "<="; ">="; "="; "<>"; "=="; "!="; "$" ] in - let list_first_char_ok = [ '='; '<'; '>'; '|'; '&'; '$'; '!' ] in - let excl = [ "<-"; "||"; "&&" ] - in - setup_op_parser infixop0 - (fun x -> - (List.mem x list_ok) || - ((not (List.mem x excl)) && - (((String.length x) >= 2) && - ((List.mem x.[0] list_first_char_ok) && - (symbolchar x 1))))) - - let _ = - let list = [ '@'; '^' ] - in - setup_op_parser infixop1 - (fun x -> - ((String.length x) >= 1) && - ((List.mem x.[0] list) && (symbolchar x 1))) - - let _ = - let list = [ '+'; '-' ] - in - setup_op_parser infixop2 - (fun x -> - (x <> "->") && - (((String.length x) >= 1) && - ((List.mem x.[0] list) && (symbolchar x 1)))) - - let _ = - let list = [ '*'; '/'; '%'; '\\' ] - in - setup_op_parser infixop3 - (fun x -> - ((String.length x) >= 1) && - ((List.mem x.[0] list) && - (((x.[0] <> '*') || - (((String.length x) < 2) || (x.[1] <> '*'))) - && (symbolchar x 1)))) - - let _ = - setup_op_parser infixop4 - (fun x -> - ((String.length x) >= 2) && - ((x.[0] == '*') && ((x.[1] == '*') && (symbolchar x 2)))) - - let rec infix_kwds_filter (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some (((KEYWORD "(", _) as tok)) -> - (Stream.junk __strm; - let xs = __strm in - let (__strm : _ Stream.t) = xs - in - (match Stream.peek __strm with - | Some - ((KEYWORD - (("or" | "mod" | "land" | "lor" | "lxor" | "lsl" | - "lsr" | "asr" - as i)), - _loc)) - -> - (Stream.junk __strm; - (match Stream.peek __strm with - | Some ((KEYWORD ")", _)) -> - (Stream.junk __strm; - let xs = __strm - in - Stream.lcons (fun _ -> ((LIDENT i), _loc)) - (Stream.slazy - (fun _ -> infix_kwds_filter xs))) - | _ -> raise (Stream.Error ""))) - | _ -> - let xs = __strm - in - Stream.icons tok - (Stream.slazy (fun _ -> infix_kwds_filter xs)))) - | Some x -> - (Stream.junk __strm; - let xs = __strm - in - Stream.icons x - (Stream.slazy (fun _ -> infix_kwds_filter xs))) - | _ -> raise Stream.Failure - - let _ = - Token.Filter.define_filter (Gram.get_filter ()) - (fun f strm -> infix_kwds_filter (f strm)) - - let _ = - Gram.Entry.setup_parser sem_expr - (let symb1 = Gram.parse_tokens_after_filter expr in - let symb (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some ((ANTIQUOT ((("list" as n)), s), ti)) -> - (Stream.junk __strm; - let _loc = Gram.token_location ti - in Ast.ExAnt (_loc, (mk_anti ~c: "expr;" n s))) - | _ -> symb1 __strm in - let rec kont al (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some ((KEYWORD ";", _)) -> - (Stream.junk __strm; - let a = - (try symb __strm - with | Stream.Failure -> raise (Stream.Error "")) in - let s = __strm in - let _loc = - Loc.merge (Ast.loc_of_expr al) (Ast.loc_of_expr a) - in kont (Ast.ExSem (_loc, al, a)) s) - | _ -> al - in - fun (__strm : _ Stream.t) -> - let a = symb __strm in kont a __strm) - - let _ = - let apply () = - let _ = (a_CHAR : 'a_CHAR Gram.Entry.t) - and _ = (override_flag_quot : 'override_flag_quot Gram.Entry.t) - and _ = (row_var_flag_quot : 'row_var_flag_quot Gram.Entry.t) - and _ = (virtual_flag_quot : 'virtual_flag_quot Gram.Entry.t) - and _ = (private_flag_quot : 'private_flag_quot Gram.Entry.t) - and _ = (mutable_flag_quot : 'mutable_flag_quot Gram.Entry.t) - and _ = (direction_flag_quot : 'direction_flag_quot Gram.Entry.t) - and _ = (rec_flag_quot : 'rec_flag_quot Gram.Entry.t) - and _ = (package_type : 'package_type Gram.Entry.t) - and _ = (do_sequence : 'do_sequence Gram.Entry.t) - and _ = (infixop4 : 'infixop4 Gram.Entry.t) - and _ = (infixop3 : 'infixop3 Gram.Entry.t) - and _ = (infixop2 : 'infixop2 Gram.Entry.t) - and _ = (infixop1 : 'infixop1 Gram.Entry.t) - and _ = (infixop0 : 'infixop0 Gram.Entry.t) - and _ = (with_constr_quot : 'with_constr_quot Gram.Entry.t) - and _ = (with_constr : 'with_constr Gram.Entry.t) - and _ = (value_val : 'value_val Gram.Entry.t) - and _ = (value_let : 'value_let Gram.Entry.t) - and _ = (val_longident : 'val_longident Gram.Entry.t) - and _ = (use_file : 'use_file Gram.Entry.t) - and _ = (typevars : 'typevars Gram.Entry.t) - and _ = (type_parameters : 'type_parameters Gram.Entry.t) - and _ = (type_parameter : 'type_parameter Gram.Entry.t) - and _ = - (type_longident_and_parameters : - 'type_longident_and_parameters Gram.Entry.t) - and _ = (type_longident : 'type_longident Gram.Entry.t) - and _ = (type_kind : 'type_kind Gram.Entry.t) - and _ = - (type_ident_and_parameters : - 'type_ident_and_parameters Gram.Entry.t) - and _ = (type_declaration : 'type_declaration Gram.Entry.t) - and _ = (type_constraint : 'type_constraint Gram.Entry.t) - and _ = (top_phrase : 'top_phrase Gram.Entry.t) - and _ = (str_items : 'str_items Gram.Entry.t) - and _ = (str_item_quot : 'str_item_quot Gram.Entry.t) - and _ = (str_item : 'str_item Gram.Entry.t) - and _ = (star_ctyp : 'star_ctyp Gram.Entry.t) - and _ = (sig_items : 'sig_items Gram.Entry.t) - and _ = (sig_item_quot : 'sig_item_quot Gram.Entry.t) - and _ = (sig_item : 'sig_item Gram.Entry.t) - and _ = (sequence : 'sequence Gram.Entry.t) - and _ = (semi : 'semi Gram.Entry.t) - and _ = (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t) - and _ = (sem_patt : 'sem_patt Gram.Entry.t) - and _ = (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t) - and _ = (sem_expr : 'sem_expr Gram.Entry.t) - and _ = (row_field : 'row_field Gram.Entry.t) - and _ = (poly_type : 'poly_type Gram.Entry.t) - and _ = (phrase : 'phrase Gram.Entry.t) - and _ = (patt_tcon : 'patt_tcon Gram.Entry.t) - and _ = (patt_quot : 'patt_quot Gram.Entry.t) - and _ = (patt_eoi : 'patt_eoi Gram.Entry.t) - and _ = (patt_as_patt_opt : 'patt_as_patt_opt Gram.Entry.t) - and _ = (patt : 'patt Gram.Entry.t) - and _ = (opt_when_expr : 'opt_when_expr Gram.Entry.t) - and _ = (opt_virtual : 'opt_virtual Gram.Entry.t) - and _ = (opt_rec : 'opt_rec Gram.Entry.t) - and _ = (opt_private : 'opt_private Gram.Entry.t) - and _ = (opt_polyt : 'opt_polyt Gram.Entry.t) - and _ = (opt_mutable : 'opt_mutable Gram.Entry.t) - and _ = (opt_meth_list : 'opt_meth_list Gram.Entry.t) - and _ = (opt_expr : 'opt_expr Gram.Entry.t) - and _ = (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t) - and _ = (opt_dot_dot : 'opt_dot_dot Gram.Entry.t) - and _ = (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t) - and _ = (opt_class_self_type : 'opt_class_self_type Gram.Entry.t) - and _ = (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t) - and _ = (opt_as_lident : 'opt_as_lident Gram.Entry.t) - and _ = (name_tags : 'name_tags Gram.Entry.t) - and _ = (more_ctyp : 'more_ctyp Gram.Entry.t) - and _ = (module_type_quot : 'module_type_quot Gram.Entry.t) - and _ = (module_type : 'module_type Gram.Entry.t) - and _ = - (module_rec_declaration : 'module_rec_declaration Gram.Entry.t) - and _ = - (module_longident_with_app : - 'module_longident_with_app Gram.Entry.t) - and _ = (module_longident : 'module_longident Gram.Entry.t) - and _ = (module_expr_quot : 'module_expr_quot Gram.Entry.t) - and _ = (module_expr : 'module_expr Gram.Entry.t) - and _ = (module_declaration : 'module_declaration Gram.Entry.t) - and _ = (module_binding_quot : 'module_binding_quot Gram.Entry.t) - and _ = (module_binding0 : 'module_binding0 Gram.Entry.t) - and _ = (module_binding : 'module_binding Gram.Entry.t) - and _ = (meth_decl : 'meth_decl Gram.Entry.t) - and _ = (meth_list : 'meth_list Gram.Entry.t) - and _ = (let_binding : 'let_binding Gram.Entry.t) - and _ = (labeled_ipatt : 'labeled_ipatt Gram.Entry.t) - and _ = (label_patt_list : 'label_patt_list Gram.Entry.t) - and _ = (label_patt : 'label_patt Gram.Entry.t) - and _ = (label_longident : 'label_longident Gram.Entry.t) - and _ = (label_ipatt_list : 'label_ipatt_list Gram.Entry.t) - and _ = (label_ipatt : 'label_ipatt Gram.Entry.t) - and _ = (label_expr_list : 'label_expr_list Gram.Entry.t) - and _ = (label_expr : 'label_expr Gram.Entry.t) - and _ = - (label_declaration_list : 'label_declaration_list Gram.Entry.t) - and _ = (label_declaration : 'label_declaration Gram.Entry.t) - and _ = (label : 'label Gram.Entry.t) - and _ = (ipatt_tcon : 'ipatt_tcon Gram.Entry.t) - and _ = (ipatt : 'ipatt Gram.Entry.t) - and _ = (interf : 'interf Gram.Entry.t) - and _ = (implem : 'implem Gram.Entry.t) - and _ = (ident_quot : 'ident_quot Gram.Entry.t) - and _ = (ident : 'ident Gram.Entry.t) - and _ = (fun_def : 'fun_def Gram.Entry.t) - and _ = (fun_binding : 'fun_binding Gram.Entry.t) - and _ = (field_expr_list : 'field_expr_list Gram.Entry.t) - and _ = (field_expr : 'field_expr Gram.Entry.t) - and _ = (expr_quot : 'expr_quot Gram.Entry.t) - and _ = (expr_eoi : 'expr_eoi Gram.Entry.t) - and _ = (expr : 'expr Gram.Entry.t) - and _ = (eq_expr : 'eq_expr Gram.Entry.t) - and _ = (dummy : 'dummy Gram.Entry.t) - and _ = (direction_flag : 'direction_flag Gram.Entry.t) - and _ = (cvalue_binding : 'cvalue_binding Gram.Entry.t) - and _ = (ctyp_quot : 'ctyp_quot Gram.Entry.t) - and _ = (ctyp : 'ctyp Gram.Entry.t) - and _ = - (constructor_declarations : - 'constructor_declarations Gram.Entry.t) - and _ = - (constructor_declaration : - 'constructor_declaration Gram.Entry.t) - and _ = - (constructor_arg_list : 'constructor_arg_list Gram.Entry.t) - and _ = (constrain : 'constrain Gram.Entry.t) - and _ = - (comma_type_parameter : 'comma_type_parameter Gram.Entry.t) - and _ = (comma_patt : 'comma_patt Gram.Entry.t) - and _ = (comma_ipatt : 'comma_ipatt Gram.Entry.t) - and _ = (comma_expr : 'comma_expr Gram.Entry.t) - and _ = (comma_ctyp : 'comma_ctyp Gram.Entry.t) - and _ = (class_type_quot : 'class_type_quot Gram.Entry.t) - and _ = (class_type_plus : 'class_type_plus Gram.Entry.t) - and _ = - (class_type_longident_and_param : - 'class_type_longident_and_param Gram.Entry.t) - and _ = - (class_type_longident : 'class_type_longident Gram.Entry.t) - and _ = - (class_type_declaration : 'class_type_declaration Gram.Entry.t) - and _ = (class_type : 'class_type Gram.Entry.t) - and _ = (class_structure : 'class_structure Gram.Entry.t) - and _ = (class_str_item_quot : 'class_str_item_quot Gram.Entry.t) - and _ = (class_str_item : 'class_str_item Gram.Entry.t) - and _ = (class_signature : 'class_signature Gram.Entry.t) - and _ = (class_sig_item_quot : 'class_sig_item_quot Gram.Entry.t) - and _ = (class_sig_item : 'class_sig_item Gram.Entry.t) - and _ = - (class_name_and_param : 'class_name_and_param Gram.Entry.t) - and _ = - (class_longident_and_param : - 'class_longident_and_param Gram.Entry.t) - and _ = (class_longident : 'class_longident Gram.Entry.t) - and _ = - (class_info_for_class_type : - 'class_info_for_class_type Gram.Entry.t) - and _ = - (class_info_for_class_expr : - 'class_info_for_class_expr Gram.Entry.t) - and _ = (class_fun_def : 'class_fun_def Gram.Entry.t) - and _ = (class_fun_binding : 'class_fun_binding Gram.Entry.t) - and _ = (class_expr_quot : 'class_expr_quot Gram.Entry.t) - and _ = (class_expr : 'class_expr Gram.Entry.t) - and _ = (class_description : 'class_description Gram.Entry.t) - and _ = (class_declaration : 'class_declaration Gram.Entry.t) - and _ = (binding_quot : 'binding_quot Gram.Entry.t) - and _ = (binding : 'binding Gram.Entry.t) - and _ = (match_case_quot : 'match_case_quot Gram.Entry.t) - and _ = (match_case0 : 'match_case0 Gram.Entry.t) - and _ = (match_case : 'match_case Gram.Entry.t) - and _ = (and_ctyp : 'and_ctyp Gram.Entry.t) - and _ = (amp_ctyp : 'amp_ctyp Gram.Entry.t) - and _ = (a_ident : 'a_ident Gram.Entry.t) - and _ = (a_UIDENT : 'a_UIDENT Gram.Entry.t) - and _ = (a_STRING : 'a_STRING Gram.Entry.t) - and _ = (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t) - and _ = (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t) - and _ = (rec_binding_quot : 'rec_binding_quot Gram.Entry.t) - and _ = (a_LIDENT : 'a_LIDENT Gram.Entry.t) - and _ = (a_LABEL : 'a_LABEL Gram.Entry.t) - and _ = (a_INT64 : 'a_INT64 Gram.Entry.t) - and _ = (a_INT32 : 'a_INT32 Gram.Entry.t) - and _ = (a_INT : 'a_INT Gram.Entry.t) - and _ = (a_FLOAT : 'a_FLOAT Gram.Entry.t) in - let grammar_entry_create = Gram.Entry.mk in - let (* Here it's LABEL and not tilde_label since ~a:b is different than ~a : b *) - (* Same remark for ?a:b *) infixop5 : 'infixop5 Gram.Entry.t = - grammar_entry_create "infixop5" - and (* | i = opt_label; "("; p = patt_tcon; ")" -> *) - (* <:patt< ? $i$ : ($p$) >> *) - (* | i = opt_label; "("; p = ipatt_tcon; ")" -> - <:patt< ? $i$ : ($p$) >> - | i = opt_label; "("; p = ipatt_tcon; "="; e = expr; ")" -> - <:patt< ? $i$ : ($p$ = $e$) >> *) - string_list : 'string_list Gram.Entry.t = - grammar_entry_create "string_list" - and opt_override : 'opt_override Gram.Entry.t = - grammar_entry_create "opt_override" - and unquoted_typevars : 'unquoted_typevars Gram.Entry.t = - grammar_entry_create "unquoted_typevars" - and value_val_opt_override : - 'value_val_opt_override Gram.Entry.t = - grammar_entry_create "value_val_opt_override" - and method_opt_override : 'method_opt_override Gram.Entry.t = - grammar_entry_create "method_opt_override" - and module_longident_dot_lparen : - 'module_longident_dot_lparen Gram.Entry.t = - grammar_entry_create "module_longident_dot_lparen" - and optional_type_parameter : - 'optional_type_parameter Gram.Entry.t = - grammar_entry_create "optional_type_parameter" - and fun_def_cont_no_when : 'fun_def_cont_no_when Gram.Entry.t = - grammar_entry_create "fun_def_cont_no_when" - and fun_def_cont : 'fun_def_cont Gram.Entry.t = - grammar_entry_create "fun_def_cont" - and sequence' : 'sequence' Gram.Entry.t = - grammar_entry_create "sequence'" - and infixop6 : 'infixop6 Gram.Entry.t = - grammar_entry_create "infixop6" - in - (Gram.extend (module_expr : 'module_expr Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), None, - [ ([ Gram.Skeyword "struct"; - Gram.Snterm - (Gram.Entry.obj - (str_items : 'str_items Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (st : 'str_items) _ (_loc : Gram.Loc.t) - -> (Ast.MeStr (_loc, st) : 'module_expr)))); - ([ Gram.Skeyword "functor"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword ")"; Gram.Skeyword "->"; Gram. - Sself ], - (Gram.Action.mk - (fun (me : 'module_expr) _ _ - (t : 'module_type) _ (i : 'a_UIDENT) _ _ - (_loc : Gram.Loc.t) -> - (Ast.MeFun (_loc, i, t, me) : 'module_expr)))) ]); - ((Some "apply"), None, - [ ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (me2 : 'module_expr) (me1 : 'module_expr) - (_loc : Gram.Loc.t) -> - (Ast.MeApp (_loc, me1, me2) : 'module_expr)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (package_type : - 'package_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'package_type) _ (e : 'expr) _ _ - (_loc : Gram.Loc.t) -> - (Ast.MePkg (_loc, - (Ast.ExTyc (_loc, e, - (Ast.TyPkg (_loc, p))))) : - 'module_expr)))); - ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e : 'expr) _ _ (_loc : Gram.Loc.t) -> - (Ast.MePkg (_loc, e) : 'module_expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (me : 'module_expr) _ - (_loc : Gram.Loc.t) -> (me : 'module_expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (mt : 'module_type) _ - (me : 'module_expr) _ (_loc : Gram.Loc.t) - -> - (Ast.MeTyc (_loc, me, mt) : 'module_expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'module_longident) - (_loc : Gram.Loc.t) -> - (Ast.MeId (_loc, i) : 'module_expr)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.module_expr_tag : - 'module_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "mexp" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"mexp\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "mexp" | "anti" | "list" as n)), - s) -> - (Ast.MeAnt (_loc, - (mk_anti ~c: "module_expr" n s)) : - 'module_expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (str_item : 'str_item Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), None, - [ ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (Ast.StExp (_loc, e) : 'str_item)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.str_item_tag : - 'str_item) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "stri" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "stri" | "anti" | "list" as n)), - s) -> - (Ast.StAnt (_loc, - (mk_anti ~c: "str_item" n s)) : - 'str_item) - | _ -> assert false))); - ([ Gram.Skeyword "class"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (class_type_declaration : - 'class_type_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ctd : 'class_type_declaration) _ _ - (_loc : Gram.Loc.t) -> - (Ast.StClt (_loc, ctd) : 'str_item)))); - ([ Gram.Skeyword "class"; - Gram.Snterm - (Gram.Entry.obj - (class_declaration : - 'class_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (cd : 'class_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.StCls (_loc, cd) : 'str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_let : 'value_let Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (bi : 'binding) (r : 'opt_rec) _ - (_loc : Gram.Loc.t) -> - (Ast.StVal (_loc, r, bi) : 'str_item)))); - ([ Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (type_declaration : - 'type_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (td : 'type_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.StTyp (_loc, td) : 'str_item)))); - ([ Gram.Skeyword "open"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'module_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.StOpn (_loc, i) : 'str_item)))); - ([ Gram.Skeyword "module"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (i : 'a_ident) _ _ - (_loc : Gram.Loc.t) -> - (Ast.StMty (_loc, i, mt) : 'str_item)))); - ([ Gram.Skeyword "module"; Gram.Skeyword "rec"; - Gram.Snterm - (Gram.Entry.obj - (module_binding : - 'module_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mb : 'module_binding) _ _ - (_loc : Gram.Loc.t) -> - (Ast.StRecMod (_loc, mb) : 'str_item)))); - ([ Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (module_binding0 : - 'module_binding0 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mb : 'module_binding0) (i : 'a_UIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.StMod (_loc, i, mb) : 'str_item)))); - ([ Gram.Skeyword "include"; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (_loc : Gram.Loc.t) - -> (Ast.StInc (_loc, me) : 'str_item)))); - ([ Gram.Skeyword "external"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (string_list : 'string_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (sl : 'string_list) _ (t : 'ctyp) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.StExt (_loc, i, t, sl) : 'str_item)))); - ([ Gram.Skeyword "exception"; - Gram.Snterm - (Gram.Entry.obj - (constructor_declaration : - 'constructor_declaration Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (type_longident : - 'type_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'type_longident) _ - (t : 'constructor_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.StExc (_loc, t, (Ast.OSome i)) : - 'str_item)))); - ([ Gram.Skeyword "exception"; - Gram.Snterm - (Gram.Entry.obj - (constructor_declaration : - 'constructor_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'constructor_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.StExc (_loc, t, Ast.ONone) : - 'str_item)))) ]) ])) - ()); - Gram.extend (module_binding0 : 'module_binding0 Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (_loc : Gram.Loc.t) - -> (me : 'module_binding0)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (mt : 'module_type) - _ (_loc : Gram.Loc.t) -> - (Ast.MeTyc (_loc, me, mt) : - 'module_binding0)))); - ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword ")"; Gram.Sself ], - (Gram.Action.mk - (fun (mb : 'module_binding0) _ - (mt : 'module_type) _ (m : 'a_UIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.MeFun (_loc, m, mt, mb) : - 'module_binding0)))) ]) ])) - ()); - Gram.extend (module_binding : 'module_binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (mt : 'module_type) - _ (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.MbColEq (_loc, m, mt, me) : - 'module_binding)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.module_binding_tag : - 'module_binding) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (mt : 'module_type) - _ (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), m) -> - (Ast.MbColEq (_loc, (mk_anti n m), mt, - me) : - 'module_binding) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), s) -> - (Ast.MbAnt (_loc, - (mk_anti ~c: "module_binding" n s)) : - 'module_binding) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("module_binding" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"module_binding\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("module_binding" | "anti" | "list" - as n)), - s) -> - (Ast.MbAnt (_loc, - (mk_anti ~c: "module_binding" n s)) : - 'module_binding) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (b2 : 'module_binding) _ - (b1 : 'module_binding) (_loc : Gram.Loc.t) - -> - (Ast.MbAnd (_loc, b1, b2) : - 'module_binding)))) ]) ])) - ()); - Gram.extend (module_type : 'module_type Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), None, - [ ([ Gram.Skeyword "functor"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Sself; - Gram.Skeyword ")"; Gram.Skeyword "->"; Gram. - Sself ], - (Gram.Action.mk - (fun (mt : 'module_type) _ _ - (t : 'module_type) _ (i : 'a_UIDENT) _ _ - (_loc : Gram.Loc.t) -> - (Ast.MtFun (_loc, i, t, mt) : 'module_type)))) ]); - ((Some "with"), None, - [ ([ Gram.Sself; Gram.Skeyword "with"; - Gram.Snterm - (Gram.Entry.obj - (with_constr : 'with_constr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (wc : 'with_constr) _ (mt : 'module_type) - (_loc : Gram.Loc.t) -> - (Ast.MtWit (_loc, mt, wc) : 'module_type)))) ]); - ((Some "apply"), None, - [ ([ Gram.Sself; Gram.Sself; - Gram.Snterm - (Gram.Entry.obj (dummy : 'dummy Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (mt2 : 'module_type) - (mt1 : 'module_type) (_loc : Gram.Loc.t) -> - (module_type_app mt1 mt2 : 'module_type)))) ]); - ((Some "."), None, - [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (mt2 : 'module_type) _ - (mt1 : 'module_type) (_loc : Gram.Loc.t) -> - (module_type_acc mt1 mt2 : 'module_type)))) ]); - ((Some "sig"), None, - [ ([ Gram.Skeyword "sig"; - Gram.Snterm - (Gram.Entry.obj - (sig_items : 'sig_items Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (sg : 'sig_items) _ (_loc : Gram.Loc.t) - -> (Ast.MtSig (_loc, sg) : 'module_type)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "module"; Gram.Skeyword "type"; - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ _ _ - (_loc : Gram.Loc.t) -> - (Ast.MtOf (_loc, me) : 'module_type)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (mt : 'module_type) _ - (_loc : Gram.Loc.t) -> (mt : 'module_type)))); - ([ Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.MtQuo (_loc, i) : 'module_type)))); - ([ Gram.Snterm - (Gram.Entry.obj - (module_longident_with_app : - 'module_longident_with_app Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'module_longident_with_app) - (_loc : Gram.Loc.t) -> - (Ast.MtId (_loc, i) : 'module_type)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.module_type_tag : - 'module_type) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "mtyp" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"mtyp\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "mtyp" | "anti" | "list" as n)), - s) -> - (Ast.MtAnt (_loc, - (mk_anti ~c: "module_type" n s)) : - 'module_type) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (sig_item : 'sig_item Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), None, - [ ([ Gram.Skeyword "class"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (class_type_declaration : - 'class_type_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ctd : 'class_type_declaration) _ _ - (_loc : Gram.Loc.t) -> - (Ast.SgClt (_loc, ctd) : 'sig_item)))); - ([ Gram.Skeyword "class"; - Gram.Snterm - (Gram.Entry.obj - (class_description : - 'class_description Gram.Entry.t)) ], - (Gram.Action.mk - (fun (cd : 'class_description) _ - (_loc : Gram.Loc.t) -> - (Ast.SgCls (_loc, cd) : 'sig_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.SgVal (_loc, i, t) : 'sig_item)))); - ([ Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (type_declaration : - 'type_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'type_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.SgTyp (_loc, t) : 'sig_item)))); - ([ Gram.Skeyword "open"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'module_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.SgOpn (_loc, i) : 'sig_item)))); - ([ Gram.Skeyword "module"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> - (Ast.SgMty (_loc, i, (Ast.MtNil _loc)) : - 'sig_item)))); - ([ Gram.Skeyword "module"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (i : 'a_ident) _ _ - (_loc : Gram.Loc.t) -> - (Ast.SgMty (_loc, i, mt) : 'sig_item)))); - ([ Gram.Skeyword "module"; Gram.Skeyword "rec"; - Gram.Snterm - (Gram.Entry.obj - (module_rec_declaration : - 'module_rec_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mb : 'module_rec_declaration) _ _ - (_loc : Gram.Loc.t) -> - (Ast.SgRecMod (_loc, mb) : 'sig_item)))); - ([ Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (module_declaration : - 'module_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_declaration) - (i : 'a_UIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.SgMod (_loc, i, mt) : 'sig_item)))); - ([ Gram.Skeyword "include"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (_loc : Gram.Loc.t) - -> (Ast.SgInc (_loc, mt) : 'sig_item)))); - ([ Gram.Skeyword "external"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (string_list : 'string_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (sl : 'string_list) _ (t : 'ctyp) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.SgExt (_loc, i, t, sl) : 'sig_item)))); - ([ Gram.Skeyword "exception"; - Gram.Snterm - (Gram.Entry.obj - (constructor_declaration : - 'constructor_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'constructor_declaration) _ - (_loc : Gram.Loc.t) -> - (Ast.SgExc (_loc, t) : 'sig_item)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.sig_item_tag : - 'sig_item) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "sigi" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "sigi" | "anti" | "list" as n)), - s) -> - (Ast.SgAnt (_loc, - (mk_anti ~c: "sig_item" n s)) : - 'sig_item) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (module_declaration : 'module_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword ")"; Gram.Sself ], - (Gram.Action.mk - (fun (mt : 'module_declaration) _ - (t : 'module_type) _ (i : 'a_UIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.MtFun (_loc, i, t, mt) : - 'module_declaration)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (_loc : Gram.Loc.t) - -> (mt : 'module_declaration)))) ]) ])) - ()); - Gram.extend - (module_rec_declaration : - 'module_rec_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (m : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (Ast.MbCol (_loc, m, mt) : - 'module_rec_declaration)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.module_binding_tag : - 'module_rec_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "module_binding" | "anti" | - "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"module_binding\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "module_binding" | "anti" | - "list" - as n)), - s) -> - (Ast.MbAnt (_loc, - (mk_anti ~c: "module_binding" n s)) : - 'module_rec_declaration) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (m2 : 'module_rec_declaration) _ - (m1 : 'module_rec_declaration) - (_loc : Gram.Loc.t) -> - (Ast.MbAnd (_loc, m1, m2) : - 'module_rec_declaration)))) ]) ])) - ()); - Gram.extend (with_constr : 'with_constr Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)); - Gram.Skeyword ":="; - Gram.Snterm - (Gram.Entry.obj - (module_longident_with_app : - 'module_longident_with_app Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i2 : 'module_longident_with_app) _ - (i1 : 'module_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.WcMoS (_loc, i1, i2) : 'with_constr)))); - ([ Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (type_longident_and_parameters : - 'type_longident_and_parameters Gram. - Entry.t)); - Gram.Skeyword ":="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ - (t1 : 'type_longident_and_parameters) _ - (_loc : Gram.Loc.t) -> - (Ast.WcTyS (_loc, t1, t2) : 'with_constr)))); - ([ Gram.Skeyword "type"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")); - Gram.Skeyword ":="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (__camlp4_0 : Gram.Token.t) - _ (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), - s) -> - (Ast.WcTyS (_loc, - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s))), - t) : - 'with_constr) - | _ -> assert false))); - ([ Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_longident_with_app : - 'module_longident_with_app Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i2 : 'module_longident_with_app) _ - (i1 : 'module_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.WcMod (_loc, i1, i2) : 'with_constr)))); - ([ Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (type_longident_and_parameters : - 'type_longident_and_parameters Gram. - Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ - (t1 : 'type_longident_and_parameters) _ - (_loc : Gram.Loc.t) -> - (Ast.WcTyp (_loc, t1, t2) : 'with_constr)))); - ([ Gram.Skeyword "type"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (__camlp4_0 : Gram.Token.t) - _ (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), - s) -> - (Ast.WcTyp (_loc, - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s))), - t) : - 'with_constr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.with_constr_tag : - 'with_constr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "with_constr" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"with_constr\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "with_constr" | "anti" | "list" - as n)), - s) -> - (Ast.WcAnt (_loc, - (mk_anti ~c: "with_constr" n s)) : - 'with_constr) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (wc2 : 'with_constr) _ - (wc1 : 'with_constr) (_loc : Gram.Loc.t) -> - (Ast.WcAnd (_loc, wc1, wc2) : 'with_constr)))) ]) ])) - ()); - Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Skeyword "object"; - Gram.Snterm - (Gram.Entry.obj - (opt_class_self_patt : - 'opt_class_self_patt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_structure : - 'class_structure Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (cst : 'class_structure) - (csp : 'opt_class_self_patt) _ - (_loc : Gram.Loc.t) -> - (Ast.ExObj (_loc, csp, cst) : 'expr)))); - ([ Gram.Skeyword "while"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword "do"; - Gram.Snterm - (Gram.Entry.obj - (do_sequence : 'do_sequence Gram.Entry.t)) ], - (Gram.Action.mk - (fun (seq : 'do_sequence) _ (e : 'sequence) _ - (_loc : Gram.Loc.t) -> - (Ast.ExWhi (_loc, (mksequence' _loc e), - seq) : - 'expr)))); - ([ Gram.Skeyword "for"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (direction_flag : - 'direction_flag Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword "do"; - Gram.Snterm - (Gram.Entry.obj - (do_sequence : 'do_sequence Gram.Entry.t)) ], - (Gram.Action.mk - (fun (seq : 'do_sequence) _ (e2 : 'sequence) - (df : 'direction_flag) (e1 : 'sequence) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.ExFor (_loc, i, (mksequence' _loc e1), - (mksequence' _loc e2), df, seq) : - 'expr)))); - ([ Gram.Skeyword "do"; - Gram.Snterm - (Gram.Entry.obj - (do_sequence : 'do_sequence Gram.Entry.t)) ], - (Gram.Action.mk - (fun (seq : 'do_sequence) _ - (_loc : Gram.Loc.t) -> - (mksequence _loc seq : 'expr)))); - ([ Gram.Skeyword "if"; Gram.Sself; - Gram.Skeyword "then"; Gram.Sself; - Gram.Skeyword "else"; Gram.Sself ], - (Gram.Action.mk - (fun (e3 : 'expr) _ (e2 : 'expr) _ - (e1 : 'expr) _ (_loc : Gram.Loc.t) -> - (Ast.ExIfe (_loc, e1, e2, e3) : 'expr)))); - ([ Gram.Skeyword "try"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword "with"; - Gram.Snterm - (Gram.Entry.obj - (match_case : 'match_case Gram.Entry.t)) ], - (Gram.Action.mk - (fun (a : 'match_case) _ (e : 'sequence) _ - (_loc : Gram.Loc.t) -> - (Ast.ExTry (_loc, (mksequence' _loc e), a) : - 'expr)))); - ([ Gram.Skeyword "match"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword "with"; - Gram.Snterm - (Gram.Entry.obj - (match_case : 'match_case Gram.Entry.t)) ], - (Gram.Action.mk - (fun (a : 'match_case) _ (e : 'sequence) _ - (_loc : Gram.Loc.t) -> - (Ast.ExMat (_loc, (mksequence' _loc e), a) : - 'expr)))); - ([ Gram.Skeyword "fun"; - Gram.Snterm - (Gram.Entry.obj - (fun_def : 'fun_def Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_def) _ (_loc : Gram.Loc.t) -> - (e : 'expr)))); - ([ Gram.Skeyword "fun"; Gram.Skeyword "["; - Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (match_case0 : - 'match_case0 Gram.Entry.t))), - (Gram.Skeyword "|")); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (a : 'match_case0 list) _ _ - (_loc : Gram.Loc.t) -> - (Ast.ExFun (_loc, (Ast.mcOr_of_list a)) : - 'expr)))); - ([ Gram.Skeyword "let"; Gram.Skeyword "open"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)); - Gram.Skeyword "in"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (i : 'module_longident) _ _ - (_loc : Gram.Loc.t) -> - (Ast.ExOpI (_loc, i, e) : 'expr)))); - ([ Gram.Skeyword "let"; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (module_binding0 : - 'module_binding0 Gram.Entry.t)); - Gram.Skeyword "in"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (mb : 'module_binding0) - (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) -> - (Ast.ExLmd (_loc, m, mb, e) : 'expr)))); - ([ Gram.Skeyword "let"; - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)); - Gram.Skeyword "in"; Gram.Sself ], - (Gram.Action.mk - (fun (x : 'expr) _ (bi : 'binding) - (r : 'opt_rec) _ (_loc : Gram.Loc.t) -> - (Ast.ExLet (_loc, r, bi, x) : 'expr)))) ]); - ((Some "where"), None, - [ ([ Gram.Sself; Gram.Skeyword "where"; - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (let_binding : 'let_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (lb : 'let_binding) (rf : 'opt_rec) _ - (e : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExLet (_loc, rf, lb, e) : 'expr)))) ]); - ((Some ":="), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Sself; Gram.Skeyword ":="; Gram.Sself; - Gram.Snterm - (Gram.Entry.obj (dummy : 'dummy Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (match bigarray_set _loc e1 e2 with - | Some e -> e - | None -> Ast.ExAss (_loc, e1, e2) : - 'expr)))) ]); - ((Some "||"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop6 : 'infixop6 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop6) - (e1 : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, op, e1)), e2) : - 'expr)))) ]); - ((Some "&&"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop5 : 'infixop5 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop5) - (e1 : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, op, e1)), e2) : - 'expr)))) ]); - ((Some "<"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop0 : 'infixop0 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop0) - (e1 : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, op, e1)), e2) : - 'expr)))) ]); - ((Some "^"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop1 : 'infixop1 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop1) - (e1 : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, op, e1)), e2) : - 'expr)))) ]); - ((Some "+"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop2 : 'infixop2 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop2) - (e1 : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, op, e1)), e2) : - 'expr)))) ]); - ((Some "*"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop3 : 'infixop3 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop3) - (e1 : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, op, e1)), e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "mod"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "mod")))), - e1)), - e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "lxor"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "lxor")))), - e1)), - e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "lor"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "lor")))), - e1)), - e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "land"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "land")))), - e1)), - e2) : - 'expr)))) ]); - ((Some "**"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (infixop4 : 'infixop4 Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (op : 'infixop4) - (e1 : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, op, e1)), e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "lsr"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "lsr")))), - e1)), - e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "lsl"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "lsl")))), - e1)), - e2) : - 'expr)))); - ([ Gram.Sself; Gram.Skeyword "asr"; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "asr")))), - e1)), - e2) : - 'expr)))) ]); - ((Some "unary minus"), - (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Skeyword "-."; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (mkumin _loc "-." e : 'expr)))); - ([ Gram.Skeyword "-"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (mkumin _loc "-" e : 'expr)))) ]); - ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "lazy"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (Ast.ExLaz (_loc, e) : 'expr)))); - ([ Gram.Skeyword "new"; - Gram.Snterm - (Gram.Entry.obj - (class_longident : - 'class_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'class_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.ExNew (_loc, i) : 'expr)))); - ([ Gram.Skeyword "assert"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (mkassert _loc e : 'expr)))); - ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, e1, e2) : 'expr)))) ]); - ((Some "label"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Skeyword "?"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.ExOlb (_loc, i, (Ast.ExNil _loc)) : - 'expr)))); - ([ Gram.Skeyword "?"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.ExOlb (_loc, i, e) : 'expr)))); - ([ Gram.Stoken - (((function | OPTLABEL _ -> true | _ -> false), - "OPTLABEL _")); - Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | OPTLABEL i -> - (Ast.ExOlb (_loc, i, e) : 'expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function | LABEL _ -> true | _ -> false), - "LABEL _")); - Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LABEL i -> - (Ast.ExLab (_loc, i, e) : 'expr) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.ExLab (_loc, i, (Ast.ExNil _loc)) : - 'expr)))); - ([ Gram.Skeyword "~"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.ExLab (_loc, i, e) : 'expr)))) ]); - ((Some "."), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)) ], - (Gram.Action.mk - (fun (lab : 'label) _ (e : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExSnd (_loc, e, lab) : 'expr)))); - ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExAcc (_loc, e1, e2) : 'expr)))); - ([ Gram.Sself; Gram.Skeyword "."; - Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (comma_expr : 'comma_expr Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (e2 : 'comma_expr) _ _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (bigarray_get _loc e1 e2 : 'expr)))); - ([ Gram.Sself; Gram.Skeyword "."; - Gram.Skeyword "["; Gram.Sself; - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExSte (_loc, e1, e2) : 'expr)))); - ([ Gram.Sself; Gram.Skeyword "."; - Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExAre (_loc, e1, e2) : 'expr)))) ]); - ((Some "~-"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (prefixop : 'prefixop Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) (f : 'prefixop) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, f, e) : 'expr)))); - ([ Gram.Skeyword "!"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (Ast.ExAcc (_loc, e, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "val"))))) : - 'expr)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (package_type : - 'package_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (pt : 'package_type) _ - (me : 'module_expr) _ _ (_loc : Gram.Loc.t) - -> - (Ast.ExPkg (_loc, - (Ast.MeTyc (_loc, me, pt))) : - 'expr)))); - ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (me : 'module_expr) _ _ - (_loc : Gram.Loc.t) -> - (Ast.ExPkg (_loc, me) : 'expr)))); - ([ Gram.Skeyword "begin"; Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : - 'expr)))); - ([ Gram.Skeyword "begin"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (seq : 'sequence) _ (_loc : Gram.Loc.t) - -> (mksequence _loc seq : 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e : 'expr) _ (_loc : Gram.Loc.t) -> - (e : 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ":>"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (e : 'expr) _ - (_loc : Gram.Loc.t) -> - (Ast.ExCoe (_loc, e, (Ast.TyNil _loc), t) : - 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ":>"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ - (e : 'expr) _ (_loc : Gram.Loc.t) -> - (Ast.ExCoe (_loc, e, t, t2) : 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ";"; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ _ (e : 'expr) _ (_loc : Gram.Loc.t) -> - (mksequence _loc e : 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (seq : 'sequence) _ (e : 'expr) _ - (_loc : Gram.Loc.t) -> - (mksequence _loc (Ast.ExSem (_loc, e, seq)) : - 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_expr : 'comma_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (el : 'comma_expr) _ (e : 'expr) _ - (_loc : Gram.Loc.t) -> - (Ast.ExTup (_loc, - (Ast.ExCom (_loc, e, el))) : - 'expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (e : 'expr) _ - (_loc : Gram.Loc.t) -> - (Ast.ExTyc (_loc, e, t) : 'expr)))); - ([ Gram.Skeyword "("; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : - 'expr)))); - ([ Gram.Skeyword "{<"; - Gram.Snterm - (Gram.Entry.obj - (field_expr_list : - 'field_expr_list Gram.Entry.t)); - Gram.Skeyword ">}" ], - (Gram.Action.mk - (fun _ (fel : 'field_expr_list) _ - (_loc : Gram.Loc.t) -> - (Ast.ExOvr (_loc, fel) : 'expr)))); - ([ Gram.Skeyword "{<"; Gram.Skeyword ">}" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.ExOvr (_loc, (Ast.RbNil _loc)) : - 'expr)))); - ([ Gram.Skeyword "{"; Gram.Skeyword "("; Gram. - Sself; Gram.Skeyword ")"; Gram.Skeyword "with"; - Gram.Snterm - (Gram.Entry.obj - (label_expr_list : - 'label_expr_list Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (el : 'label_expr_list) _ _ (e : 'expr) - _ _ (_loc : Gram.Loc.t) -> - (Ast.ExRec (_loc, el, e) : 'expr)))); - ([ Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (label_expr_list : - 'label_expr_list Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (el : 'label_expr_list) _ - (_loc : Gram.Loc.t) -> - (Ast.ExRec (_loc, el, (Ast.ExNil _loc)) : - 'expr)))); - ([ Gram.Skeyword "[|"; - Gram.Snterm - (Gram.Entry.obj - (sem_expr : 'sem_expr Gram.Entry.t)); - Gram.Skeyword "|]" ], - (Gram.Action.mk - (fun _ (el : 'sem_expr) _ (_loc : Gram.Loc.t) - -> (Ast.ExArr (_loc, el) : 'expr)))); - ([ Gram.Skeyword "[|"; Gram.Skeyword "|]" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.ExArr (_loc, (Ast.ExNil _loc)) : - 'expr)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (sem_expr_for_list : - 'sem_expr_for_list Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (mk_list : 'sem_expr_for_list) _ - (_loc : Gram.Loc.t) -> - (mk_list - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "[]")))) : - 'expr)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (sem_expr_for_list : - 'sem_expr_for_list Gram.Entry.t)); - Gram.Skeyword "::"; Gram.Sself; - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (last : 'expr) _ - (mk_list : 'sem_expr_for_list) _ - (_loc : Gram.Loc.t) -> - (mk_list last : 'expr)))); - ([ Gram.Skeyword "["; Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))) : - 'expr)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.ExVrn (_loc, s) : 'expr)))); - ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (val_longident : - 'val_longident Gram.Entry.t))) ], - (Gram.Action.mk - (fun (i : 'val_longident) (_loc : Gram.Loc.t) - -> (Ast.ExId (_loc, i) : 'expr)))); - ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (module_longident_dot_lparen : - 'module_longident_dot_lparen Gram. - Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e : 'sequence) - (i : 'module_longident_dot_lparen) - (_loc : Gram.Loc.t) -> - (Ast.ExOpI (_loc, i, e) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_CHAR : 'a_CHAR Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_CHAR) (_loc : Gram.Loc.t) -> - (Ast.ExChr (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_STRING : 'a_STRING Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_STRING) (_loc : Gram.Loc.t) -> - (Ast.ExStr (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_FLOAT) (_loc : Gram.Loc.t) -> - (Ast.ExFlo (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_NATIVEINT) (_loc : Gram.Loc.t) -> - (Ast.ExNativeInt (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_INT64 : 'a_INT64 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT64) (_loc : Gram.Loc.t) -> - (Ast.ExInt64 (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_INT32 : 'a_INT32 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT32) (_loc : Gram.Loc.t) -> - (Ast.ExInt32 (_loc, s) : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT) (_loc : Gram.Loc.t) -> - (Ast.ExInt (_loc, s) : 'expr)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("seq", _) -> true - | _ -> false), - "ANTIQUOT (\"seq\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("seq" as n)), s) -> - (Ast.ExSeq (_loc, - (Ast.ExAnt (_loc, - (mk_anti ~c: "expr" n s)))) : - 'expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("tup", _) -> true - | _ -> false), - "ANTIQUOT (\"tup\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("tup" as n)), s) -> - (Ast.ExTup (_loc, - (Ast.ExAnt (_loc, - (mk_anti ~c: "expr" n s)))) : - 'expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("`bool", _) -> true - | _ -> false), - "ANTIQUOT (\"`bool\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("`bool" as n)), s) -> - (Ast.ExId (_loc, - (Ast.IdAnt (_loc, (mk_anti n s)))) : - 'expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("exp" | "" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"exp\" | \"\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("exp" | "" | "anti" as n)), - s) -> - (Ast.ExAnt (_loc, - (mk_anti ~c: "expr" n s)) : - 'expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.expr_tag : - 'expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (do_sequence : 'do_sequence Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "done" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : - 'do_sequence)))); - ([ Gram.Stry - (Gram.srules do_sequence - [ ([ Gram.Snterm - (Gram.Entry.obj - (sequence : - 'sequence Gram.Entry.t)); - Gram.Skeyword "done" ], - (Gram.Action.mk - (fun _ (seq : 'sequence) - (_loc : Gram.Loc.t) -> - (seq : 'e__3)))) ]) ], - (Gram.Action.mk - (fun (seq : 'e__3) (_loc : Gram.Loc.t) -> - (seq : 'do_sequence)))); - ([ Gram.Stry - (Gram.srules do_sequence - [ ([ Gram.Skeyword "{"; Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (() : 'e__2)))) ]) ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : - 'do_sequence)))); - ([ Gram.Stry - (Gram.srules do_sequence - [ ([ Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (sequence : - 'sequence Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (seq : 'sequence) _ - (_loc : Gram.Loc.t) -> - (seq : 'e__1)))) ]) ], - (Gram.Action.mk - (fun (seq : 'e__1) (_loc : Gram.Loc.t) -> - (seq : 'do_sequence)))) ]) ])) - ()); - Gram.extend (infixop5 : 'infixop5 Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.srules infixop5 - [ ([ Gram.Skeyword "&&" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : - 'e__4)))); - ([ Gram.Skeyword "&" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : - 'e__4)))) ] ], - (Gram.Action.mk - (fun (x : 'e__4) (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdLid (_loc, x))) : - 'infixop5)))) ]) ])) - ()); - Gram.extend (infixop6 : 'infixop6 Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.srules infixop6 - [ ([ Gram.Skeyword "||" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : - 'e__5)))); - ([ Gram.Skeyword "or" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : - 'e__5)))) ] ], - (Gram.Action.mk - (fun (x : 'e__5) (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdLid (_loc, x))) : - 'infixop6)))) ]) ])) - ()); - Gram.extend - (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - acc) : - 'sem_expr_for_list)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (e : 'expr) (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - acc) : - 'sem_expr_for_list)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (el : 'sem_expr_for_list) _ (e : 'expr) - (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - (el acc)) : - 'sem_expr_for_list)))) ]) ])) - ()); - Gram.extend (comma_expr : 'comma_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top") ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (e : 'comma_expr)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.ExAnt (_loc, - (mk_anti ~c: "expr," n s)) : - 'comma_expr) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], - (Gram.Action.mk - (fun (e2 : 'comma_expr) _ (e1 : 'comma_expr) - (_loc : Gram.Loc.t) -> - (Ast.ExCom (_loc, e1, e2) : 'comma_expr)))) ]) ])) - ()); - Gram.extend (dummy : 'dummy Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> (() : 'dummy)))) ]) ])) - ()); - Gram.extend (sequence' : 'sequence' Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)) ], - (Gram.Action.mk - (fun (el : 'sequence) _ (_loc : Gram.Loc.t) -> - (fun e -> Ast.ExSem (_loc, e, el) : - 'sequence')))); - ([ Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (fun e -> e : 'sequence')))); - ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (fun e -> e : 'sequence')))) ]) ])) - ()); - Gram.extend (sequence : 'sequence Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (sequence' : 'sequence' Gram.Entry.t)) ], - (Gram.Action.mk - (fun (k : 'sequence') (e : 'expr) - (_loc : Gram.Loc.t) -> (k e : 'sequence)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.ExAnt (_loc, - (mk_anti ~c: "expr;" n s)) : - 'sequence) - | _ -> assert false))); - ([ Gram.Skeyword "let"; Gram.Skeyword "open"; - Gram.Snterm - (Gram.Entry.obj - (module_longident : - 'module_longident Gram.Entry.t)); - Gram.Skeyword "in"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'sequence) _ (i : 'module_longident) - _ _ (_loc : Gram.Loc.t) -> - (Ast.ExOpI (_loc, i, e) : 'sequence)))); - ([ Gram.Skeyword "let"; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (module_binding0 : - 'module_binding0 Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (el : 'sequence) _ - (mb : 'module_binding0) (m : 'a_UIDENT) _ _ - (_loc : Gram.Loc.t) -> - (Ast.ExLmd (_loc, m, mb, - (mksequence _loc el)) : - 'sequence)))); - ([ Gram.Skeyword "let"; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (module_binding0 : - 'module_binding0 Gram.Entry.t)); - Gram.Skeyword "in"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (sequence' : 'sequence' Gram.Entry.t)) ], - (Gram.Action.mk - (fun (k : 'sequence') (e : 'expr) _ - (mb : 'module_binding0) (m : 'a_UIDENT) _ _ - (_loc : Gram.Loc.t) -> - (k (Ast.ExLmd (_loc, m, mb, e)) : - 'sequence)))); - ([ Gram.Skeyword "let"; - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (el : 'sequence) _ (bi : 'binding) - (rf : 'opt_rec) _ (_loc : Gram.Loc.t) -> - (Ast.ExLet (_loc, rf, bi, - (mksequence _loc el)) : - 'sequence)))); - ([ Gram.Skeyword "let"; - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)); - Gram.Skeyword "in"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (sequence' : 'sequence' Gram.Entry.t)) ], - (Gram.Action.mk - (fun (k : 'sequence') (e : 'expr) _ - (bi : 'binding) (rf : 'opt_rec) _ - (_loc : Gram.Loc.t) -> - (k (Ast.ExLet (_loc, rf, bi, e)) : - 'sequence)))) ]) ])) - ()); - Gram.extend (binding : 'binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (let_binding : 'let_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (b : 'let_binding) (_loc : Gram.Loc.t) -> - (b : 'binding)))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (b2 : 'binding) _ (b1 : 'binding) - (_loc : Gram.Loc.t) -> - (Ast.BiAnd (_loc, b1, b2) : 'binding)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.BiAnt (_loc, - (mk_anti ~c: "binding" n s)) : - 'binding) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.BiEq (_loc, - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s))), - e) : - 'binding) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("binding" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"binding\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("binding" | "list" as n)), s) - -> - (Ast.BiAnt (_loc, - (mk_anti ~c: "binding" n s)) : - 'binding) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (let_binding : 'let_binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (fun_binding : 'fun_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_binding) (p : 'ipatt) - (_loc : Gram.Loc.t) -> - (Ast.BiEq (_loc, p, e) : 'let_binding)))) ]) ])) - ()); - Gram.extend (fun_binding : 'fun_binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (cvalue_binding : - 'cvalue_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (bi : 'cvalue_binding) - (_loc : Gram.Loc.t) -> (bi : 'fun_binding)))); - ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t))); - Gram.Sself ], - (Gram.Action.mk - (fun (e : 'fun_binding) (p : 'labeled_ipatt) - (_loc : Gram.Loc.t) -> - (Ast.ExFun (_loc, - (Ast.McArr (_loc, p, (Ast.ExNil _loc), - e))) : - 'fun_binding)))); - ([ Gram.Stry - (Gram.srules fun_binding - [ ([ Gram.Skeyword "("; - Gram.Skeyword "type" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (() : 'e__6)))) ]); - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ")"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'fun_binding) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.ExFUN (_loc, i, e) : 'fun_binding)))) ]) ])) - ()); - Gram.extend (match_case : 'match_case Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (p : 'ipatt) - (_loc : Gram.Loc.t) -> - (Ast.McArr (_loc, p, (Ast.ExNil _loc), e) : - 'match_case)))); - ([ Gram.Skeyword "["; - Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (match_case0 : - 'match_case0 Gram.Entry.t))), - (Gram.Skeyword "|")); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (l : 'match_case0 list) _ - (_loc : Gram.Loc.t) -> - (Ast.mcOr_of_list l : 'match_case)))) ]) ])) - ()); - Gram.extend (match_case0 : 'match_case0 Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (patt_as_patt_opt : - 'patt_as_patt_opt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_when_expr : - 'opt_when_expr Gram.Entry.t)); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (w : 'opt_when_expr) - (p : 'patt_as_patt_opt) (_loc : Gram.Loc.t) - -> - (Ast.McArr (_loc, p, w, e) : 'match_case0)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")); - Gram.Skeyword "when"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (w : 'expr) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.McArr (_loc, - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s))), - w, e) : - 'match_case0) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.McArr (_loc, - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s))), - (Ast.ExNil _loc), e) : - 'match_case0) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.McAnt (_loc, - (mk_anti ~c: "match_case" n s)) : - 'match_case0) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("match_case" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"match_case\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("match_case" | "list" as n)), - s) -> - (Ast.McAnt (_loc, - (mk_anti ~c: "match_case" n s)) : - 'match_case0) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (opt_when_expr : 'opt_when_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.ExNil _loc : 'opt_when_expr)))); - ([ Gram.Skeyword "when"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (w : 'expr) _ (_loc : Gram.Loc.t) -> - (w : 'opt_when_expr)))) ]) ])) - ()); - Gram.extend - (patt_as_patt_opt : 'patt_as_patt_opt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) (_loc : Gram.Loc.t) -> - (p : 'patt_as_patt_opt)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword "as"; - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p2 : 'patt) _ (p1 : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaAli (_loc, p1, p2) : - 'patt_as_patt_opt)))) ]) ])) - ()); - Gram.extend (label_expr_list : 'label_expr_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_expr : 'label_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (b1 : 'label_expr) (_loc : Gram.Loc.t) -> - (b1 : 'label_expr_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_expr : 'label_expr Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (b1 : 'label_expr) (_loc : Gram.Loc.t) - -> (b1 : 'label_expr_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_expr : 'label_expr Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (b2 : 'label_expr_list) _ - (b1 : 'label_expr) (_loc : Gram.Loc.t) -> - (Ast.RbSem (_loc, b1, b2) : - 'label_expr_list)))) ]) ])) - ()); - Gram.extend (label_expr : 'label_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'label_longident) - (_loc : Gram.Loc.t) -> - (Ast.RbEq (_loc, i, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, (lid_of_ident i)))))) : - 'label_expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (fun_binding : 'fun_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_binding) (i : 'label_longident) - (_loc : Gram.Loc.t) -> - (Ast.RbEq (_loc, i, e) : 'label_expr)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.RbAnt (_loc, - (mk_anti ~c: "rec_binding" n s)) : - 'label_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.RbEq (_loc, - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s))), - e) : - 'label_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "anti" as n)), s) -> - (Ast.RbAnt (_loc, - (mk_anti ~c: "rec_binding" n s)) : - 'label_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("rec_binding", _) -> true - | _ -> false), - "ANTIQUOT (\"rec_binding\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("rec_binding" as n)), s) -> - (Ast.RbAnt (_loc, - (mk_anti ~c: "rec_binding" n s)) : - 'label_expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (fun_def : 'fun_def Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (fun_def_cont : - 'fun_def_cont Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((w, e) : 'fun_def_cont) - (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> - (Ast.ExFun (_loc, - (Ast.McArr (_loc, p, w, e))) : - 'fun_def)))); - ([ Gram.Stry - (Gram.srules fun_def - [ ([ Gram.Skeyword "("; - Gram.Skeyword "type" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (() : 'e__7)))) ]); - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ")"; - Gram.Snterm - (Gram.Entry.obj - (fun_def_cont_no_when : - 'fun_def_cont_no_when Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_def_cont_no_when) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.ExFUN (_loc, i, e) : 'fun_def)))) ]) ])) - ()); - Gram.extend (fun_def_cont : 'fun_def_cont Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (((Ast.ExNil _loc), e) : 'fun_def_cont)))); - ([ Gram.Skeyword "when"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (w : 'expr) _ - (_loc : Gram.Loc.t) -> - ((w, e) : 'fun_def_cont)))); - ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t))); - Gram.Sself ], - (Gram.Action.mk - (fun ((w, e) : 'fun_def_cont) - (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> - (((Ast.ExNil _loc), - (Ast.ExFun (_loc, - (Ast.McArr (_loc, p, w, e))))) : - 'fun_def_cont)))); - ([ Gram.Stry - (Gram.srules fun_def_cont - [ ([ Gram.Skeyword "("; - Gram.Skeyword "type" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (() : 'e__8)))) ]); - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ")"; - Gram.Snterm - (Gram.Entry.obj - (fun_def_cont_no_when : - 'fun_def_cont_no_when Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_def_cont_no_when) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (((Ast.ExNil _loc), - (Ast.ExFUN (_loc, i, e))) : - 'fun_def_cont)))) ]) ])) - ()); - Gram.extend - (fun_def_cont_no_when : 'fun_def_cont_no_when Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (e : 'fun_def_cont_no_when)))); - ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (fun_def_cont : - 'fun_def_cont Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((w, e) : 'fun_def_cont) - (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> - (Ast.ExFun (_loc, - (Ast.McArr (_loc, p, w, e))) : - 'fun_def_cont_no_when)))); - ([ Gram.Stry - (Gram.srules fun_def_cont_no_when - [ ([ Gram.Skeyword "("; - Gram.Skeyword "type" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (() : 'e__9)))) ]); - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ")"; Gram.Sself ], - (Gram.Action.mk - (fun (e : 'fun_def_cont_no_when) _ - (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (Ast.ExFUN (_loc, i, e) : - 'fun_def_cont_no_when)))) ]) ])) - ()); - Gram.extend (patt : 'patt Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "|"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'patt) _ (p1 : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaOrp (_loc, p1, p2) : 'patt)))) ]); - ((Some ".."), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Sself; Gram.Skeyword ".."; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'patt) _ (p1 : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaRng (_loc, p1, p2) : 'patt)))) ]); - ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "lazy"; Gram.Sself ], - (Gram.Action.mk - (fun (p : 'patt) _ (_loc : Gram.Loc.t) -> - (Ast.PaLaz (_loc, p) : 'patt)))); - ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'patt) (p1 : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaApp (_loc, p1, p2) : 'patt)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "?"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (patt_tcon : 'patt_tcon Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e : 'expr) _ (p : 'patt_tcon) _ _ - (_loc : Gram.Loc.t) -> - (Ast.PaOlbi (_loc, "", p, e) : 'patt)))); - ([ Gram.Skeyword "?"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (patt_tcon : 'patt_tcon Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'patt_tcon) _ _ - (_loc : Gram.Loc.t) -> - (Ast.PaOlb (_loc, "", p) : 'patt)))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaOlb (_loc, (mk_anti n i), - (Ast.PaNil _loc)) : - 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function | LIDENT _ -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT i -> - (Ast.PaOlb (_loc, i, (Ast.PaNil _loc)) : - 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")); - Gram.Skeyword ":"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (patt_tcon : 'patt_tcon Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (eq_expr : 'eq_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (f : 'eq_expr) (p : 'patt_tcon) _ _ - (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (f (mk_anti n i) p : 'patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function | OPTLABEL _ -> true | _ -> false), - "OPTLABEL _")); - Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (patt_tcon : 'patt_tcon Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (eq_expr : 'eq_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (f : 'eq_expr) (p : 'patt_tcon) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | OPTLABEL i -> (f i p : 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function | LIDENT _ -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT i -> - (Ast.PaLab (_loc, i, (Ast.PaNil _loc)) : - 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaLab (_loc, (mk_anti n i), - (Ast.PaNil _loc)) : - 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (p : 'patt) _ (__camlp4_0 : Gram.Token.t) - _ (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaLab (_loc, (mk_anti n i), p) : - 'patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function | LABEL _ -> true | _ -> false), - "LABEL _")); - Gram.Sself ], - (Gram.Action.mk - (fun (p : 'patt) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LABEL i -> - (Ast.PaLab (_loc, i, p) : 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (type_longident : - 'type_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'type_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTyp (_loc, i) : 'patt)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.PaVrn (_loc, s) : 'patt)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.patt_tag : - 'patt) - | _ -> assert false))); - ([ Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.PaAny _loc : 'patt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_patt : 'comma_patt Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (pl : 'comma_patt) _ (p : 'patt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTup (_loc, - (Ast.PaCom (_loc, p, pl))) : - 'patt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword "as"; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p2 : 'patt) _ (p : 'patt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaAli (_loc, p, p2) : 'patt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (p : 'patt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, p, t) : 'patt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'patt) _ (_loc : Gram.Loc.t) -> - (p : 'patt)))); - ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (package_type : - 'package_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (pt : 'package_type) _ (m : 'a_UIDENT) - _ _ (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)), - (Ast.TyPkg (_loc, pt))) : - 'patt)))); - ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) - -> (Ast.PaMod (_loc, m) : 'patt)))); - ([ Gram.Skeyword "("; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.PaId (_loc, (Ast.IdUid (_loc, "()"))) : - 'patt)))); - ([ Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (label_patt_list : - 'label_patt_list Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (pl : 'label_patt_list) _ - (_loc : Gram.Loc.t) -> - (Ast.PaRec (_loc, pl) : 'patt)))); - ([ Gram.Skeyword "[|"; - Gram.Snterm - (Gram.Entry.obj - (sem_patt : 'sem_patt Gram.Entry.t)); - Gram.Skeyword "|]" ], - (Gram.Action.mk - (fun _ (pl : 'sem_patt) _ (_loc : Gram.Loc.t) - -> (Ast.PaArr (_loc, pl) : 'patt)))); - ([ Gram.Skeyword "[|"; Gram.Skeyword "|]" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.PaArr (_loc, (Ast.PaNil _loc)) : - 'patt)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (sem_patt_for_list : - 'sem_patt_for_list Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (mk_list : 'sem_patt_for_list) _ - (_loc : Gram.Loc.t) -> - (mk_list - (Ast.PaId (_loc, - (Ast.IdUid (_loc, "[]")))) : - 'patt)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (sem_patt_for_list : - 'sem_patt_for_list Gram.Entry.t)); - Gram.Skeyword "::"; Gram.Sself; - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (last : 'patt) _ - (mk_list : 'sem_patt_for_list) _ - (_loc : Gram.Loc.t) -> - (mk_list last : 'patt)))); - ([ Gram.Skeyword "["; Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.PaId (_loc, (Ast.IdUid (_loc, "[]"))) : - 'patt)))); - ([ Gram.Skeyword "-"; - Gram.Snterm - (Gram.Entry.obj - (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_FLOAT) _ (_loc : Gram.Loc.t) -> - (Ast.PaFlo (_loc, (neg_string s)) : 'patt)))); - ([ Gram.Skeyword "-"; - Gram.Snterm - (Gram.Entry.obj - (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_NATIVEINT) _ (_loc : Gram.Loc.t) - -> - (Ast.PaNativeInt (_loc, (neg_string s)) : - 'patt)))); - ([ Gram.Skeyword "-"; - Gram.Snterm - (Gram.Entry.obj - (a_INT64 : 'a_INT64 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT64) _ (_loc : Gram.Loc.t) -> - (Ast.PaInt64 (_loc, (neg_string s)) : - 'patt)))); - ([ Gram.Skeyword "-"; - Gram.Snterm - (Gram.Entry.obj - (a_INT32 : 'a_INT32 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT32) _ (_loc : Gram.Loc.t) -> - (Ast.PaInt32 (_loc, (neg_string s)) : - 'patt)))); - ([ Gram.Skeyword "-"; - Gram.Snterm - (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT) _ (_loc : Gram.Loc.t) -> - (Ast.PaInt (_loc, (neg_string s)) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_CHAR : 'a_CHAR Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_CHAR) (_loc : Gram.Loc.t) -> - (Ast.PaChr (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_STRING : 'a_STRING Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_STRING) (_loc : Gram.Loc.t) -> - (Ast.PaStr (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_FLOAT) (_loc : Gram.Loc.t) -> - (Ast.PaFlo (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_NATIVEINT) (_loc : Gram.Loc.t) -> - (Ast.PaNativeInt (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_INT64 : 'a_INT64 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT64) (_loc : Gram.Loc.t) -> - (Ast.PaInt64 (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_INT32 : 'a_INT32 Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT32) (_loc : Gram.Loc.t) -> - (Ast.PaInt32 (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_INT) (_loc : Gram.Loc.t) -> - (Ast.PaInt (_loc, s) : 'patt)))); - ([ Gram.Snterm - (Gram.Entry.obj (ident : 'ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'ident) (_loc : Gram.Loc.t) -> - (Ast.PaId (_loc, i) : 'patt)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("`bool", _) -> true - | _ -> false), - "ANTIQUOT (\"`bool\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("`bool" as n)), s) -> - (Ast.PaId (_loc, - (Ast.IdAnt (_loc, (mk_anti n s)))) : - 'patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("tup", _) -> true - | _ -> false), - "ANTIQUOT (\"tup\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("tup" as n)), s) -> - (Ast.PaTup (_loc, - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)))) : - 'patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "pat" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "pat" | "anti" as n)), - s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)) : - 'patt) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (comma_patt : 'comma_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) (_loc : Gram.Loc.t) -> - (p : 'comma_patt)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt," n s)) : - 'comma_patt) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'comma_patt) _ (p1 : 'comma_patt) - (_loc : Gram.Loc.t) -> - (Ast.PaCom (_loc, p1, p2) : 'comma_patt)))) ]) ])) - ()); - Gram.extend (sem_patt : 'sem_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) (_loc : Gram.Loc.t) -> - (p : 'sem_patt)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (p : 'patt) (_loc : Gram.Loc.t) -> - (p : 'sem_patt)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt;" n s)) : - 'sem_patt) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'sem_patt) _ (p1 : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, p2) : 'sem_patt)))) ]) ])) - ()); - Gram.extend - (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, "::")))), - p)), - acc) : - 'sem_patt_for_list)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (p : 'patt) (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, "::")))), - p)), - acc) : - 'sem_patt_for_list)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (pl : 'sem_patt_for_list) _ (p : 'patt) - (_loc : Gram.Loc.t) -> - (fun acc -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, "::")))), - p)), - (pl acc)) : - 'sem_patt_for_list)))) ]) ])) - ()); - Gram.extend (label_patt_list : 'label_patt_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_patt : 'label_patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p1 : 'label_patt) (_loc : Gram.Loc.t) -> - (p1 : 'label_patt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_patt : 'label_patt Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (p1 : 'label_patt) (_loc : Gram.Loc.t) - -> (p1 : 'label_patt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_patt : 'label_patt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Skeyword "_"; - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ _ _ (p1 : 'label_patt) - (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : - 'label_patt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_patt : 'label_patt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ _ (p1 : 'label_patt) - (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : - 'label_patt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_patt : 'label_patt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'label_patt_list) _ - (p1 : 'label_patt) (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, p2) : - 'label_patt_list)))) ]) ])) - ()); - Gram.extend (label_patt : 'label_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'label_longident) - (_loc : Gram.Loc.t) -> - (Ast.PaEq (_loc, i, - (Ast.PaId (_loc, - (Ast.IdLid (_loc, (lid_of_ident i)))))) : - 'label_patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) _ (i : 'label_longident) - (_loc : Gram.Loc.t) -> - (Ast.PaEq (_loc, i, p) : 'label_patt)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt;" n s)) : - 'label_patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.patt_tag : - 'label_patt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "pat" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "pat" | "anti" as n)), - s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)) : - 'label_patt) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (ipatt : 'ipatt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.PaAny _loc : 'ipatt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.PaId (_loc, (Ast.IdLid (_loc, s))) : - 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_ipatt : 'comma_ipatt Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (pl : 'comma_ipatt) _ (p : 'ipatt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTup (_loc, - (Ast.PaCom (_loc, p, pl))) : - 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword "as"; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaAli (_loc, p, p2) : 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (p : 'ipatt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, p, t) : 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'ipatt) _ (_loc : Gram.Loc.t) -> - (p : 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (package_type : - 'package_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (pt : 'package_type) _ (m : 'a_UIDENT) - _ _ (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)), - (Ast.TyPkg (_loc, pt))) : - 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) - -> (Ast.PaMod (_loc, m) : 'ipatt)))); - ([ Gram.Skeyword "("; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.PaId (_loc, (Ast.IdUid (_loc, "()"))) : - 'ipatt)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.patt_tag : - 'ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("tup", _) -> true - | _ -> false), - "ANTIQUOT (\"tup\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("tup" as n)), s) -> - (Ast.PaTup (_loc, - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)))) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "pat" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "pat" | "anti" as n)), - s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (label_ipatt_list : - 'label_ipatt_list Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (pl : 'label_ipatt_list) _ - (_loc : Gram.Loc.t) -> - (Ast.PaRec (_loc, pl) : 'ipatt)))) ]) ])) - ()); - Gram.extend (labeled_ipatt : 'labeled_ipatt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'ipatt) (_loc : Gram.Loc.t) -> - (p : 'labeled_ipatt)))) ]) ])) - ()); - Gram.extend (comma_ipatt : 'comma_ipatt Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'ipatt) (_loc : Gram.Loc.t) -> - (p : 'comma_ipatt)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt," n s)) : - 'comma_ipatt) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'comma_ipatt) _ (p1 : 'comma_ipatt) - (_loc : Gram.Loc.t) -> - (Ast.PaCom (_loc, p1, p2) : 'comma_ipatt)))) ]) ])) - ()); - Gram.extend - (label_ipatt_list : 'label_ipatt_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_ipatt : 'label_ipatt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p1 : 'label_ipatt) (_loc : Gram.Loc.t) - -> (p1 : 'label_ipatt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_ipatt : 'label_ipatt Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (p1 : 'label_ipatt) (_loc : Gram.Loc.t) - -> (p1 : 'label_ipatt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_ipatt : 'label_ipatt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Skeyword "_"; - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ _ _ (p1 : 'label_ipatt) - (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : - 'label_ipatt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_ipatt : 'label_ipatt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ _ (p1 : 'label_ipatt) - (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : - 'label_ipatt_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_ipatt : 'label_ipatt Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'label_ipatt_list) _ - (p1 : 'label_ipatt) (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, p2) : - 'label_ipatt_list)))) ]) ])) - ()); - Gram.extend (label_ipatt : 'label_ipatt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'ipatt) _ (i : 'label_longident) - (_loc : Gram.Loc.t) -> - (Ast.PaEq (_loc, i, p) : 'label_ipatt)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.patt_tag : - 'label_ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt;" n s)) : - 'label_ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "pat" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "pat" | "anti" as n)), - s) -> - (Ast.PaAnt (_loc, - (mk_anti ~c: "patt" n s)) : - 'label_ipatt) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (type_declaration : 'type_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_ident_and_parameters : - 'type_ident_and_parameters Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t)); - Gram.Slist0 - (Gram.Snterm - (Gram.Entry.obj - (constrain : 'constrain Gram.Entry.t))) ], - (Gram.Action.mk - (fun (cl : 'constrain list) - (tk : 'opt_eq_ctyp) - ((n, tpl) : 'type_ident_and_parameters) - (_loc : Gram.Loc.t) -> - (Ast.TyDcl (_loc, n, tpl, tk, cl) : - 'type_declaration)))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'type_declaration) _ - (t1 : 'type_declaration) - (_loc : Gram.Loc.t) -> - (Ast.TyAnd (_loc, t1, t2) : - 'type_declaration)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'type_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctypand" n s)) : - 'type_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), - s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'type_declaration) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (constrain : 'constrain Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "constraint"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ - (_loc : Gram.Loc.t) -> - ((t1, t2) : 'constrain)))) ]) ])) - ()); - Gram.extend (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.TyNil _loc : 'opt_eq_ctyp)))); - ([ Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (type_kind : 'type_kind Gram.Entry.t)) ], - (Gram.Action.mk - (fun (tk : 'type_kind) _ (_loc : Gram.Loc.t) - -> (tk : 'opt_eq_ctyp)))) ]) ])) - ()); - Gram.extend (type_kind : 'type_kind Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'type_kind)))) ]) ])) - ()); - Gram.extend - (type_ident_and_parameters : - 'type_ident_and_parameters Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Slist0 - (Gram.Snterm - (Gram.Entry.obj - (optional_type_parameter : - 'optional_type_parameter Gram.Entry.t))) ], - (Gram.Action.mk - (fun (tpl : 'optional_type_parameter list) - (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - ((i, tpl) : 'type_ident_and_parameters)))) ]) ])) - ()); - Gram.extend - (type_longident_and_parameters : - 'type_longident_and_parameters Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_longident : - 'type_longident Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (type_parameters : - 'type_parameters Gram.Entry.t)) ], - (Gram.Action.mk - (fun (tpl : 'type_parameters) - (i : 'type_longident) (_loc : Gram.Loc.t) - -> - (tpl (Ast.TyId (_loc, i)) : - 'type_longident_and_parameters)))) ]) ])) - ()); - Gram.extend (type_parameters : 'type_parameters Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (fun t -> t : 'type_parameters)))); - ([ Gram.Snterm - (Gram.Entry.obj - (type_parameter : - 'type_parameter Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'type_parameter) (_loc : Gram.Loc.t) - -> - (fun acc -> Ast.TyApp (_loc, acc, t) : - 'type_parameters)))); - ([ Gram.Snterm - (Gram.Entry.obj - (type_parameter : - 'type_parameter Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'type_parameters) - (t1 : 'type_parameter) (_loc : Gram.Loc.t) - -> - (fun acc -> t2 (Ast.TyApp (_loc, acc, t1)) : - 'type_parameters)))) ]) ])) - ()); - Gram.extend (type_parameter : 'type_parameter Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "-"; Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> - (Ast.TyQuM (_loc, i) : 'type_parameter)))); - ([ Gram.Skeyword "+"; Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> - (Ast.TyQuP (_loc, i) : 'type_parameter)))); - ([ Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyQuo (_loc, i) : 'type_parameter)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'type_parameter) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), - s) -> - (Ast.TyAnt (_loc, (mk_anti n s)) : - 'type_parameter) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (optional_type_parameter : - 'optional_type_parameter Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.TyAny _loc : 'optional_type_parameter)))); - ([ Gram.Skeyword "-"; Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.TyAnM _loc : 'optional_type_parameter)))); - ([ Gram.Skeyword "+"; Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.TyAnP _loc : 'optional_type_parameter)))); - ([ Gram.Skeyword "-"; Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> - (Ast.TyQuM (_loc, i) : - 'optional_type_parameter)))); - ([ Gram.Skeyword "+"; Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) -> - (Ast.TyQuP (_loc, i) : - 'optional_type_parameter)))); - ([ Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyQuo (_loc, i) : - 'optional_type_parameter)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'optional_type_parameter) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), - s) -> - (Ast.TyAnt (_loc, (mk_anti n s)) : - 'optional_type_parameter) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (ctyp : 'ctyp Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "=="), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Skeyword "=="; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyMan (_loc, t1, t2) : 'ctyp)))) ]); - ((Some "private"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Skeyword "private"; - Gram.Snterml - ((Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)), - "alias") ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (_loc : Gram.Loc.t) -> - (Ast.TyPrv (_loc, t) : 'ctyp)))) ]); - ((Some "alias"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Skeyword "as"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyAli (_loc, t1, t2) : 'ctyp)))) ]); - ((Some "forall"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "!"; - Gram.Snterm - (Gram.Entry.obj - (typevars : 'typevars Gram.Entry.t)); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'typevars) _ - (_loc : Gram.Loc.t) -> - (Ast.TyPol (_loc, t1, t2) : 'ctyp)))) ]); - ((Some "arrow"), (Some Camlp4.Sig.Grammar.RightA), - [ ([ Gram.Sself; Gram.Skeyword "->"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyArr (_loc, t1, t2) : 'ctyp)))) ]); - ((Some "label"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (t : 'ctyp) (i : 'a_OPTLABEL) - (_loc : Gram.Loc.t) -> - (Ast.TyOlb (_loc, i, t) : 'ctyp)))); - ([ Gram.Skeyword "?"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.TyOlb (_loc, i, t) : 'ctyp)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LABEL : 'a_LABEL Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (t : 'ctyp) (i : 'a_LABEL) - (_loc : Gram.Loc.t) -> - (Ast.TyLab (_loc, i, t) : 'ctyp)))); - ([ Gram.Skeyword "~"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.TyLab (_loc, i, t) : 'ctyp)))) ]); - ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) (t1 : 'ctyp) - (_loc : Gram.Loc.t) -> - (let t = Ast.TyApp (_loc, t1, t2) - in - try - Ast.TyId (_loc, (Ast.ident_of_ctyp t)) - with | Invalid_argument _ -> t : - 'ctyp)))) ]); - ((Some "."), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Gram.Loc.t) -> - (try - Ast.TyId (_loc, - (Ast.IdAcc (_loc, - (Ast.ident_of_ctyp t1), - (Ast.ident_of_ctyp t2)))) - with - | Invalid_argument s -> - raise (Stream.Error s) : - 'ctyp)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Skeyword "module"; - Gram.Snterm - (Gram.Entry.obj - (package_type : - 'package_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'package_type) _ _ - (_loc : Gram.Loc.t) -> - (Ast.TyPkg (_loc, p) : 'ctyp)))); - ([ Gram.Skeyword "<"; - Gram.Snterm - (Gram.Entry.obj - (opt_meth_list : - 'opt_meth_list Gram.Entry.t)); - Gram.Skeyword ">" ], - (Gram.Action.mk - (fun _ (t : 'opt_meth_list) _ - (_loc : Gram.Loc.t) -> (t : 'ctyp)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (class_longident : - 'class_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'class_longident) _ - (_loc : Gram.Loc.t) -> - (Ast.TyCls (_loc, i) : 'ctyp)))); - ([ Gram.Skeyword "{"; - Gram.Snterm - (Gram.Entry.obj - (label_declaration_list : - 'label_declaration_list Gram.Entry.t)); - Gram.Skeyword "}" ], - (Gram.Action.mk - (fun _ (t : 'label_declaration_list) _ - (_loc : Gram.Loc.t) -> - (Ast.TyRec (_loc, t) : 'ctyp)))); - ([ Gram.Skeyword "[<"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword ">"; - Gram.Snterm - (Gram.Entry.obj - (name_tags : 'name_tags Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (ntl : 'name_tags) _ (rfl : 'row_field) - _ (_loc : Gram.Loc.t) -> - (Ast.TyVrnInfSup (_loc, rfl, ntl) : 'ctyp)))); - ([ Gram.Skeyword "[<"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (rfl : 'row_field) _ - (_loc : Gram.Loc.t) -> - (Ast.TyVrnInf (_loc, rfl) : 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword "<"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword ">"; - Gram.Snterm - (Gram.Entry.obj - (name_tags : 'name_tags Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (ntl : 'name_tags) _ (rfl : 'row_field) - _ _ (_loc : Gram.Loc.t) -> - (Ast.TyVrnInfSup (_loc, rfl, ntl) : 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword "<"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (rfl : 'row_field) _ _ - (_loc : Gram.Loc.t) -> - (Ast.TyVrnInf (_loc, rfl) : 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword ">"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (rfl : 'row_field) _ _ - (_loc : Gram.Loc.t) -> - (Ast.TyVrnSup (_loc, rfl) : 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword ">"; - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ _ _ (_loc : Gram.Loc.t) -> - (Ast.TyVrnSup (_loc, (Ast.TyNil _loc)) : - 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (rfl : 'row_field) _ _ - (_loc : Gram.Loc.t) -> - (Ast.TyVrnEq (_loc, rfl) : 'ctyp)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (constructor_declarations : - 'constructor_declarations Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (t : 'constructor_declarations) _ - (_loc : Gram.Loc.t) -> - (Ast.TySum (_loc, t) : 'ctyp)))); - ([ Gram.Skeyword "["; Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.TySum (_loc, (Ast.TyNil _loc)) : - 'ctyp)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (_loc : Gram.Loc.t) -> - (t : 'ctyp)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword "*"; - Gram.Snterm - (Gram.Entry.obj - (star_ctyp : 'star_ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (tl : 'star_ctyp) _ (t : 'ctyp) _ - (_loc : Gram.Loc.t) -> - (Ast.TyTup (_loc, - (Ast.TySta (_loc, t, tl))) : - 'ctyp)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyId (_loc, (Ast.IdUid (_loc, i))) : - 'ctyp)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyId (_loc, (Ast.IdLid (_loc, i))) : - 'ctyp)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'ctyp) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("id", _) -> true - | _ -> false), - "ANTIQUOT (\"id\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("id" as n)), s) -> - (Ast.TyId (_loc, - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)))) : - 'ctyp) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("tup", _) -> true - | _ -> false), - "ANTIQUOT (\"tup\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("tup" as n)), s) -> - (Ast.TyTup (_loc, - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)))) : - 'ctyp) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" | "anti" as n)), - s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'ctyp) - | _ -> assert false))); - ([ Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.TyAny _loc : 'ctyp)))); - ([ Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyQuo (_loc, i) : 'ctyp)))) ]) ])) - ()); - Gram.extend (star_ctyp : 'star_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'star_ctyp)))); - ([ Gram.Sself; Gram.Skeyword "*"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'star_ctyp) _ (t1 : 'star_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TySta (_loc, t1, t2) : 'star_ctyp)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp*" n s)) : - 'star_ctyp) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'star_ctyp) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (constructor_declarations : - 'constructor_declarations Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyId (_loc, (Ast.IdUid (_loc, s))) : - 'constructor_declarations)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (s : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (let (tl, rt) = generalized_type_of_type t - in - Ast.TyCol (_loc, - (Ast.TyId (_loc, - (Ast.IdUid (_loc, s)))), - (Ast.TyArr (_loc, - (Ast.tyAnd_of_list tl), rt))) : - 'constructor_declarations)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (constructor_arg_list : - 'constructor_arg_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'constructor_arg_list) _ - (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyOf (_loc, - (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), - t) : - 'constructor_declarations)))); - ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'constructor_declarations) _ - (t1 : 'constructor_declarations) - (_loc : Gram.Loc.t) -> - (Ast.TyOr (_loc, t1, t2) : - 'constructor_declarations)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'constructor_declarations) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp|" n s)) : - 'constructor_declarations) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'constructor_declarations) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (constructor_declaration : - 'constructor_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyId (_loc, (Ast.IdUid (_loc, s))) : - 'constructor_declaration)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (constructor_arg_list : - 'constructor_arg_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'constructor_arg_list) _ - (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyOf (_loc, - (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), - t) : - 'constructor_declaration)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'constructor_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'constructor_declaration) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (constructor_arg_list : 'constructor_arg_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'constructor_arg_list)))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'constructor_arg_list) _ - (t1 : 'constructor_arg_list) - (_loc : Gram.Loc.t) -> - (Ast.TyAnd (_loc, t1, t2) : - 'constructor_arg_list)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctypand" n s)) : - 'constructor_arg_list) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (label_declaration_list : - 'label_declaration_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_declaration : - 'label_declaration Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t1 : 'label_declaration) - (_loc : Gram.Loc.t) -> - (t1 : 'label_declaration_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_declaration : - 'label_declaration Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (t1 : 'label_declaration) - (_loc : Gram.Loc.t) -> - (t1 : 'label_declaration_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_declaration : - 'label_declaration Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'label_declaration_list) _ - (t1 : 'label_declaration) - (_loc : Gram.Loc.t) -> - (Ast.TySem (_loc, t1, t2) : - 'label_declaration_list)))) ]) ])) - ()); - Gram.extend - (label_declaration : 'label_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; Gram.Skeyword "mutable"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ _ (s : 'a_LIDENT) - (_loc : Gram.Loc.t) -> - (Ast.TyCol (_loc, - (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))), - (Ast.TyMut (_loc, t))) : - 'label_declaration)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (s : 'a_LIDENT) - (_loc : Gram.Loc.t) -> - (Ast.TyCol (_loc, - (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))), - t) : - 'label_declaration)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'label_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp;" n s)) : - 'label_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'label_declaration) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_ident : 'a_ident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (i : 'a_ident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (i : 'a_ident)))) ]) ])) - ()); - Gram.extend (ident : 'ident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'ident) _ (i : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, i)), j) : - 'ident)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (i : 'ident) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAcc (_loc, - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s))), - i) : - 'ident) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdLid (_loc, i) : 'ident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdUid (_loc, i) : 'ident)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'ident) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (module_longident : 'module_longident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdUid (_loc, i) : 'module_longident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (l : 'module_longident) _ (m : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) : - 'module_longident)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'module_longident) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (module_longident_with_app : - 'module_longident_with_app Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "apply"), None, - [ ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'module_longident_with_app) - (i : 'module_longident_with_app) - (_loc : Gram.Loc.t) -> - (Ast.IdApp (_loc, i, j) : - 'module_longident_with_app)))) ]); - ((Some "."), None, - [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'module_longident_with_app) _ - (i : 'module_longident_with_app) - (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, i, j) : - 'module_longident_with_app)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (i : 'module_longident_with_app) _ - (_loc : Gram.Loc.t) -> - (i : 'module_longident_with_app)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdUid (_loc, i) : - 'module_longident_with_app)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'module_longident_with_app) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (module_longident_dot_lparen : - 'module_longident_dot_lparen Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "."; Gram.Skeyword "(" ], - (Gram.Action.mk - (fun _ _ (i : 'a_UIDENT) (_loc : Gram.Loc.t) - -> - (Ast.IdUid (_loc, i) : - 'module_longident_dot_lparen)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (l : 'module_longident_dot_lparen) _ - (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) : - 'module_longident_dot_lparen)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")); - Gram.Skeyword "."; Gram.Skeyword "(" ], - (Gram.Action.mk - (fun _ _ (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'module_longident_dot_lparen) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (type_longident : 'type_longident Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "apply"), None, - [ ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'type_longident) - (i : 'type_longident) (_loc : Gram.Loc.t) - -> - (Ast.IdApp (_loc, i, j) : 'type_longident)))) ]); - ((Some "."), None, - [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'type_longident) _ - (i : 'type_longident) (_loc : Gram.Loc.t) - -> - (Ast.IdAcc (_loc, i, j) : 'type_longident)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (i : 'type_longident) _ - (_loc : Gram.Loc.t) -> - (i : 'type_longident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdUid (_loc, i) : 'type_longident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdLid (_loc, i) : 'type_longident)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'type_longident) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (label_longident : 'label_longident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdLid (_loc, i) : 'label_longident)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (l : 'label_longident) _ (m : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), l) : - 'label_longident)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'label_longident) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (class_type_longident : 'class_type_longident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_longident : - 'type_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'type_longident) (_loc : Gram.Loc.t) - -> (x : 'class_type_longident)))) ]) ])) - ()); - Gram.extend (val_longident : 'val_longident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ident : 'ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'ident) (_loc : Gram.Loc.t) -> - (x : 'val_longident)))) ]) ])) - ()); - Gram.extend (class_longident : 'class_longident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (label_longident : - 'label_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'label_longident) - (_loc : Gram.Loc.t) -> - (x : 'class_longident)))) ]) ])) - ()); - Gram.extend - (class_declaration : 'class_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_info_for_class_expr : - 'class_info_for_class_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_fun_binding : - 'class_fun_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_fun_binding) - (ci : 'class_info_for_class_expr) - (_loc : Gram.Loc.t) -> - (Ast.CeEq (_loc, ci, ce) : - 'class_declaration)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_expr_tag : - 'class_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "cdcl" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"cdcl\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "cdcl" | "anti" | "list" as n)), - s) -> - (Ast.CeAnt (_loc, - (mk_anti ~c: "class_expr" n s)) : - 'class_declaration) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (c2 : 'class_declaration) _ - (c1 : 'class_declaration) - (_loc : Gram.Loc.t) -> - (Ast.CeAnd (_loc, c1, c2) : - 'class_declaration)))) ]) ])) - ()); - Gram.extend - (class_fun_binding : 'class_fun_binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (cfb : 'class_fun_binding) - (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> - (Ast.CeFun (_loc, p, cfb) : - 'class_fun_binding)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (class_type_plus : - 'class_type_plus Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (class_expr : 'class_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_expr) _ - (ct : 'class_type_plus) _ - (_loc : Gram.Loc.t) -> - (Ast.CeTyc (_loc, ce, ct) : - 'class_fun_binding)))); - ([ Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (class_expr : 'class_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_expr) _ (_loc : Gram.Loc.t) - -> (ce : 'class_fun_binding)))) ]) ])) - ()); - Gram.extend - (class_info_for_class_type : - 'class_info_for_class_type Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_virtual : 'opt_virtual Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_name_and_param : - 'class_name_and_param Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((i, ot) : 'class_name_and_param) - (mv : 'opt_virtual) (_loc : Gram.Loc.t) -> - (Ast.CtCon (_loc, mv, - (Ast.IdLid (_loc, i)), ot) : - 'class_info_for_class_type)))) ]) ])) - ()); - Gram.extend - (class_info_for_class_expr : - 'class_info_for_class_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_virtual : 'opt_virtual Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_name_and_param : - 'class_name_and_param Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((i, ot) : 'class_name_and_param) - (mv : 'opt_virtual) (_loc : Gram.Loc.t) -> - (Ast.CeCon (_loc, mv, - (Ast.IdLid (_loc, i)), ot) : - 'class_info_for_class_expr)))) ]) ])) - ()); - Gram.extend - (class_name_and_param : 'class_name_and_param Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - ((i, (Ast.TyNil _loc)) : - 'class_name_and_param)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (comma_type_parameter : - 'comma_type_parameter Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (x : 'comma_type_parameter) _ - (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - ((i, x) : 'class_name_and_param)))) ]) ])) - ()); - Gram.extend - (comma_type_parameter : 'comma_type_parameter Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_parameter : - 'type_parameter Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'type_parameter) (_loc : Gram.Loc.t) - -> (t : 'comma_type_parameter)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp," n s)) : - 'comma_type_parameter) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'comma_type_parameter) _ - (t1 : 'comma_type_parameter) - (_loc : Gram.Loc.t) -> - (Ast.TyCom (_loc, t1, t2) : - 'comma_type_parameter)))) ]) ])) - ()); - Gram.extend (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.TyNil _loc : 'opt_comma_ctyp)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (comma_ctyp : 'comma_ctyp Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (x : 'comma_ctyp) _ (_loc : Gram.Loc.t) - -> (x : 'opt_comma_ctyp)))) ]) ])) - ()); - Gram.extend (comma_ctyp : 'comma_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'comma_ctyp)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp," n s)) : - 'comma_ctyp) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'comma_ctyp) _ (t1 : 'comma_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyCom (_loc, t1, t2) : 'comma_ctyp)))) ]) ])) - ()); - Gram.extend (class_fun_def : 'class_fun_def Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj - (class_expr : 'class_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_expr) _ (_loc : Gram.Loc.t) - -> (ce : 'class_fun_def)))); - ([ Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (ce : 'class_fun_def) - (p : 'labeled_ipatt) (_loc : Gram.Loc.t) -> - (Ast.CeFun (_loc, p, ce) : 'class_fun_def)))) ]) ])) - ()); - Gram.extend (class_expr : 'class_expr Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), None, - [ ([ Gram.Skeyword "let"; - Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)); - Gram.Skeyword "in"; Gram.Sself ], - (Gram.Action.mk - (fun (ce : 'class_expr) _ (bi : 'binding) - (rf : 'opt_rec) _ (_loc : Gram.Loc.t) -> - (Ast.CeLet (_loc, rf, bi, ce) : - 'class_expr)))); - ([ Gram.Skeyword "fun"; - Gram.Snterm - (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_fun_def : - 'class_fun_def Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_fun_def) - (p : 'labeled_ipatt) _ (_loc : Gram.Loc.t) - -> (Ast.CeFun (_loc, p, ce) : 'class_expr)))) ]); - ((Some "apply"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Sself; - Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "label") ], - (Gram.Action.mk - (fun (e : 'expr) (ce : 'class_expr) - (_loc : Gram.Loc.t) -> - (Ast.CeApp (_loc, ce, e) : 'class_expr)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (ce : 'class_expr) _ - (_loc : Gram.Loc.t) -> (ce : 'class_expr)))); - ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (class_type : 'class_type Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (ct : 'class_type) _ (ce : 'class_expr) - _ (_loc : Gram.Loc.t) -> - (Ast.CeTyc (_loc, ce, ct) : 'class_expr)))); - ([ Gram.Skeyword "object"; - Gram.Snterm - (Gram.Entry.obj - (opt_class_self_patt : - 'opt_class_self_patt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_structure : - 'class_structure Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (cst : 'class_structure) - (csp : 'opt_class_self_patt) _ - (_loc : Gram.Loc.t) -> - (Ast.CeStr (_loc, csp, cst) : 'class_expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_longident_and_param : - 'class_longident_and_param Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ce : 'class_longident_and_param) - (_loc : Gram.Loc.t) -> (ce : 'class_expr)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_expr_tag : - 'class_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "cexp" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"cexp\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "cexp" | "anti" as n)), - s) -> - (Ast.CeAnt (_loc, - (mk_anti ~c: "class_expr" n s)) : - 'class_expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (class_longident_and_param : - 'class_longident_and_param Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_longident : - 'class_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ci : 'class_longident) - (_loc : Gram.Loc.t) -> - (Ast.CeCon (_loc, Ast.ViNil, ci, - (Ast.TyNil _loc)) : - 'class_longident_and_param)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_longident : - 'class_longident Gram.Entry.t)); - Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (comma_ctyp : 'comma_ctyp Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (t : 'comma_ctyp) _ - (ci : 'class_longident) (_loc : Gram.Loc.t) - -> - (Ast.CeCon (_loc, Ast.ViNil, ci, t) : - 'class_longident_and_param)))) ]) ])) - ()); - Gram.extend (class_structure : 'class_structure Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist0 - (Gram.srules class_structure - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_str_item : - 'class_str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (cst : 'class_str_item) - (_loc : Gram.Loc.t) -> - (cst : 'e__10)))) ]) ], - (Gram.Action.mk - (fun (l : 'e__10 list) (_loc : Gram.Loc.t) -> - (Ast.crSem_of_list l : 'class_structure)))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "cst" | "anti" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (cst : 'class_structure) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "cst" | "anti" | "list" as n)), - s) -> - (Ast.CrSem (_loc, - (Ast.CrAnt (_loc, - (mk_anti ~c: "class_str_item" n s))), - cst) : - 'class_structure) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "cst" | "anti" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "cst" | "anti" | "list" as n)), - s) -> - (Ast.CrAnt (_loc, - (mk_anti ~c: "class_str_item" n s)) : - 'class_structure) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.PaNil _loc : 'opt_class_self_patt)))); - ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (p : 'patt) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, p, t) : - 'opt_class_self_patt)))); - ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'patt) _ (_loc : Gram.Loc.t) -> - (p : 'opt_class_self_patt)))) ]) ])) - ()); - Gram.extend (class_str_item : 'class_str_item Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "initializer"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (se : 'expr) _ (_loc : Gram.Loc.t) -> - (Ast.CrIni (_loc, se) : 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (type_constraint : - 'type_constraint Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ - (_loc : Gram.Loc.t) -> - (Ast.CrCtr (_loc, t1, t2) : - 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (method_opt_override : - 'method_opt_override Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) _ - (pf : 'opt_private) - (o : 'method_opt_override) - (_loc : Gram.Loc.t) -> - (if o <> Ast.OvNil - then - raise - (Stream.Error - "override (!) is incompatible with virtual") - else Ast.CrVir (_loc, l, pf, t) : - 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (method_opt_override : - 'method_opt_override Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_polyt : 'opt_polyt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (fun_binding : 'fun_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'fun_binding) (topt : 'opt_polyt) - (l : 'label) (pf : 'opt_private) - (o : 'method_opt_override) - (_loc : Gram.Loc.t) -> - (Ast.CrMth (_loc, l, o, pf, e, topt) : - 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (method_opt_override : - 'method_opt_override Gram.Entry.t)); - Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) - (pf : 'opt_private) _ - (o : 'method_opt_override) - (_loc : Gram.Loc.t) -> - (if o <> Ast.OvNil - then - raise - (Stream.Error - "override (!) is incompatible with virtual") - else Ast.CrVir (_loc, l, pf, t) : - 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val_opt_override : - 'value_val_opt_override Gram.Entry.t)); - Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj - (opt_mutable : 'opt_mutable Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) - (mf : 'opt_mutable) _ - (o : 'value_val_opt_override) - (_loc : Gram.Loc.t) -> - (if o <> Ast.OvNil - then - raise - (Stream.Error - "override (!) is incompatible with virtual") - else Ast.CrVvr (_loc, l, mf, t) : - 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val_opt_override : - 'value_val_opt_override Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_mutable : 'opt_mutable Gram.Entry.t)); - Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) _ - (mf : 'opt_mutable) - (o : 'value_val_opt_override) - (_loc : Gram.Loc.t) -> - (if o <> Ast.OvNil - then - raise - (Stream.Error - "override (!) is incompatible with virtual") - else Ast.CrVvr (_loc, l, mf, t) : - 'class_str_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val_opt_override : - 'value_val_opt_override Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_mutable : 'opt_mutable Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (cvalue_binding : - 'cvalue_binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'cvalue_binding) (lab : 'label) - (mf : 'opt_mutable) - (o : 'value_val_opt_override) - (_loc : Gram.Loc.t) -> - (Ast.CrVal (_loc, lab, o, mf, e) : - 'class_str_item)))); - ([ Gram.Skeyword "inherit"; - Gram.Snterm - (Gram.Entry.obj - (opt_override : - 'opt_override Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_expr : 'class_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_as_lident : - 'opt_as_lident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (pb : 'opt_as_lident) (ce : 'class_expr) - (o : 'opt_override) _ (_loc : Gram.Loc.t) - -> - (Ast.CrInh (_loc, o, ce, pb) : - 'class_str_item)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_str_item_tag : - 'class_str_item) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "cst" | "anti" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "cst" | "anti" | "list" as n)), - s) -> - (Ast.CrAnt (_loc, - (mk_anti ~c: "class_str_item" n s)) : - 'class_str_item) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (method_opt_override : 'method_opt_override Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "method" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.OvNil : 'method_opt_override)))); - ([ Gram.Skeyword "method"; - Gram.Stoken - (((function - | ANTIQUOT (("!" | "override" | "anti"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("!" | "override" | "anti" as n)), s) - -> - (Ast.OvAnt (mk_anti n s) : - 'method_opt_override) - | _ -> assert false))); - ([ Gram.Skeyword "method"; Gram.Skeyword "!" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.OvOverride : 'method_opt_override)))) ]) ])) - ()); - Gram.extend - (value_val_opt_override : - 'value_val_opt_override Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.OvNil : 'value_val_opt_override)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Stoken - (((function - | ANTIQUOT (("!" | "override" | "anti"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("!" | "override" | "anti" as n)), s) - -> - (Ast.OvAnt (mk_anti n s) : - 'value_val_opt_override) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Skeyword "!" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (Ast.OvOverride : 'value_val_opt_override)))) ]) ])) - ()); - Gram.extend (opt_as_lident : 'opt_as_lident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - ("" : 'opt_as_lident)))); - ([ Gram.Skeyword "as"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) _ (_loc : Gram.Loc.t) -> - (i : 'opt_as_lident)))) ]) ])) - ()); - Gram.extend (opt_polyt : 'opt_polyt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.TyNil _loc : 'opt_polyt)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (_loc : Gram.Loc.t) -> - (t : 'opt_polyt)))) ]) ])) - ()); - Gram.extend (cvalue_binding : 'cvalue_binding Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword ":>"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (t : 'ctyp) _ - (_loc : Gram.Loc.t) -> - (Ast.ExCoe (_loc, e, (Ast.TyNil _loc), t) : - 'cvalue_binding)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)); - Gram.Skeyword ":>"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (t2 : 'ctyp) _ - (t : 'poly_type) _ (_loc : Gram.Loc.t) -> - (match t with - | Ast.TyPol (_, _, _) -> - raise - (Stream.Error - "unexpected polytype here") - | _ -> Ast.ExCoe (_loc, e, t, t2) : - 'cvalue_binding)))); - ([ Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (t : 'poly_type) _ - (_loc : Gram.Loc.t) -> - (Ast.ExTyc (_loc, e, t) : 'cvalue_binding)))); - ([ Gram.Skeyword ":"; Gram.Skeyword "type"; - Gram.Snterm - (Gram.Entry.obj - (unquoted_typevars : - 'unquoted_typevars Gram.Entry.t)); - Gram.Skeyword "."; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (t2 : 'ctyp) _ - (t1 : 'unquoted_typevars) _ _ - (_loc : Gram.Loc.t) -> - (let u = Ast.TyTypePol (_loc, t1, t2) - in Ast.ExTyc (_loc, e, u) : - 'cvalue_binding)))); - ([ Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (e : 'cvalue_binding)))) ]) ])) - ()); - Gram.extend (label : 'label Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (i : 'label)))) ]) ])) - ()); - Gram.extend (class_type : 'class_type Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "object"; - Gram.Snterm - (Gram.Entry.obj - (opt_class_self_type : - 'opt_class_self_type Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (class_signature : - 'class_signature Gram.Entry.t)); - Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (csg : 'class_signature) - (cst : 'opt_class_self_type) _ - (_loc : Gram.Loc.t) -> - (Ast.CtSig (_loc, cst, csg) : 'class_type)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_type_longident_and_param : - 'class_type_longident_and_param Gram. - Entry.t)) ], - (Gram.Action.mk - (fun (ct : 'class_type_longident_and_param) - (_loc : Gram.Loc.t) -> (ct : 'class_type)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_type_tag : - 'class_type) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "ctyp" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"ctyp\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "ctyp" | "anti" as n)), - s) -> - (Ast.CtAnt (_loc, - (mk_anti ~c: "class_type" n s)) : - 'class_type) - | _ -> assert false))) ]) ])) - ()); - Gram.extend - (class_type_longident_and_param : - 'class_type_longident_and_param Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_type_longident : - 'class_type_longident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'class_type_longident) - (_loc : Gram.Loc.t) -> - (Ast.CtCon (_loc, Ast.ViNil, i, - (Ast.TyNil _loc)) : - 'class_type_longident_and_param)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_type_longident : - 'class_type_longident Gram.Entry.t)); - Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (comma_ctyp : 'comma_ctyp Gram.Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (t : 'comma_ctyp) _ - (i : 'class_type_longident) - (_loc : Gram.Loc.t) -> - (Ast.CtCon (_loc, Ast.ViNil, i, t) : - 'class_type_longident_and_param)))) ]) ])) - ()); - Gram.extend (class_type_plus : 'class_type_plus Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_type : 'class_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ct : 'class_type) (_loc : Gram.Loc.t) -> - (ct : 'class_type_plus)))); - ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "]"; Gram.Skeyword "->"; Gram. - Sself ], - (Gram.Action.mk - (fun (ct : 'class_type_plus) _ _ (t : 'ctyp) _ - (_loc : Gram.Loc.t) -> - (Ast.CtFun (_loc, t, ct) : - 'class_type_plus)))) ]) ])) - ()); - Gram.extend - (opt_class_self_type : 'opt_class_self_type Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.TyNil _loc : 'opt_class_self_type)))); - ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 'ctyp) _ (_loc : Gram.Loc.t) -> - (t : 'opt_class_self_type)))) ]) ])) - ()); - Gram.extend (class_signature : 'class_signature Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist0 - (Gram.srules class_signature - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_sig_item : - 'class_sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (csg : 'class_sig_item) - (_loc : Gram.Loc.t) -> - (csg : 'e__11)))) ]) ], - (Gram.Action.mk - (fun (l : 'e__11 list) (_loc : Gram.Loc.t) -> - (Ast.cgSem_of_list l : 'class_signature)))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "csg" | "anti" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (csg : 'class_signature) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "csg" | "anti" | "list" as n)), - s) -> - (Ast.CgSem (_loc, - (Ast.CgAnt (_loc, - (mk_anti ~c: "class_sig_item" n s))), - csg) : - 'class_signature) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "csg" | "anti" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "csg" | "anti" | "list" as n)), - s) -> - (Ast.CgAnt (_loc, - (mk_anti ~c: "class_sig_item" n s)) : - 'class_signature) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (class_sig_item : 'class_sig_item Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_constraint : - 'type_constraint Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ - (_loc : Gram.Loc.t) -> - (Ast.CgCtr (_loc, t1, t2) : - 'class_sig_item)))); - ([ Gram.Skeyword "method"; - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) _ - (pf : 'opt_private) _ (_loc : Gram.Loc.t) - -> - (Ast.CgVir (_loc, l, pf, t) : - 'class_sig_item)))); - ([ Gram.Skeyword "method"; - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) - (pf : 'opt_private) _ (_loc : Gram.Loc.t) - -> - (Ast.CgMth (_loc, l, pf, t) : - 'class_sig_item)))); - ([ Gram.Skeyword "method"; - Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (l : 'label) - (pf : 'opt_private) _ _ (_loc : Gram.Loc.t) - -> - (Ast.CgVir (_loc, l, pf, t) : - 'class_sig_item)))); - ([ Gram.Snterm - (Gram.Entry.obj - (value_val : 'value_val Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_mutable : 'opt_mutable Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_virtual : 'opt_virtual Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (l : 'label) - (mv : 'opt_virtual) (mf : 'opt_mutable) _ - (_loc : Gram.Loc.t) -> - (Ast.CgVal (_loc, l, mf, mv, t) : - 'class_sig_item)))); - ([ Gram.Skeyword "inherit"; - Gram.Snterm - (Gram.Entry.obj - (class_type : 'class_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (cs : 'class_type) _ (_loc : Gram.Loc.t) - -> (Ast.CgInh (_loc, cs) : 'class_sig_item)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_sig_item_tag : - 'class_sig_item) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "csg" | "anti" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "csg" | "anti" | "list" as n)), - s) -> - (Ast.CgAnt (_loc, - (mk_anti ~c: "class_sig_item" n s)) : - 'class_sig_item) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (type_constraint : 'type_constraint Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "constraint" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (() : 'type_constraint)))); - ([ Gram.Skeyword "type" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (() : 'type_constraint)))) ]) ])) - ()); - Gram.extend - (class_description : 'class_description Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_info_for_class_type : - 'class_info_for_class_type Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (class_type_plus : - 'class_type_plus Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ct : 'class_type_plus) _ - (ci : 'class_info_for_class_type) - (_loc : Gram.Loc.t) -> - (Ast.CtCol (_loc, ci, ct) : - 'class_description)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_type_tag : - 'class_description) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "typ" | "anti" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "typ" | "anti" | "list" as n)), - s) -> - (Ast.CtAnt (_loc, - (mk_anti ~c: "class_type" n s)) : - 'class_description) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (cd2 : 'class_description) _ - (cd1 : 'class_description) - (_loc : Gram.Loc.t) -> - (Ast.CtAnd (_loc, cd1, cd2) : - 'class_description)))) ]) ])) - ()); - Gram.extend - (class_type_declaration : - 'class_type_declaration Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (class_info_for_class_type : - 'class_info_for_class_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (class_type : 'class_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ct : 'class_type) _ - (ci : 'class_info_for_class_type) - (_loc : Gram.Loc.t) -> - (Ast.CtEq (_loc, ci, ct) : - 'class_type_declaration)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.class_type_tag : - 'class_type_declaration) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "typ" | "anti" | "list"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "typ" | "anti" | "list" as n)), - s) -> - (Ast.CtAnt (_loc, - (mk_anti ~c: "class_type" n s)) : - 'class_type_declaration) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (cd2 : 'class_type_declaration) _ - (cd1 : 'class_type_declaration) - (_loc : Gram.Loc.t) -> - (Ast.CtAnd (_loc, cd1, cd2) : - 'class_type_declaration)))) ]) ])) - ()); - Gram.extend (field_expr_list : 'field_expr_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (field_expr : 'field_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (b1 : 'field_expr) (_loc : Gram.Loc.t) -> - (b1 : 'field_expr_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (field_expr : 'field_expr Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (b1 : 'field_expr) (_loc : Gram.Loc.t) - -> (b1 : 'field_expr_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (field_expr : 'field_expr Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (b2 : 'field_expr_list) _ - (b1 : 'field_expr) (_loc : Gram.Loc.t) -> - (Ast.RbSem (_loc, b1, b2) : - 'field_expr_list)))) ]) ])) - ()); - Gram.extend (field_expr : 'field_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (label : 'label Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top") ], - (Gram.Action.mk - (fun (e : 'expr) _ (l : 'label) - (_loc : Gram.Loc.t) -> - (Ast.RbEq (_loc, (Ast.IdLid (_loc, l)), e) : - 'field_expr)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.RbAnt (_loc, - (mk_anti ~c: "rec_binding" n s)) : - 'field_expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "bi" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"bi\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "bi" | "anti" as n)), s) - -> - (Ast.RbAnt (_loc, - (mk_anti ~c: "rec_binding" n s)) : - 'field_expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (meth_list : 'meth_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (meth_decl : 'meth_decl Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], - (Gram.Action.mk - (fun (v : 'opt_dot_dot) (m : 'meth_decl) - (_loc : Gram.Loc.t) -> - ((m, v) : 'meth_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (meth_decl : 'meth_decl Gram.Entry.t)); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], - (Gram.Action.mk - (fun (v : 'opt_dot_dot) _ (m : 'meth_decl) - (_loc : Gram.Loc.t) -> - ((m, v) : 'meth_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (meth_decl : 'meth_decl Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun ((ml, v) : 'meth_list) _ (m : 'meth_decl) - (_loc : Gram.Loc.t) -> - (((Ast.TySem (_loc, m, ml)), v) : - 'meth_list)))) ]) ])) - ()); - Gram.extend (meth_decl : 'meth_decl Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (poly_type : 'poly_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'poly_type) _ (lab : 'a_LIDENT) - (_loc : Gram.Loc.t) -> - (Ast.TyCol (_loc, - (Ast.TyId (_loc, - (Ast.IdLid (_loc, lab)))), - t) : - 'meth_decl)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'meth_decl) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp;" n s)) : - 'meth_decl) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'meth_decl) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (opt_meth_list : 'opt_meth_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], - (Gram.Action.mk - (fun (v : 'opt_dot_dot) (_loc : Gram.Loc.t) -> - (Ast.TyObj (_loc, (Ast.TyNil _loc), v) : - 'opt_meth_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (meth_list : 'meth_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((ml, v) : 'meth_list) - (_loc : Gram.Loc.t) -> - (Ast.TyObj (_loc, ml, v) : 'opt_meth_list)))) ]) ])) - ()); - Gram.extend (poly_type : 'poly_type Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'poly_type)))) ]) ])) - ()); - Gram.extend (package_type : 'package_type Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'module_type) (_loc : Gram.Loc.t) -> - (p : 'package_type)))) ]) ])) - ()); - Gram.extend (typevars : 'typevars Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Skeyword "'"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyQuo (_loc, i) : 'typevars)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'typevars) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'typevars) - | _ -> assert false))); - ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'typevars) (t1 : 'typevars) - (_loc : Gram.Loc.t) -> - (Ast.TyApp (_loc, t1, t2) : 'typevars)))) ]) ])) - ()); - Gram.extend - (unquoted_typevars : 'unquoted_typevars Gram.Entry.t) - ((fun () -> - (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) (_loc : Gram.Loc.t) -> - (Ast.TyId (_loc, (Ast.IdLid (_loc, i))) : - 'unquoted_typevars)))); - ([ Gram.Stoken - (((function - | QUOTATION _ -> true - | _ -> false), - "QUOTATION _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | QUOTATION x -> - (Quotation.expand _loc x Quotation. - DynAst.ctyp_tag : - 'unquoted_typevars) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'unquoted_typevars) - | _ -> assert false))); - ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'unquoted_typevars) - (t1 : 'unquoted_typevars) - (_loc : Gram.Loc.t) -> - (Ast.TyApp (_loc, t1, t2) : - 'unquoted_typevars)))) ]) ])) - ()); - Gram.extend (row_field : 'row_field Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'row_field)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)); - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'amp_ctyp) _ (i : 'a_ident) _ - (_loc : Gram.Loc.t) -> - (Ast.TyOf (_loc, (Ast.TyVrn (_loc, i)), t) : - 'row_field)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)); - Gram.Skeyword "of"; Gram.Skeyword "&"; - Gram.Snterm - (Gram.Entry.obj - (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'amp_ctyp) _ _ (i : 'a_ident) _ - (_loc : Gram.Loc.t) -> - (Ast.TyOfAmp (_loc, (Ast.TyVrn (_loc, i)), - t) : - 'row_field)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyVrn (_loc, i) : 'row_field)))); - ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'row_field) _ (t1 : 'row_field) - (_loc : Gram.Loc.t) -> - (Ast.TyOr (_loc, t1, t2) : 'row_field)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp|" n s)) : - 'row_field) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'row_field) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (amp_ctyp : 'amp_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) (_loc : Gram.Loc.t) -> - (t : 'amp_ctyp)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("list", _) -> true - | _ -> false), - "ANTIQUOT (\"list\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("list" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp&" n s)) : - 'amp_ctyp) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "&"; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'amp_ctyp) _ (t1 : 'amp_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyAmp (_loc, t1, t2) : 'amp_ctyp)))) ]) ])) - ()); - Gram.extend (name_tags : 'name_tags Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyVrn (_loc, i) : 'name_tags)))); - ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (t2 : 'name_tags) (t1 : 'name_tags) - (_loc : Gram.Loc.t) -> - (Ast.TyApp (_loc, t1, t2) : 'name_tags)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "typ"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"typ\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "typ" as n)), s) -> - (Ast.TyAnt (_loc, - (mk_anti ~c: "ctyp" n s)) : - 'name_tags) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (eq_expr : 'eq_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (fun i p -> Ast.PaOlb (_loc, i, p) : - 'eq_expr)))); - ([ Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (fun i p -> Ast.PaOlbi (_loc, i, p, e) : - 'eq_expr)))) ]) ])) - ()); - Gram.extend (patt_tcon : 'patt_tcon Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) (_loc : Gram.Loc.t) -> - (p : 'patt_tcon)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (p : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, p, t) : 'patt_tcon)))) ]) ])) - ()); - Gram.extend (ipatt : 'ipatt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "?"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e : 'expr) _ (p : 'ipatt_tcon) _ _ - (_loc : Gram.Loc.t) -> - (Ast.PaOlbi (_loc, "", p, e) : 'ipatt)))); - ([ Gram.Skeyword "?"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'ipatt_tcon) _ _ - (_loc : Gram.Loc.t) -> - (Ast.PaOlb (_loc, "", p) : 'ipatt)))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaOlb (_loc, (mk_anti n i), - (Ast.PaNil _loc)) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function | LIDENT _ -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT i -> - (Ast.PaOlb (_loc, i, (Ast.PaNil _loc)) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")); - Gram.Skeyword ":"; Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (eq_expr : 'eq_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (f : 'eq_expr) (p : 'ipatt_tcon) _ _ - (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (f (mk_anti n i) p : 'ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function | OPTLABEL _ -> true | _ -> false), - "OPTLABEL _")); - Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj - (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (eq_expr : 'eq_expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (f : 'eq_expr) (p : 'ipatt_tcon) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | OPTLABEL i -> (f i p : 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function | LIDENT _ -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT i -> - (Ast.PaLab (_loc, i, (Ast.PaNil _loc)) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaLab (_loc, (mk_anti n i), - (Ast.PaNil _loc)) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")); - Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (p : 'ipatt) _ - (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), i) -> - (Ast.PaLab (_loc, (mk_anti n i), p) : - 'ipatt) - | _ -> assert false))); - ([ Gram.Stoken - (((function | LABEL _ -> true | _ -> false), - "LABEL _")); - Gram.Sself ], - (Gram.Action.mk - (fun (p : 'ipatt) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LABEL i -> - (Ast.PaLab (_loc, i, p) : 'ipatt) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (ipatt_tcon : 'ipatt_tcon Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'ipatt) (_loc : Gram.Loc.t) -> - (p : 'ipatt_tcon)))); - ([ Gram.Snterm - (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'ctyp) _ (p : 'ipatt) - (_loc : Gram.Loc.t) -> - (Ast.PaTyc (_loc, p, t) : 'ipatt_tcon)))) ]) ])) - ()); - Gram.extend (direction_flag : 'direction_flag Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | ANTIQUOT (("to" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"to\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("to" | "anti" as n)), s) -> - (Ast.DiAnt (mk_anti n s) : - 'direction_flag) - | _ -> assert false))); - ([ Gram.Skeyword "downto" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.DiDownto : 'direction_flag)))); - ([ Gram.Skeyword "to" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.DiTo : 'direction_flag)))) ]) ])) - ()); - Gram.extend (opt_private : 'opt_private Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.PrNil : 'opt_private)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("private" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"private\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("private" | "anti" as n)), s) - -> - (Ast.PrAnt (mk_anti n s) : - 'opt_private) - | _ -> assert false))); - ([ Gram.Skeyword "private" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.PrPrivate : 'opt_private)))) ]) ])) - ()); - Gram.extend (opt_mutable : 'opt_mutable Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.MuNil : 'opt_mutable)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("mutable" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"mutable\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("mutable" | "anti" as n)), s) - -> - (Ast.MuAnt (mk_anti n s) : - 'opt_mutable) - | _ -> assert false))); - ([ Gram.Skeyword "mutable" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.MuMutable : 'opt_mutable)))) ]) ])) - ()); - Gram.extend (opt_virtual : 'opt_virtual Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.ViNil : 'opt_virtual)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("virtual" | "anti"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"virtual\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("virtual" | "anti" as n)), s) - -> - (Ast.ViAnt (mk_anti n s) : - 'opt_virtual) - | _ -> assert false))); - ([ Gram.Skeyword "virtual" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.ViVirtual : 'opt_virtual)))) ]) ])) - ()); - Gram.extend (opt_dot_dot : 'opt_dot_dot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.RvNil : 'opt_dot_dot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ((".." | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"..\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT (((".." | "anti" as n)), s) -> - (Ast.RvAnt (mk_anti n s) : - 'opt_dot_dot) - | _ -> assert false))); - ([ Gram.Skeyword ".." ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.RvRowVar : 'opt_dot_dot)))) ]) ])) - ()); - Gram.extend (opt_rec : 'opt_rec Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.ReNil : 'opt_rec)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("rec" | "anti"), _) -> true - | _ -> false), - "ANTIQUOT ((\"rec\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("rec" | "anti" as n)), s) -> - (Ast.ReAnt (mk_anti n s) : 'opt_rec) - | _ -> assert false))); - ([ Gram.Skeyword "rec" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.ReRecursive : 'opt_rec)))) ]) ])) - ()); - Gram.extend (opt_override : 'opt_override Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.OvNil : 'opt_override)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("!" | "override" | "anti"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"!\" | \"override\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("!" | "override" | "anti" as n)), s) - -> - (Ast.OvAnt (mk_anti n s) : - 'opt_override) - | _ -> assert false))); - ([ Gram.Skeyword "!" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.OvOverride : 'opt_override)))) ]) ])) - ()); - Gram.extend (opt_expr : 'opt_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.ExNil _loc : 'opt_expr)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (e : 'opt_expr)))) ]) ])) - ()); - Gram.extend (interf : 'interf Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | EOI -> true | _ -> false), - "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (([], None) : 'interf) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (sig_item : 'sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun ((sil, stopped) : 'interf) _ - (si : 'sig_item) (_loc : Gram.Loc.t) -> - (((si :: sil), stopped) : 'interf)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (([ Ast.SgDir (_loc, n, dp) ], - (stopped_at _loc)) : 'interf)))) ]) ])) - ()); - Gram.extend (sig_items : 'sig_items Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist0 - (Gram.srules sig_items - [ ([ Gram.Snterm - (Gram.Entry.obj - (sig_item : - 'sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (sg : 'sig_item) - (_loc : Gram.Loc.t) -> - (sg : 'e__12)))) ]) ], - (Gram.Action.mk - (fun (l : 'e__12 list) (_loc : Gram.Loc.t) -> - (Ast.sgSem_of_list l : 'sig_items)))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "sigi" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (sg : 'sig_items) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "sigi" | "anti" | "list" as n)), - s) -> - (Ast.SgSem (_loc, - (Ast.SgAnt (_loc, - (mk_anti n ~c: "sig_item" s))), - sg) : - 'sig_items) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "sigi" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "sigi" | "anti" | "list" as n)), - s) -> - (Ast.SgAnt (_loc, - (mk_anti n ~c: "sig_item" s)) : - 'sig_items) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (implem : 'implem Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | EOI -> true | _ -> false), - "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (([], None) : 'implem) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (str_item : 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun ((sil, stopped) : 'implem) _ - (si : 'str_item) (_loc : Gram.Loc.t) -> - (((si :: sil), stopped) : 'implem)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (([ Ast.StDir (_loc, n, dp) ], - (stopped_at _loc)) : 'implem)))) ]) ])) - ()); - Gram.extend (str_items : 'str_items Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist0 - (Gram.srules str_items - [ ([ Gram.Snterm - (Gram.Entry.obj - (str_item : - 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (st : 'str_item) - (_loc : Gram.Loc.t) -> - (st : 'e__13)))) ]) ], - (Gram.Action.mk - (fun (l : 'e__13 list) (_loc : Gram.Loc.t) -> - (Ast.stSem_of_list l : 'str_items)))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "stri" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (st : 'str_items) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "stri" | "anti" | "list" as n)), - s) -> - (Ast.StSem (_loc, - (Ast.StAnt (_loc, - (mk_anti n ~c: "str_item" s))), - st) : - 'str_items) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "stri" | "anti" | "list"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "stri" | "anti" | "list" as n)), - s) -> - (Ast.StAnt (_loc, - (mk_anti n ~c: "str_item" s)) : - 'str_items) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (top_phrase : 'top_phrase Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | EOI -> true | _ -> false), - "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (None : 'top_phrase) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (phrase : 'phrase Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ph : 'phrase) (_loc : Gram.Loc.t) -> - (Some ph : 'top_phrase)))) ]) ])) - ()); - Gram.extend (use_file : 'use_file Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | EOI -> true | _ -> false), - "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (([], None) : 'use_file) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (str_item : 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun ((sil, stopped) : 'use_file) _ - (si : 'str_item) (_loc : Gram.Loc.t) -> - (((si :: sil), stopped) : 'use_file)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (([ Ast.StDir (_loc, n, dp) ], - (stopped_at _loc)) : 'use_file)))) ]) ])) - ()); - Gram.extend (phrase : 'phrase Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (str_item : 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (st : 'str_item) (_loc : Gram.Loc.t) -> - (st : 'phrase)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.StDir (_loc, n, dp) : 'phrase)))) ]) ])) - ()); - Gram.extend (a_INT : 'a_INT Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | INT (_, _) -> true | _ -> false), - "INT (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | INT (_, s) -> (s : 'a_INT) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "int" | "`int"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"int\" | \"`int\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "int" | "`int" as n)), - s) -> (mk_anti n s : 'a_INT) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_INT32 : 'a_INT32 Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | INT32 (_, _) -> true - | _ -> false), - "INT32 (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | INT32 (_, s) -> (s : 'a_INT32) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "int32" | "`int32"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"int32\" | \"`int32\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "int32" | "`int32" as n)), s) - -> (mk_anti n s : 'a_INT32) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_INT64 : 'a_INT64 Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | INT64 (_, _) -> true - | _ -> false), - "INT64 (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | INT64 (_, s) -> (s : 'a_INT64) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "int64" | "`int64"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"int64\" | \"`int64\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "int64" | "`int64" as n)), s) - -> (mk_anti n s : 'a_INT64) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | NATIVEINT (_, _) -> true - | _ -> false), - "NATIVEINT (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | NATIVEINT (_, s) -> (s : 'a_NATIVEINT) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT - (("" | "nativeint" | "`nativeint"), _) - -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"nativeint\" | \"`nativeint\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "nativeint" | "`nativeint" as - n)), - s) -> (mk_anti n s : 'a_NATIVEINT) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_FLOAT : 'a_FLOAT Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | FLOAT (_, _) -> true - | _ -> false), - "FLOAT (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | FLOAT (_, s) -> (s : 'a_FLOAT) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "flo" | "`flo"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"flo\" | \"`flo\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "flo" | "`flo" as n)), - s) -> (mk_anti n s : 'a_FLOAT) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_CHAR : 'a_CHAR Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | CHAR (_, _) -> true - | _ -> false), - "CHAR (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | CHAR (_, s) -> (s : 'a_CHAR) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "chr" | "`chr"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"chr\" | \"`chr\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "chr" | "`chr" as n)), - s) -> (mk_anti n s : 'a_CHAR) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_UIDENT : 'a_UIDENT Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | UIDENT _ -> true | _ -> false), - "UIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT s -> (s : 'a_UIDENT) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "uid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"uid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "uid" as n)), s) -> - (mk_anti n s : 'a_UIDENT) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_LIDENT : 'a_LIDENT Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | LIDENT _ -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT s -> (s : 'a_LIDENT) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "lid"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"lid\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "lid" as n)), s) -> - (mk_anti n s : 'a_LIDENT) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_LABEL : 'a_LABEL Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | LABEL _ -> true | _ -> false), - "LABEL _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LABEL s -> (s : 'a_LABEL) - | _ -> assert false))); - ([ Gram.Skeyword "~"; - Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")); - Gram.Skeyword ":" ], - (Gram.Action.mk - (fun _ (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), s) -> - (mk_anti n s : 'a_LABEL) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | OPTLABEL _ -> true | _ -> false), - "OPTLABEL _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | OPTLABEL s -> (s : 'a_OPTLABEL) - | _ -> assert false))); - ([ Gram.Skeyword "?"; - Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")); - Gram.Skeyword ":" ], - (Gram.Action.mk - (fun _ (__camlp4_0 : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), s) -> - (mk_anti n s : 'a_OPTLABEL) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (a_STRING : 'a_STRING Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | STRING (_, _) -> true - | _ -> false), - "STRING (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | STRING (_, s) -> (s : 'a_STRING) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "str" | "`str"), _) -> - true - | _ -> false), - "ANTIQUOT ((\"\" | \"str\" | \"`str\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" | "str" | "`str" as n)), - s) -> (mk_anti n s : 'a_STRING) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (string_list : 'string_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | STRING (_, _) -> true - | _ -> false), - "STRING (_, _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | STRING (_, x) -> - (Ast.LCons (x, Ast.LNil) : - 'string_list) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | STRING (_, _) -> true - | _ -> false), - "STRING (_, _)")); - Gram.Sself ], - (Gram.Action.mk - (fun (xs : 'string_list) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | STRING (_, x) -> - (Ast.LCons (x, xs) : 'string_list) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "str_list"), _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"str_list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT (("" | "str_list"), s) -> - (Ast.LAnt (mk_anti "str_list" s) : - 'string_list) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (value_let : 'value_let Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "value" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (() : 'value_let)))) ]) ])) - ()); - Gram.extend (value_val : 'value_val Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "value" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (() : 'value_val)))) ]) ])) - ()); - Gram.extend (semi : 'semi Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> (() : 'semi)))) ]) ])) - ()); - Gram.extend (expr_quot : 'expr_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.ExNil _loc : 'expr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (e : 'expr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (sem_expr : 'sem_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e2 : 'sem_expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExSem (_loc, e1, e2) : 'expr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_expr : 'comma_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e2 : 'comma_expr) _ (e1 : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExCom (_loc, e1, e2) : 'expr_quot)))) ]) ])) - ()); - Gram.extend (patt_quot : 'patt_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.PaNil _loc : 'patt_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'patt) (_loc : Gram.Loc.t) -> - (x : 'patt_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'patt) _ (x : 'patt) - (_loc : Gram.Loc.t) -> - (let i = - match x with - | Ast.PaAnt (loc, s) -> - Ast.IdAnt (loc, s) - | p -> Ast.ident_of_patt p - in Ast.PaEq (_loc, i, y) : 'patt_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (sem_patt : 'sem_patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'sem_patt) _ (x : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaSem (_loc, x, y) : 'patt_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_patt : 'comma_patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'comma_patt) _ (x : 'patt) - (_loc : Gram.Loc.t) -> - (Ast.PaCom (_loc, x, y) : 'patt_quot)))) ]) ])) - ()); - Gram.extend (ctyp_quot : 'ctyp_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.TyNil _loc : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (x : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "and"; - Gram.Snterm - (Gram.Entry.obj - (constructor_arg_list : - 'constructor_arg_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'constructor_arg_list) _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TyAnd (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "&"; - Gram.Snterm - (Gram.Entry.obj - (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'amp_ctyp) _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyAmp (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "*"; - Gram.Snterm - (Gram.Entry.obj - (star_ctyp : 'star_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'star_ctyp) _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TySta (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (label_declaration_list : - 'label_declaration_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (z : 'label_declaration_list) _ - (y : 'more_ctyp) _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TySem (_loc, (Ast.TyCol (_loc, x, y)), - z) : - 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'more_ctyp) _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyCol (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "of"; Gram.Skeyword "&"; - Gram.Snterm - (Gram.Entry.obj - (amp_ctyp : 'amp_ctyp Gram.Entry.t)); - Gram.Skeyword "|"; - Gram.Snterm - (Gram.Entry.obj - (row_field : 'row_field Gram.Entry.t)) ], - (Gram.Action.mk - (fun (z : 'row_field) _ (y : 'amp_ctyp) _ _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TyOr (_loc, - (Ast.TyOfAmp (_loc, x, y)), z) : - 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "of"; Gram.Skeyword "&"; - Gram.Snterm - (Gram.Entry.obj - (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'amp_ctyp) _ _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyOfAmp (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (constructor_arg_list : - 'constructor_arg_list Gram.Entry.t)); - Gram.Skeyword "|"; - Gram.Snterm - (Gram.Entry.obj - (constructor_declarations : - 'constructor_declarations Gram.Entry.t)) ], - (Gram.Action.mk - (fun (z : 'constructor_declarations) _ - (y : 'constructor_arg_list) _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TyOr (_loc, (Ast.TyOf (_loc, x, y)), - z) : - 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "of"; - Gram.Snterm - (Gram.Entry.obj - (constructor_arg_list : - 'constructor_arg_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'constructor_arg_list) _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TyOf (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword "|"; - Gram.Snterm - (Gram.Entry.obj - (constructor_declarations : - 'constructor_declarations Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'constructor_declarations) _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TyOr (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (label_declaration_list : - 'label_declaration_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'label_declaration_list) _ - (x : 'more_ctyp) (_loc : Gram.Loc.t) -> - (Ast.TySem (_loc, x, y) : 'ctyp_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (more_ctyp : 'more_ctyp Gram.Entry.t)); - Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_ctyp : 'comma_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (y : 'comma_ctyp) _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> - (Ast.TyCom (_loc, x, y) : 'ctyp_quot)))) ]) ])) - ()); - Gram.extend (more_ctyp : 'more_ctyp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (type_parameter : - 'type_parameter Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'type_parameter) (_loc : Gram.Loc.t) - -> (x : 'more_ctyp)))); - ([ Gram.Snterm - (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'ctyp) (_loc : Gram.Loc.t) -> - (x : 'more_ctyp)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.TyVrn (_loc, x) : 'more_ctyp)))); - ([ Gram.Skeyword "mutable"; Gram.Sself ], - (Gram.Action.mk - (fun (x : 'more_ctyp) _ (_loc : Gram.Loc.t) -> - (Ast.TyMut (_loc, x) : 'more_ctyp)))) ]) ])) - ()); - Gram.extend (str_item_quot : 'str_item_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.StNil _loc : 'str_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (str_item : 'str_item Gram.Entry.t)) ], - (Gram.Action.mk - (fun (st : 'str_item) (_loc : Gram.Loc.t) -> - (st : 'str_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (str_item : 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (st2 : 'str_item_quot) _ - (st1 : 'str_item) (_loc : Gram.Loc.t) -> - (match st2 with - | Ast.StNil _ -> st1 - | _ -> Ast.StSem (_loc, st1, st2) : - 'str_item_quot)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.StDir (_loc, n, dp) : 'str_item_quot)))) ]) ])) - ()); - Gram.extend (sig_item_quot : 'sig_item_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.SgNil _loc : 'sig_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (sig_item : 'sig_item Gram.Entry.t)) ], - (Gram.Action.mk - (fun (sg : 'sig_item) (_loc : Gram.Loc.t) -> - (sg : 'sig_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (sig_item : 'sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (sg2 : 'sig_item_quot) _ - (sg1 : 'sig_item) (_loc : Gram.Loc.t) -> - (match sg2 with - | Ast.SgNil _ -> sg1 - | _ -> Ast.SgSem (_loc, sg1, sg2) : - 'sig_item_quot)))); - ([ Gram.Skeyword "#"; - Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_expr : 'opt_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (dp : 'opt_expr) (n : 'a_LIDENT) _ - (_loc : Gram.Loc.t) -> - (Ast.SgDir (_loc, n, dp) : 'sig_item_quot)))) ]) ])) - ()); - Gram.extend - (module_type_quot : 'module_type_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.MtNil _loc : 'module_type_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'module_type) (_loc : Gram.Loc.t) -> - (x : 'module_type_quot)))) ]) ])) - ()); - Gram.extend - (module_expr_quot : 'module_expr_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.MeNil _loc : 'module_expr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'module_expr) (_loc : Gram.Loc.t) -> - (x : 'module_expr_quot)))) ]) ])) - ()); - Gram.extend (match_case_quot : 'match_case_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.McNil _loc : 'match_case_quot)))); - ([ Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (match_case0 : - 'match_case0 Gram.Entry.t))), - (Gram.Skeyword "|")) ], - (Gram.Action.mk - (fun (x : 'match_case0 list) - (_loc : Gram.Loc.t) -> - (Ast.mcOr_of_list x : 'match_case_quot)))) ]) ])) - ()); - Gram.extend (binding_quot : 'binding_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.BiNil _loc : 'binding_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (binding : 'binding Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'binding) (_loc : Gram.Loc.t) -> - (x : 'binding_quot)))) ]) ])) - ()); - Gram.extend - (rec_binding_quot : 'rec_binding_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.RbNil _loc : 'rec_binding_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (label_expr_list : - 'label_expr_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'label_expr_list) - (_loc : Gram.Loc.t) -> - (x : 'rec_binding_quot)))) ]) ])) - ()); - Gram.extend - (module_binding_quot : 'module_binding_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.MbNil _loc : 'module_binding_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (mt : 'module_type) - _ (m : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.MbColEq (_loc, m, mt, me) : - 'module_binding_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ (m : 'a_UIDENT) - (_loc : Gram.Loc.t) -> - (Ast.MbCol (_loc, m, mt) : - 'module_binding_quot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (module_expr : 'module_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (me : 'module_expr) _ (mt : 'module_type) - _ (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), m) -> - (Ast.MbColEq (_loc, (mk_anti n m), mt, - me) : - 'module_binding_quot) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (module_type : 'module_type Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mt : 'module_type) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), m) -> - (Ast.MbCol (_loc, (mk_anti n m), mt) : - 'module_binding_quot) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("" as n)), s) -> - (Ast.MbAnt (_loc, - (mk_anti ~c: "module_binding" n s)) : - 'module_binding_quot) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("module_binding" | "anti"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"module_binding\" | \"anti\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("module_binding" | "anti" as n)), s) - -> - (Ast.MbAnt (_loc, - (mk_anti ~c: "module_binding" n s)) : - 'module_binding_quot) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (b2 : 'module_binding_quot) _ - (b1 : 'module_binding_quot) - (_loc : Gram.Loc.t) -> - (Ast.MbAnd (_loc, b1, b2) : - 'module_binding_quot)))) ]) ])) - ()); - Gram.extend (ident_quot : 'ident_quot Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "apply"), None, - [ ([ Gram.Sself; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'ident_quot) (i : 'ident_quot) - (_loc : Gram.Loc.t) -> - (Ast.IdApp (_loc, i, j) : 'ident_quot)))) ]); - ((Some "."), None, - [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (j : 'ident_quot) _ (i : 'ident_quot) - (_loc : Gram.Loc.t) -> - (Ast.IdAcc (_loc, i, j) : 'ident_quot)))) ]); - ((Some "simple"), None, - [ ([ Gram.Skeyword "("; Gram.Sself; - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (i : 'ident_quot) _ (_loc : Gram.Loc.t) - -> (i : 'ident_quot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (i : 'ident_quot) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAcc (_loc, - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s))), - i) : - 'ident_quot) - | _ -> assert false))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdLid (_loc, i) : 'ident_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.IdUid (_loc, i) : 'ident_quot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT (("" | "id" | "anti" | "list"), - _) -> true - | _ -> false), - "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT - ((("" | "id" | "anti" | "list" as n)), - s) -> - (Ast.IdAnt (_loc, - (mk_anti ~c: "ident" n s)) : - 'ident_quot) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (class_expr_quot : 'class_expr_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.CeNil _loc : 'class_expr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_expr : 'class_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'class_expr) (_loc : Gram.Loc.t) -> - (x : 'class_expr_quot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("virtual", _) -> true - | _ -> false), - "ANTIQUOT (\"virtual\", _)")); - Gram.Snterm - (Gram.Entry.obj (ident : 'ident Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_comma_ctyp : - 'opt_comma_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ot : 'opt_comma_ctyp) (i : 'ident) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("virtual" as n)), s) -> - (let anti = - Ast.ViAnt - (mk_anti ~c: "class_expr" n s) - in Ast.CeCon (_loc, anti, i, ot) : - 'class_expr_quot) - | _ -> assert false))); - ([ Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj - (class_name_and_param : - 'class_name_and_param Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((i, ot) : 'class_name_and_param) _ - (_loc : Gram.Loc.t) -> - (Ast.CeCon (_loc, Ast.ViVirtual, - (Ast.IdLid (_loc, i)), ot) : - 'class_expr_quot)))); - ([ Gram.Sself; Gram.Skeyword "="; Gram.Sself ], - (Gram.Action.mk - (fun (ce2 : 'class_expr_quot) _ - (ce1 : 'class_expr_quot) - (_loc : Gram.Loc.t) -> - (Ast.CeEq (_loc, ce1, ce2) : - 'class_expr_quot)))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (ce2 : 'class_expr_quot) _ - (ce1 : 'class_expr_quot) - (_loc : Gram.Loc.t) -> - (Ast.CeAnd (_loc, ce1, ce2) : - 'class_expr_quot)))) ]) ])) - ()); - Gram.extend (class_type_quot : 'class_type_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.CtNil _loc : 'class_type_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_type_plus : - 'class_type_plus Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'class_type_plus) - (_loc : Gram.Loc.t) -> - (x : 'class_type_quot)))); - ([ Gram.Stoken - (((function - | ANTIQUOT ("virtual", _) -> true - | _ -> false), - "ANTIQUOT (\"virtual\", _)")); - Gram.Snterm - (Gram.Entry.obj (ident : 'ident Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_comma_ctyp : - 'opt_comma_ctyp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ot : 'opt_comma_ctyp) (i : 'ident) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ((("virtual" as n)), s) -> - (let anti = - Ast.ViAnt - (mk_anti ~c: "class_type" n s) - in Ast.CtCon (_loc, anti, i, ot) : - 'class_type_quot) - | _ -> assert false))); - ([ Gram.Skeyword "virtual"; - Gram.Snterm - (Gram.Entry.obj - (class_name_and_param : - 'class_name_and_param Gram.Entry.t)) ], - (Gram.Action.mk - (fun ((i, ot) : 'class_name_and_param) _ - (_loc : Gram.Loc.t) -> - (Ast.CtCon (_loc, Ast.ViVirtual, - (Ast.IdLid (_loc, i)), ot) : - 'class_type_quot)))); - ([ Gram.Sself; Gram.Skeyword ":"; Gram.Sself ], - (Gram.Action.mk - (fun (ct2 : 'class_type_quot) _ - (ct1 : 'class_type_quot) - (_loc : Gram.Loc.t) -> - (Ast.CtCol (_loc, ct1, ct2) : - 'class_type_quot)))); - ([ Gram.Sself; Gram.Skeyword "="; Gram.Sself ], - (Gram.Action.mk - (fun (ct2 : 'class_type_quot) _ - (ct1 : 'class_type_quot) - (_loc : Gram.Loc.t) -> - (Ast.CtEq (_loc, ct1, ct2) : - 'class_type_quot)))); - ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], - (Gram.Action.mk - (fun (ct2 : 'class_type_quot) _ - (ct1 : 'class_type_quot) - (_loc : Gram.Loc.t) -> - (Ast.CtAnd (_loc, ct1, ct2) : - 'class_type_quot)))) ]) ])) - ()); - Gram.extend - (class_str_item_quot : 'class_str_item_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.CrNil _loc : 'class_str_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_str_item : - 'class_str_item Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'class_str_item) (_loc : Gram.Loc.t) - -> (x : 'class_str_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_str_item : - 'class_str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (x2 : 'class_str_item_quot) _ - (x1 : 'class_str_item) (_loc : Gram.Loc.t) - -> - (match x2 with - | Ast.CrNil _ -> x1 - | _ -> Ast.CrSem (_loc, x1, x2) : - 'class_str_item_quot)))) ]) ])) - ()); - Gram.extend - (class_sig_item_quot : 'class_sig_item_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.CgNil _loc : 'class_sig_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_sig_item : - 'class_sig_item Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'class_sig_item) (_loc : Gram.Loc.t) - -> (x : 'class_sig_item_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (class_sig_item : - 'class_sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (x2 : 'class_sig_item_quot) _ - (x1 : 'class_sig_item) (_loc : Gram.Loc.t) - -> - (match x2 with - | Ast.CgNil _ -> x1 - | _ -> Ast.CgSem (_loc, x1, x2) : - 'class_sig_item_quot)))) ]) ])) - ()); - Gram.extend - (with_constr_quot : 'with_constr_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.WcNil _loc : 'with_constr_quot)))); - ([ Gram.Snterm - (Gram.Entry.obj - (with_constr : 'with_constr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'with_constr) (_loc : Gram.Loc.t) -> - (x : 'with_constr_quot)))) ]) ])) - ()); - Gram.extend (rec_flag_quot : 'rec_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_rec : 'opt_rec Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_rec) (_loc : Gram.Loc.t) -> - (x : 'rec_flag_quot)))) ]) ])) - ()); - Gram.extend - (direction_flag_quot : 'direction_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (direction_flag : - 'direction_flag Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'direction_flag) (_loc : Gram.Loc.t) - -> (x : 'direction_flag_quot)))) ]) ])) - ()); - Gram.extend - (mutable_flag_quot : 'mutable_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_mutable : 'opt_mutable Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_mutable) (_loc : Gram.Loc.t) -> - (x : 'mutable_flag_quot)))) ]) ])) - ()); - Gram.extend - (private_flag_quot : 'private_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_private : 'opt_private Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_private) (_loc : Gram.Loc.t) -> - (x : 'private_flag_quot)))) ]) ])) - ()); - Gram.extend - (virtual_flag_quot : 'virtual_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_virtual : 'opt_virtual Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_virtual) (_loc : Gram.Loc.t) -> - (x : 'virtual_flag_quot)))) ]) ])) - ()); - Gram.extend - (row_var_flag_quot : 'row_var_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_dot_dot) (_loc : Gram.Loc.t) -> - (x : 'row_var_flag_quot)))) ]) ])) - ()); - Gram.extend - (override_flag_quot : 'override_flag_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (opt_override : - 'opt_override Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'opt_override) (_loc : Gram.Loc.t) - -> (x : 'override_flag_quot)))) ]) ])) - ()); - Gram.extend (patt_eoi : 'patt_eoi Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Stoken - (((function | EOI -> true | _ -> false), - "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) (x : 'patt) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (x : 'patt_eoi) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (expr_eoi : 'expr_eoi Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Stoken - (((function | EOI -> true | _ -> false), - "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) (x : 'expr) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (x : 'expr_eoi) - | _ -> assert false))) ]) ])) - ())) - in apply () - - end - - let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () - - end - -module Camlp4QuotationCommon = - struct - open Camlp4 - - (* -*- camlp4r -*- *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2002-2006 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 OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Nicolas Pouillard: initial version - *) - module Id = - struct - let name = "Camlp4QuotationCommon" - - let version = Sys.ocaml_version - - end - - module Make - (Syntax : Sig.Camlp4Syntax) - (TheAntiquotSyntax : Sig.Parser(Syntax.Ast).SIMPLE) = - struct - open Sig - - include Syntax - - (* Be careful an AntiquotSyntax module appears here *) - module MetaLocHere = Ast.Meta.MetaLoc - - module MetaLoc = - struct - module Ast = Ast - - let loc_name = ref None - - let meta_loc_expr _loc loc = - match !loc_name with - | None -> Ast.ExId (_loc, (Ast.IdLid (_loc, !Loc.name))) - | Some "here" -> MetaLocHere.meta_loc_expr _loc loc - | Some x -> Ast.ExId (_loc, (Ast.IdLid (_loc, x))) - - let meta_loc_patt _loc _ = Ast.PaAny _loc - - end - - module MetaAst = Ast.Meta.Make(MetaLoc) - - module ME = MetaAst.Expr - - module MP = MetaAst.Patt - - let is_antiquot s = - let len = String.length s - in (len > 2) && ((s.[0] = '\\') && (s.[1] = '$')) - - let handle_antiquot_in_string s term parse loc decorate = - if is_antiquot s - then - (let pos = String.index s ':' in - let name = String.sub s 2 (pos - 2) - and code = - String.sub s (pos + 1) (((String.length s) - pos) - 1) - in decorate name (parse loc code)) - else term - - let antiquot_expander = - object - inherit Ast.map as super - method patt = - function - | (Ast.PaAnt (_loc, s) | Ast.PaStr (_loc, s) as p) -> - let mloc _loc = MetaLoc.meta_loc_patt _loc _loc - in - handle_antiquot_in_string s p TheAntiquotSyntax. - parse_patt _loc - (fun n p -> - match n with - | "antisig_item" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgAnt")))))), - (mloc _loc))), - p) - | "antistr_item" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StAnt")))))), - (mloc _loc))), - p) - | "antictyp" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAnt")))))), - (mloc _loc))), - p) - | "antipatt" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaAnt")))))), - (mloc _loc))), - p) - | "antiexpr" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAnt")))))), - (mloc _loc))), - p) - | "antimodule_type" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtAnt")))))), - (mloc _loc))), - p) - | "antimodule_expr" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeAnt")))))), - (mloc _loc))), - p) - | "anticlass_type" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtAnt")))))), - (mloc _loc))), - p) - | "anticlass_expr" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeAnt")))))), - (mloc _loc))), - p) - | "anticlass_sig_item" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgAnt")))))), - (mloc _loc))), - p) - | "anticlass_str_item" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrAnt")))))), - (mloc _loc))), - p) - | "antiwith_constr" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcAnt")))))), - (mloc _loc))), - p) - | "antibinding" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BiAnt")))))), - (mloc _loc))), - p) - | "antirec_binding" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RbAnt")))))), - (mloc _loc))), - p) - | "antimatch_case" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "McAnt")))))), - (mloc _loc))), - p) - | "antimodule_binding" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbAnt")))))), - (mloc _loc))), - p) - | "antiident" -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdAnt")))))), - (mloc _loc))), - p) - | _ -> p) - | p -> super#patt p - method expr = - function - | (Ast.ExAnt (_loc, s) | Ast.ExStr (_loc, s) as e) -> - let mloc _loc = MetaLoc.meta_loc_expr _loc _loc - in - handle_antiquot_in_string s e TheAntiquotSyntax. - parse_expr _loc - (fun n e -> - match n with - | "`int" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "string_of_int")))), - e) - | "`int32" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Int32")), - (Ast.IdLid (_loc, "to_string")))))), - e) - | "`int64" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Int64")), - (Ast.IdLid (_loc, "to_string")))))), - e) - | "`nativeint" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Nativeint")), - (Ast.IdLid (_loc, "to_string")))))), - e) - | "`flo" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4_import")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Oprint")), - (Ast.IdLid (_loc, "float_repres")))))))), - e) - | "`str" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "safe_string_escaped")))))), - e) - | "`chr" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Char")), - (Ast.IdLid (_loc, "escaped")))))), - e) - | "`bool" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdUid")))))), - (mloc _loc))), - (Ast.ExIfe (_loc, e, - (Ast.ExStr (_loc, "True")), - (Ast.ExStr (_loc, "False"))))) - | "liststr_item" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "stSem_of_list")))))), - e) - | "listsig_item" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "sgSem_of_list")))))), - e) - | "listclass_sig_item" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "cgSem_of_list")))))), - e) - | "listclass_str_item" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "crSem_of_list")))))), - e) - | "listmodule_expr" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "meApp_of_list")))))), - e) - | "listmodule_type" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "mtApp_of_list")))))), - e) - | "listmodule_binding" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "mbAnd_of_list")))))), - e) - | "listbinding" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "biAnd_of_list")))))), - e) - | "listbinding;" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "biSem_of_list")))))), - e) - | "listrec_binding" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "rbSem_of_list")))))), - e) - | "listclass_type" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "ctAnd_of_list")))))), - e) - | "listclass_expr" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "ceAnd_of_list")))))), - e) - | "listident" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "idAcc_of_list")))))), - e) - | "listctypand" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "tyAnd_of_list")))))), - e) - | "listctyp;" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "tySem_of_list")))))), - e) - | "listctyp*" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "tySta_of_list")))))), - e) - | "listctyp|" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "tyOr_of_list")))))), - e) - | "listctyp," -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "tyCom_of_list")))))), - e) - | "listctyp&" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "tyAmp_of_list")))))), - e) - | "listwith_constr" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "wcAnd_of_list")))))), - e) - | "listmatch_case" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "mcOr_of_list")))))), - e) - | "listpatt," -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "paCom_of_list")))))), - e) - | "listpatt;" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "paSem_of_list")))))), - e) - | "listexpr," -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "exCom_of_list")))))), - e) - | "listexpr;" -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdLid (_loc, "exSem_of_list")))))), - e) - | "antisig_item" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgAnt")))))), - (mloc _loc))), - e) - | "antistr_item" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StAnt")))))), - (mloc _loc))), - e) - | "antictyp" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAnt")))))), - (mloc _loc))), - e) - | "antipatt" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaAnt")))))), - (mloc _loc))), - e) - | "antiexpr" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAnt")))))), - (mloc _loc))), - e) - | "antimodule_type" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtAnt")))))), - (mloc _loc))), - e) - | "antimodule_expr" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeAnt")))))), - (mloc _loc))), - e) - | "anticlass_type" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtAnt")))))), - (mloc _loc))), - e) - | "anticlass_expr" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeAnt")))))), - (mloc _loc))), - e) - | "anticlass_sig_item" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgAnt")))))), - (mloc _loc))), - e) - | "anticlass_str_item" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrAnt")))))), - (mloc _loc))), - e) - | "antiwith_constr" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcAnt")))))), - (mloc _loc))), - e) - | "antibinding" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BiAnt")))))), - (mloc _loc))), - e) - | "antirec_binding" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RbAnt")))))), - (mloc _loc))), - e) - | "antimatch_case" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "McAnt")))))), - (mloc _loc))), - e) - | "antimodule_binding" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbAnt")))))), - (mloc _loc))), - e) - | "antiident" -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdAnt")))))), - (mloc _loc))), - e) - | _ -> e) - | e -> super#expr e - end - - let add_quotation name entry mexpr mpatt = - let entry_eoi = Gram.Entry.mk (Gram.Entry.name entry) in - let parse_quot_string entry loc s = - let q = !Camlp4_config.antiquotations in - let () = Camlp4_config.antiquotations := true in - let res = Gram.parse_string entry loc s in - let () = Camlp4_config.antiquotations := q in res in - let expand_expr loc loc_name_opt s = - let ast = parse_quot_string entry_eoi loc s in - let () = MetaLoc.loc_name := loc_name_opt in - let meta_ast = mexpr loc ast in - let exp_ast = antiquot_expander#expr meta_ast in exp_ast in - let expand_str_item loc loc_name_opt s = - let exp_ast = expand_expr loc loc_name_opt s - in Ast.StExp (loc, exp_ast) in - let expand_patt _loc loc_name_opt s = - let ast = parse_quot_string entry_eoi _loc s in - let meta_ast = mpatt _loc ast in - let exp_ast = antiquot_expander#patt meta_ast - in - match loc_name_opt with - | None -> exp_ast - | Some name -> - let rec subst_first_loc = - (function - | Ast.PaApp (_loc, - (Ast.PaId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Ast")), - (Ast.IdUid (_, u)))))), - _) -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, u)))))), - (Ast.PaId (_loc, (Ast.IdLid (_loc, name))))) - | Ast.PaApp (_loc, a, b) -> - Ast.PaApp (_loc, (subst_first_loc a), b) - | p -> p) - in subst_first_loc exp_ast - in - (Gram.extend (entry_eoi : 'entry_eoi Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (entry : 'entry Gram.Entry.t)); - Gram.Stoken - (((function | EOI -> true | _ -> false), "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) (x : 'entry) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (x : 'entry_eoi) - | _ -> assert false))) ]) ])) - ()); - Quotation.add name Quotation.DynAst.expr_tag expand_expr; - Quotation.add name Quotation.DynAst.patt_tag expand_patt; - Quotation.add name Quotation.DynAst.str_item_tag expand_str_item) - - let _ = - add_quotation "sig_item" sig_item_quot ME.meta_sig_item MP. - meta_sig_item - - let _ = - add_quotation "str_item" str_item_quot ME.meta_str_item MP. - meta_str_item - - let _ = add_quotation "ctyp" ctyp_quot ME.meta_ctyp MP.meta_ctyp - - let _ = add_quotation "patt" patt_quot ME.meta_patt MP.meta_patt - - let _ = add_quotation "expr" expr_quot ME.meta_expr MP.meta_expr - - let _ = - add_quotation "module_type" module_type_quot ME.meta_module_type - MP.meta_module_type - - let _ = - add_quotation "module_expr" module_expr_quot ME.meta_module_expr - MP.meta_module_expr - - let _ = - add_quotation "class_type" class_type_quot ME.meta_class_type MP. - meta_class_type - - let _ = - add_quotation "class_expr" class_expr_quot ME.meta_class_expr MP. - meta_class_expr - - let _ = - add_quotation "class_sig_item" class_sig_item_quot ME. - meta_class_sig_item MP.meta_class_sig_item - - let _ = - add_quotation "class_str_item" class_str_item_quot ME. - meta_class_str_item MP.meta_class_str_item - - let _ = - add_quotation "with_constr" with_constr_quot ME.meta_with_constr - MP.meta_with_constr - - let _ = - add_quotation "binding" binding_quot ME.meta_binding MP. - meta_binding - - let _ = - add_quotation "rec_binding" rec_binding_quot ME.meta_rec_binding - MP.meta_rec_binding - - let _ = - add_quotation "match_case" match_case_quot ME.meta_match_case MP. - meta_match_case - - let _ = - add_quotation "module_binding" module_binding_quot ME. - meta_module_binding MP.meta_module_binding - - let _ = add_quotation "ident" ident_quot ME.meta_ident MP.meta_ident - - let _ = - add_quotation "rec_flag" rec_flag_quot ME.meta_rec_flag MP. - meta_rec_flag - - let _ = - add_quotation "private_flag" private_flag_quot ME.meta_private_flag - MP.meta_private_flag - - let _ = - add_quotation "row_var_flag" row_var_flag_quot ME.meta_row_var_flag - MP.meta_row_var_flag - - let _ = - add_quotation "mutable_flag" mutable_flag_quot ME.meta_mutable_flag - MP.meta_mutable_flag - - let _ = - add_quotation "virtual_flag" virtual_flag_quot ME.meta_virtual_flag - MP.meta_virtual_flag - - let _ = - add_quotation "override_flag" override_flag_quot ME. - meta_override_flag MP.meta_override_flag - - let _ = - add_quotation "direction_flag" direction_flag_quot ME. - meta_direction_flag MP.meta_direction_flag - - end - - end - -module Q = - struct - open Camlp4 - - (* -*- camlp4r -*- *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2002-2006 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 OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - module Id = - struct - let name = "Camlp4QuotationExpander" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - module M = Camlp4QuotationCommon.Make(Syntax)(Syntax.AntiquotSyntax) - - include M - - end - - let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () - - end - -module Rp = - struct - open Camlp4 - - (* -*- camlp4r -*- *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 1998-2006 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 OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - module Id : Sig.Id = - struct - let name = "Camlp4OCamlRevisedParserParser" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - open Sig - - include Syntax - - type spat_comp = - | SpTrm of Loc.t * Ast.patt * Ast.expr option - | SpNtr of Loc.t * Ast.patt * Ast.expr - | SpStr of Loc.t * Ast.patt - - type sexp_comp = - | SeTrm of Loc.t * Ast.expr | SeNtr of Loc.t * Ast.expr - - let stream_expr = Gram.Entry.mk "stream_expr" - - let stream_begin = Gram.Entry.mk "stream_begin" - - let stream_end = Gram.Entry.mk "stream_end" - - let stream_quot = Gram.Entry.mk "stream_quot" - - let parser_case = Gram.Entry.mk "parser_case" - - let parser_case_list = Gram.Entry.mk "parser_case_list" - - let strm_n = "__strm" - - let peek_fun _loc = - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "peek"))))) - - let junk_fun _loc = - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "junk"))))) - - (* Parsers. *) - (* In syntax generated, many cases are optimisations. *) - let rec pattern_eq_expression p e = - match (p, e) with - | (Ast.PaId (_, (Ast.IdLid (_, a))), - Ast.ExId (_, (Ast.IdLid (_, b)))) -> a = b - | (Ast.PaId (_, (Ast.IdUid (_, a))), - Ast.ExId (_, (Ast.IdUid (_, b)))) -> a = b - | (Ast.PaApp (_, p1, p2), Ast.ExApp (_, e1, e2)) -> - (pattern_eq_expression p1 e1) && (pattern_eq_expression p2 e2) - | _ -> false - - let is_raise e = - match e with - | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "raise")))), _) -> - true - | _ -> false - - let is_raise_failure e = - match e with - | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "raise")))), - (Ast.ExId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Stream")), - (Ast.IdUid (_, "Failure"))))))) - -> true - | _ -> false - - let rec handle_failure e = - match e with - | Ast.ExTry (_, _, - (Ast.McArr (_, - (Ast.PaId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Stream")), - (Ast.IdUid (_, "Failure")))))), - (Ast.ExNil _), e))) - -> handle_failure e - | Ast.ExMat (_, me, a) -> - let rec match_case_handle_failure = - (function - | Ast.McOr (_, a1, a2) -> - (match_case_handle_failure a1) && - (match_case_handle_failure a2) - | Ast.McArr (_, _, (Ast.ExNil _), e) -> handle_failure e - | _ -> false) - in (handle_failure me) && (match_case_handle_failure a) - | Ast.ExLet (_, Ast.ReNil, bi, e) -> - let rec binding_handle_failure = - (function - | Ast.BiAnd (_, b1, b2) -> - (binding_handle_failure b1) && - (binding_handle_failure b2) - | Ast.BiEq (_, _, e) -> handle_failure e - | _ -> false) - in (binding_handle_failure bi) && (handle_failure e) - | Ast.ExId (_, (Ast.IdLid (_, _))) | Ast.ExInt (_, _) | - Ast.ExStr (_, _) | Ast.ExChr (_, _) | Ast.ExFun (_, _) | - Ast.ExId (_, (Ast.IdUid (_, _))) -> true - | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "raise")))), e) -> - (match e with - | Ast.ExId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Stream")), - (Ast.IdUid (_, "Failure"))))) - -> false - | _ -> true) - | Ast.ExApp (_, f, x) -> - (is_constr_apply f) && - ((handle_failure f) && (handle_failure x)) - | _ -> false - and is_constr_apply = - function - | Ast.ExId (_, (Ast.IdUid (_, _))) -> true - | Ast.ExId (_, (Ast.IdLid (_, _))) -> false - | Ast.ExApp (_, x, _) -> is_constr_apply x - | _ -> false - - let rec subst v e = - let _loc = Ast.loc_of_expr e - in - match e with - | Ast.ExId (_, (Ast.IdLid (_, x))) -> - let x = if x = v then strm_n else x - in Ast.ExId (_loc, (Ast.IdLid (_loc, x))) - | Ast.ExId (_, (Ast.IdUid (_, _))) -> e - | Ast.ExInt (_, _) -> e - | Ast.ExChr (_, _) -> e - | Ast.ExStr (_, _) -> e - | Ast.ExAcc (_, _, _) -> e - | Ast.ExLet (_, rf, bi, e) -> - Ast.ExLet (_loc, rf, (subst_binding v bi), (subst v e)) - | Ast.ExApp (_, e1, e2) -> - Ast.ExApp (_loc, (subst v e1), (subst v e2)) - | Ast.ExTup (_, e) -> Ast.ExTup (_loc, (subst v e)) - | Ast.ExCom (_, e1, e2) -> - Ast.ExCom (_loc, (subst v e1), (subst v e2)) - | _ -> raise Not_found - and subst_binding v = - function - | Ast.BiAnd (_loc, b1, b2) -> - Ast.BiAnd (_loc, (subst_binding v b1), (subst_binding v b2)) - | Ast.BiEq (_loc, (Ast.PaId (_, (Ast.IdLid (_, v')))), e) -> - Ast.BiEq (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, v')))), - (if v = v' then e else subst v e)) - | _ -> raise Not_found - - let stream_pattern_component skont ckont = - function - | SpTrm (_loc, p, None) -> - Ast.ExMat (_loc, - (Ast.ExApp (_loc, (peek_fun _loc), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), - (Ast.McOr (_loc, - (Ast.McArr (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, (Ast.IdUid (_loc, "Some")))), p)), - (Ast.ExNil _loc), - (Ast.ExSeq (_loc, - (Ast.ExSem (_loc, - (Ast.ExApp (_loc, (junk_fun _loc), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), - skont)))))), - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), - ckont))))) - | SpTrm (_loc, p, (Some w)) -> - Ast.ExMat (_loc, - (Ast.ExApp (_loc, (peek_fun _loc), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), - (Ast.McOr (_loc, - (Ast.McArr (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, (Ast.IdUid (_loc, "Some")))), p)), - w, - (Ast.ExSeq (_loc, - (Ast.ExSem (_loc, - (Ast.ExApp (_loc, (junk_fun _loc), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), - skont)))))), - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), - ckont))))) - | SpNtr (_loc, p, e) -> - let e = - (match e with - | Ast.ExFun (_, - (Ast.McArr (_, - (Ast.PaTyc (_, (Ast.PaId (_, (Ast.IdLid (_, v)))), - (Ast.TyApp (_, - (Ast.TyId (_, - (Ast.IdAcc (_, (Ast.IdUid (_, "Stream")), - (Ast.IdLid (_, "t")))))), - (Ast.TyAny _))))), - (Ast.ExNil _), e))) - when v = strm_n -> e - | _ -> - Ast.ExApp (_loc, e, - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))) - in - if pattern_eq_expression p skont - then - if is_raise_failure ckont - then e - else - if handle_failure e - then e - else - Ast.ExTry (_loc, e, - (Ast.McArr (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdUid (_loc, "Failure")))))), - (Ast.ExNil _loc), ckont))) - else - if is_raise_failure ckont - then - Ast.ExLet (_loc, Ast.ReNil, (Ast.BiEq (_loc, p, e)), - skont) - else - if - pattern_eq_expression - (Ast.PaApp (_loc, - (Ast.PaId (_loc, (Ast.IdUid (_loc, "Some")))), p)) - skont - then - Ast.ExTry (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "Some")))), e)), - (Ast.McArr (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdUid (_loc, "Failure")))))), - (Ast.ExNil _loc), ckont))) - else - if is_raise ckont - then - (let tst = - if handle_failure e - then e - else - Ast.ExTry (_loc, e, - (Ast.McArr (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Stream")), - (Ast.IdUid (_loc, "Failure")))))), - (Ast.ExNil _loc), ckont))) - in - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, p, tst)), skont)) - else - Ast.ExMat (_loc, - (Ast.ExTry (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "Some")))), - e)), - (Ast.McArr (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Stream")), - (Ast.IdUid (_loc, "Failure")))))), - (Ast.ExNil _loc), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "None")))))))), - (Ast.McOr (_loc, - (Ast.McArr (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, "Some")))), - p)), - (Ast.ExNil _loc), skont)), - (Ast.McArr (_loc, (Ast.PaAny _loc), - (Ast.ExNil _loc), ckont))))) - | SpStr (_loc, p) -> - (try - match p with - | Ast.PaId (_, (Ast.IdLid (_, v))) -> subst v skont - | _ -> raise Not_found - with - | Not_found -> - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, p, - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), - skont)) - - let rec stream_pattern _loc epo e ekont = - function - | [] -> - (match epo with - | Some ep -> - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, ep, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "count")))))), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))))), - e) - | _ -> e) - | (spc, err) :: spcl -> - let skont = - let ekont err = - let str = - (match err with - | Some estr -> estr - | _ -> Ast.ExStr (_loc, "")) - in - Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdLid (_loc, "raise")))), - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdUid (_loc, "Error")))))), - str))) - in stream_pattern _loc epo e ekont spcl in - let ckont = ekont err - in stream_pattern_component skont ckont spc - - let stream_patterns_term _loc ekont tspel = - let pel = - List.fold_right - (fun (p, w, _loc, spcl, epo, e) acc -> - let p = - Ast.PaApp (_loc, - (Ast.PaId (_loc, (Ast.IdUid (_loc, "Some")))), p) in - let e = - let ekont err = - let str = - match err with - | Some estr -> estr - | _ -> Ast.ExStr (_loc, "") - in - Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdLid (_loc, "raise")))), - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Stream")), - (Ast.IdUid (_loc, "Error")))))), - str))) in - let skont = stream_pattern _loc epo e ekont spcl - in - Ast.ExSeq (_loc, - (Ast.ExSem (_loc, - (Ast.ExApp (_loc, (junk_fun _loc), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), - skont))) - in - match w with - | Some w -> - Ast.McOr (_loc, (Ast.McArr (_loc, p, w, e)), acc) - | None -> - Ast.McOr (_loc, - (Ast.McArr (_loc, p, (Ast.ExNil _loc), e)), acc)) - tspel (Ast.McNil _loc) - in - Ast.ExMat (_loc, - (Ast.ExApp (_loc, (peek_fun _loc), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))), - (Ast.McOr (_loc, pel, - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), - (ekont ())))))) - - let rec group_terms = - function - | ((SpTrm (_loc, p, w), None) :: spcl, epo, e) :: spel -> - let (tspel, spel) = group_terms spel - in (((p, w, _loc, spcl, epo, e) :: tspel), spel) - | spel -> ([], spel) - - let rec parser_cases _loc = - function - | [] -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdLid (_loc, "raise")))), - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdUid (_loc, "Failure"))))))) - | spel -> - (match group_terms spel with - | ([], (spcl, epo, e) :: spel) -> - stream_pattern _loc epo e - (fun _ -> parser_cases _loc spel) spcl - | (tspel, spel) -> - stream_patterns_term _loc - (fun _ -> parser_cases _loc spel) tspel) - - let cparser _loc bpo pc = - let e = parser_cases _loc pc in - let e = - match bpo with - | Some bp -> - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, bp, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "count")))))), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))))), - e) - | None -> e in - let p = - Ast.PaTyc (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, strm_n)))), - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "t")))))), - (Ast.TyAny _loc)))) - in Ast.ExFun (_loc, (Ast.McArr (_loc, p, (Ast.ExNil _loc), e))) - - let cparser_match _loc me bpo pc = - let pc = parser_cases _loc pc in - let e = - match bpo with - | Some bp -> - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, bp, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "count")))))), - (Ast.ExId (_loc, (Ast.IdLid (_loc, strm_n)))))))), - pc) - | None -> pc in - let me = - match me with - | (Ast.ExSem (_loc, _, _) as e) -> Ast.ExSeq (_loc, e) - | e -> e - in - match me with - | Ast.ExId (_, (Ast.IdLid (_, x))) when x = strm_n -> e - | _ -> - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, - (Ast.PaTyc (_loc, - (Ast.PaId (_loc, (Ast.IdLid (_loc, strm_n)))), - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "t")))))), - (Ast.TyAny _loc))))), - me)), - e) - - (* streams *) - let rec not_computing = - function - | Ast.ExId (_, (Ast.IdLid (_, _))) | - Ast.ExId (_, (Ast.IdUid (_, _))) | Ast.ExInt (_, _) | - Ast.ExFlo (_, _) | Ast.ExChr (_, _) | Ast.ExStr (_, _) -> true - | Ast.ExApp (_, x, y) -> - (is_cons_apply_not_computing x) && (not_computing y) - | _ -> false - and is_cons_apply_not_computing = - function - | Ast.ExId (_, (Ast.IdUid (_, _))) -> true - | Ast.ExId (_, (Ast.IdLid (_, _))) -> false - | Ast.ExApp (_, x, y) -> - (is_cons_apply_not_computing x) && (not_computing y) - | _ -> false - - let slazy _loc e = - match e with - | Ast.ExApp (_, f, (Ast.ExId (_, (Ast.IdUid (_, "()"))))) -> - (match f with - | Ast.ExId (_, (Ast.IdLid (_, _))) -> f - | _ -> - Ast.ExFun (_loc, - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), e)))) - | _ -> - Ast.ExFun (_loc, - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), e))) - - let rec cstream gloc = - function - | [] -> - let _loc = gloc - in - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "sempty"))))) - | [ SeTrm (_loc, e) ] -> - if not_computing e - then - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "ising")))))), - e) - else - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "lsing")))))), - (slazy _loc e)) - | SeTrm (_loc, e) :: secl -> - if not_computing e - then - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "icons")))))), - e)), - (cstream gloc secl)) - else - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "lcons")))))), - (slazy _loc e))), - (cstream gloc secl)) - | [ SeNtr (_loc, e) ] -> - if not_computing e - then e - else - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "slazy")))))), - (slazy _loc e)) - | SeNtr (_loc, e) :: secl -> - if not_computing e - then - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "iapp")))))), - e)), - (cstream gloc secl)) - else - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Stream")), - (Ast.IdLid (_loc, "lapp")))))), - (slazy _loc e))), - (cstream gloc secl)) - - (* Syntax extensions in Revised Syntax grammar *) - let _ = - let _ = (expr : 'expr Gram.Entry.t) - and _ = (parser_case_list : 'parser_case_list Gram.Entry.t) - and _ = (parser_case : 'parser_case Gram.Entry.t) - and _ = (stream_quot : 'stream_quot Gram.Entry.t) - and _ = (stream_end : 'stream_end Gram.Entry.t) - and _ = (stream_begin : 'stream_begin Gram.Entry.t) - and _ = (stream_expr : 'stream_expr Gram.Entry.t) in - let grammar_entry_create = Gram.Entry.mk in - let stream_patt : 'stream_patt Gram.Entry.t = - grammar_entry_create "stream_patt" - and stream_expr_comp : 'stream_expr_comp Gram.Entry.t = - grammar_entry_create "stream_expr_comp" - and stream_expr_comp_list : 'stream_expr_comp_list Gram.Entry.t = - grammar_entry_create "stream_expr_comp_list" - and parser_ipatt : 'parser_ipatt Gram.Entry.t = - grammar_entry_create "parser_ipatt" - and stream_patt_comp : 'stream_patt_comp Gram.Entry.t = - grammar_entry_create "stream_patt_comp" - and stream_patt_comp_err_list : - 'stream_patt_comp_err_list Gram.Entry.t = - grammar_entry_create "stream_patt_comp_err_list" - and stream_patt_comp_err : 'stream_patt_comp_err Gram.Entry.t = - grammar_entry_create "stream_patt_comp_err" - in - (Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "top")), - [ (None, None, - [ ([ Gram.Skeyword "match"; - Gram.Snterm - (Gram.Entry.obj - (sequence : 'sequence Gram.Entry.t)); - Gram.Skeyword "with"; Gram.Skeyword "parser"; - Gram.Sopt - (Gram.Snterm - (Gram.Entry.obj - (parser_ipatt : - 'parser_ipatt Gram.Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (parser_case_list : - 'parser_case_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (pcl : 'parser_case_list) - (po : 'parser_ipatt option) _ _ - (e : 'sequence) _ (_loc : Gram.Loc.t) -> - (cparser_match _loc e po pcl : 'expr)))); - ([ Gram.Skeyword "parser"; - Gram.Sopt - (Gram.Snterm - (Gram.Entry.obj - (parser_ipatt : - 'parser_ipatt Gram.Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (parser_case_list : - 'parser_case_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (pcl : 'parser_case_list) - (po : 'parser_ipatt option) _ - (_loc : Gram.Loc.t) -> - (cparser _loc po pcl : 'expr)))) ]) ])) - ()); - Gram.extend (parser_case_list : 'parser_case_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (parser_case : 'parser_case Gram.Entry.t)) ], - (Gram.Action.mk - (fun (pc : 'parser_case) (_loc : Gram.Loc.t) -> - ([ pc ] : 'parser_case_list)))); - ([ Gram.Skeyword "["; - Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (parser_case : - 'parser_case Gram.Entry.t))), - (Gram.Skeyword "|")); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (pcl : 'parser_case list) _ - (_loc : Gram.Loc.t) -> - (pcl : 'parser_case_list)))) ]) ])) - ()); - Gram.extend (parser_case : 'parser_case Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (stream_begin : 'stream_begin Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (stream_patt : 'stream_patt Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (stream_end : 'stream_end Gram.Entry.t)); - Gram.Sopt - (Gram.Snterm - (Gram.Entry.obj - (parser_ipatt : - 'parser_ipatt Gram.Entry.t))); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (po : 'parser_ipatt option) _ - (sp : 'stream_patt) _ (_loc : Gram.Loc.t) -> - ((sp, po, e) : 'parser_case)))) ]) ])) - ()); - Gram.extend (stream_begin : 'stream_begin Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "[:" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (() : 'stream_begin)))) ]) ])) - ()); - Gram.extend (stream_end : 'stream_end Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword ":]" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> (() : 'stream_end)))) ]) ])) - ()); - Gram.extend (stream_quot : 'stream_quot Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "`" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (() : 'stream_quot)))) ]) ])) - ()); - Gram.extend (stream_expr : 'stream_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (e : 'stream_expr)))) ]) ])) - ()); - Gram.extend (stream_patt : 'stream_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> ([] : 'stream_patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_patt_comp : - 'stream_patt_comp Gram.Entry.t)); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (stream_patt_comp_err_list : - 'stream_patt_comp_err_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (sp : 'stream_patt_comp_err_list) _ - (spc : 'stream_patt_comp) (_loc : Gram.Loc.t) - -> ((spc, None) :: sp : 'stream_patt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_patt_comp : - 'stream_patt_comp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (spc : 'stream_patt_comp) - (_loc : Gram.Loc.t) -> - ([ (spc, None) ] : 'stream_patt)))) ]) ])) - ()); - Gram.extend - (stream_patt_comp_err : 'stream_patt_comp_err Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (stream_patt_comp : - 'stream_patt_comp Gram.Entry.t)); - Gram.Sopt - (Gram.srules stream_patt_comp_err - [ ([ Gram.Skeyword "??"; - Gram.Snterm - (Gram.Entry.obj - (stream_expr : - 'stream_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'stream_expr) _ - (_loc : Gram.Loc.t) -> (e : 'e__14)))) ]) ], - (Gram.Action.mk - (fun (eo : 'e__14 option) - (spc : 'stream_patt_comp) (_loc : Gram.Loc.t) - -> ((spc, eo) : 'stream_patt_comp_err)))) ]) ])) - ()); - Gram.extend - (stream_patt_comp_err_list : - 'stream_patt_comp_err_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (stream_patt_comp_err : - 'stream_patt_comp_err Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (sp : 'stream_patt_comp_err_list) _ - (spc : 'stream_patt_comp_err) - (_loc : Gram.Loc.t) -> - (spc :: sp : 'stream_patt_comp_err_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_patt_comp_err : - 'stream_patt_comp_err Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (spc : 'stream_patt_comp_err) - (_loc : Gram.Loc.t) -> - ([ spc ] : 'stream_patt_comp_err_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_patt_comp_err : - 'stream_patt_comp_err Gram.Entry.t)) ], - (Gram.Action.mk - (fun (spc : 'stream_patt_comp_err) - (_loc : Gram.Loc.t) -> - ([ spc ] : 'stream_patt_comp_err_list)))) ]) ])) - ()); - Gram.extend (stream_patt_comp : 'stream_patt_comp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) (_loc : Gram.Loc.t) -> - (SpStr (_loc, p) : 'stream_patt_comp)))); - ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj - (stream_expr : 'stream_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'stream_expr) _ (p : 'patt) - (_loc : Gram.Loc.t) -> - (SpNtr (_loc, p, e) : 'stream_patt_comp)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_quot : 'stream_quot Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Sopt - (Gram.srules stream_patt_comp - [ ([ Gram.Skeyword "when"; - Gram.Snterm - (Gram.Entry.obj - (stream_expr : - 'stream_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'stream_expr) _ - (_loc : Gram.Loc.t) -> (e : 'e__15)))) ]) ], - (Gram.Action.mk - (fun (eo : 'e__15 option) (p : 'patt) _ - (_loc : Gram.Loc.t) -> - (SpTrm (_loc, p, eo) : 'stream_patt_comp)))) ]) ])) - ()); - Gram.extend (parser_ipatt : 'parser_ipatt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.PaAny _loc : 'parser_ipatt)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.PaId (_loc, (Ast.IdLid (_loc, i))) : - 'parser_ipatt)))) ]) ])) - ()); - Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "simple")), - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (stream_begin : 'stream_begin Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (stream_expr_comp_list : - 'stream_expr_comp_list Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (stream_end : 'stream_end Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (sel : 'stream_expr_comp_list) _ - (_loc : Gram.Loc.t) -> - (cstream _loc sel : 'expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_begin : 'stream_begin Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (stream_end : 'stream_end Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - (cstream _loc [] : 'expr)))) ]) ])) - ()); - Gram.extend - (stream_expr_comp_list : 'stream_expr_comp_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (stream_expr_comp : - 'stream_expr_comp Gram.Entry.t)) ], - (Gram.Action.mk - (fun (se : 'stream_expr_comp) - (_loc : Gram.Loc.t) -> - ([ se ] : 'stream_expr_comp_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_expr_comp : - 'stream_expr_comp Gram.Entry.t)); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (se : 'stream_expr_comp) - (_loc : Gram.Loc.t) -> - ([ se ] : 'stream_expr_comp_list)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_expr_comp : - 'stream_expr_comp Gram.Entry.t)); - Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (sel : 'stream_expr_comp_list) _ - (se : 'stream_expr_comp) (_loc : Gram.Loc.t) - -> (se :: sel : 'stream_expr_comp_list)))) ]) ])) - ()); - Gram.extend (stream_expr_comp : 'stream_expr_comp Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (stream_expr : 'stream_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'stream_expr) (_loc : Gram.Loc.t) -> - (SeNtr (_loc, e) : 'stream_expr_comp)))); - ([ Gram.Snterm - (Gram.Entry.obj - (stream_quot : 'stream_quot Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (stream_expr : 'stream_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'stream_expr) _ (_loc : Gram.Loc.t) -> - (SeTrm (_loc, e) : 'stream_expr_comp)))) ]) ])) - ())) - - end - - module M = Register.OCamlSyntaxExtension(Id)(Make) - - end - -module G = - struct - open Camlp4 - - (* -*- camlp4r -*- *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2002-2006 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 OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - module Id = - struct let name = "Camlp4GrammarParser" - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - open Sig - - include Syntax - - module MetaLoc = Ast.Meta.MetaGhostLoc - - module MetaAst = Ast.Meta.Make(MetaLoc) - - module PP = Camlp4.Printers.OCaml.Make(Syntax) - - let pp = new PP.printer ~comments: false () - - let string_of_patt patt = - let buf = Buffer.create 42 in - let () = Format.bprintf buf "%a@?" pp#patt patt in - let str = Buffer.contents buf - in if str = "" then assert false else str - - let split_ext = ref false - - type loc = Loc.t - - type 'e name = { expr : 'e; tvar : string; loc : loc } - - type styp = - | STlid of loc * string - | STapp of loc * styp * styp - | STquo of loc * string - | STself of loc * string - | STtok of loc - | STstring_tok of loc - | STtyp of Ast.ctyp - - type ('e, 'p) text = - | TXmeta of loc * string * (('e, 'p) text) list * 'e * styp - | TXlist of loc * bool * ('e, 'p) symbol * (('e, 'p) symbol) option - | TXnext of loc - | TXnterm of loc * 'e name * string option - | TXopt of loc * ('e, 'p) text - | TXtry of loc * ('e, 'p) text - | TXrules of loc * (((('e, 'p) text) list) * 'e) list - | TXself of loc - | TXkwd of loc * string - | TXtok of loc * 'e * string - and (** The first is the match function expr, - the second is the string description. - The description string will be used for - grammar insertion and left factoring. - Keep this string normalized and well comparable. *) - ('e, 'p) entry = - { name : 'e name; pos : 'e option; levels : (('e, 'p) level) list - } - and ('e, 'p) level = - { label : string option; assoc : 'e option; - rules : (('e, 'p) rule) list - } - and ('e, 'p) rule = - { prod : (('e, 'p) symbol) list; action : 'e option - } - and ('e, 'p) symbol = - { used : string list; text : ('e, 'p) text; styp : styp; - pattern : 'p option - } - - type used = | Unused | UsedScanned | UsedNotScanned - - let _loc = Loc.ghost - - let gm = "Camlp4Grammar__" - - let mark_used modif ht n = - try - let rll = Hashtbl.find_all ht n - in - List.iter - (fun (r, _) -> - if !r == Unused - then (r := UsedNotScanned; modif := true) - else ()) - rll - with | Not_found -> () - - let rec mark_symbol modif ht symb = - List.iter (fun e -> mark_used modif ht e) symb.used - - let check_use nl el = - let ht = Hashtbl.create 301 in - let modif = ref false - in - (List.iter - (fun e -> - let u = - match e.name.expr with - | Ast.ExId (_, (Ast.IdLid (_, _))) -> Unused - | _ -> UsedNotScanned - in Hashtbl.add ht e.name.tvar ((ref u), e)) - el; - List.iter - (fun n -> - try - let rll = Hashtbl.find_all ht n.tvar - in List.iter (fun (r, _) -> r := UsedNotScanned) rll - with | _ -> ()) - nl; - modif := true; - while !modif do modif := false; - Hashtbl.iter - (fun _ (r, e) -> - if !r = UsedNotScanned - then - (r := UsedScanned; - List.iter - (fun level -> - let rules = level.rules - in - List.iter - (fun rule -> - List.iter - (fun s -> mark_symbol modif ht s) - rule.prod) - rules) - e.levels) - else ()) - ht - done; - Hashtbl.iter - (fun s (r, e) -> - if !r = Unused - then - print_warning e.name.loc - ("Unused local entry \"" ^ (s ^ "\"")) - else ()) - ht) - - let new_type_var = - let i = ref 0 in fun () -> (incr i; "e__" ^ (string_of_int !i)) - - let used_of_rule_list rl = - List.fold_left - (fun nl r -> List.fold_left (fun nl s -> s.used @ nl) nl r.prod) - [] rl - - let retype_rule_list_without_patterns _loc rl = - try - List.map - (function - | (* ...; [ "foo" ]; ... ==> ...; (x = [ "foo" ] -> Gram.Token.extract_string x); ... *) - { - prod = [ ({ pattern = None; styp = STtok _ } as s) ]; - action = None - } -> - { - prod = - [ { - (s) - with - pattern = - Some (Ast.PaId (_loc, (Ast.IdLid (_loc, "x")))); - } ]; - action = - Some - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Token")), - (Ast.IdLid (_loc, "extract_string")))))))), - (Ast.ExId (_loc, (Ast.IdLid (_loc, "x")))))); - } - | (* ...; [ symb ]; ... ==> ...; (x = [ symb ] -> x); ... *) - { prod = [ ({ pattern = None } as s) ]; action = None } -> - { - prod = - [ { - (s) - with - pattern = - Some (Ast.PaId (_loc, (Ast.IdLid (_loc, "x")))); - } ]; - action = Some (Ast.ExId (_loc, (Ast.IdLid (_loc, "x")))); - } - | (* ...; ([] -> a); ... *) - ({ prod = []; action = Some _ } as r) -> r - | _ -> raise Exit) - rl - with | Exit -> rl - - let meta_action = ref false - - let mklistexp _loc = - let rec loop top = - function - | [] -> Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))) - | e1 :: el -> - let _loc = - if top then _loc else Loc.merge (Ast.loc_of_expr e1) _loc - in - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), e1)), - (loop false el)) - in loop true - - let mklistpat _loc = - let rec loop top = - function - | [] -> Ast.PaId (_loc, (Ast.IdUid (_loc, "[]"))) - | p1 :: pl -> - let _loc = - if top then _loc else Loc.merge (Ast.loc_of_patt p1) _loc - in - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, (Ast.IdUid (_loc, "::")))), p1)), - (loop false pl)) - in loop true - - let rec expr_fa al = - function - | Ast.ExApp (_, f, a) -> expr_fa (a :: al) f - | f -> (f, al) - - let rec make_ctyp styp tvar = - match styp with - | STlid (_loc, s) -> Ast.TyId (_loc, (Ast.IdLid (_loc, s))) - | STapp (_loc, t1, t2) -> - Ast.TyApp (_loc, (make_ctyp t1 tvar), (make_ctyp t2 tvar)) - | STquo (_loc, s) -> Ast.TyQuo (_loc, s) - | STself (_loc, x) -> - if tvar = "" - then - Loc.raise _loc - (Stream.Error - ("'" ^ (x ^ "' illegal in anonymous entry level"))) - else Ast.TyQuo (_loc, tvar) - | STtok _loc -> - Ast.TyId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Token")))), - (Ast.IdLid (_loc, "t"))))) - | STstring_tok _loc -> - Ast.TyId (_loc, (Ast.IdLid (_loc, "string"))) - | STtyp t -> t - - let make_ctyp_patt styp tvar patt = - let styp = - match styp with | STstring_tok _loc -> STtok _loc | t -> t - in - match make_ctyp styp tvar with - | Ast.TyAny _ -> patt - | t -> - let _loc = Ast.loc_of_patt patt in Ast.PaTyc (_loc, patt, t) - - let make_ctyp_expr styp tvar expr = - match make_ctyp styp tvar with - | Ast.TyAny _ -> expr - | t -> let _loc = Ast.loc_of_expr expr in Ast.ExTyc (_loc, expr, t) - - let text_of_action _loc psl rtvar act tvar = - let locid = Ast.PaId (_loc, (Ast.IdLid (_loc, !Loc.name))) in - let act = - match act with - | Some act -> act - | None -> Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) in - let (tok_match_pl, act, _) = - List.fold_left - (fun (((tok_match_pl, act, i) as accu)) -> - function - | { pattern = None } -> accu - | { pattern = Some p } when Ast.is_irrefut_patt p -> accu - | { - pattern = - Some - (Ast.PaAli (_, - (Ast.PaApp (_, _, (Ast.PaTup (_, (Ast.PaAny _))))), - (Ast.PaId (_, (Ast.IdLid (_, s)))))) - } -> - (tok_match_pl, - (Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, - (Ast.PaId (_loc, (Ast.IdLid (_loc, s)))), - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Token")), - (Ast.IdLid (_loc, "extract_string")))))))), - (Ast.ExId (_loc, (Ast.IdLid (_loc, s)))))))), - act)), - i) - | { pattern = Some p; text = TXtok (_, _, _) } -> - let id = "__camlp4_" ^ (string_of_int i) - in - ((Some - (match tok_match_pl with - | None -> - ((Ast.ExId (_loc, (Ast.IdLid (_loc, id)))), - p) - | Some ((tok_pl, match_pl)) -> - ((Ast.ExCom (_loc, - (Ast.ExId (_loc, (Ast.IdLid (_loc, id)))), - tok_pl)), - (Ast.PaCom (_loc, p, match_pl))))), - act, (succ i)) - | _ -> accu) - (None, act, 0) psl in - let e = - let e1 = Ast.ExTyc (_loc, act, (Ast.TyQuo (_loc, rtvar))) in - let e2 = - match tok_match_pl with - | None -> e1 - | Some ((Ast.ExCom (_, t1, t2), Ast.PaCom (_, p1, p2))) -> - Ast.ExMat (_loc, - (Ast.ExTup (_loc, (Ast.ExCom (_loc, t1, t2)))), - (Ast.McOr (_loc, - (Ast.McArr (_loc, - (Ast.PaTup (_loc, (Ast.PaCom (_loc, p1, p2)))), - (Ast.ExNil _loc), e1)), - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), - (Ast.ExAsf _loc)))))) - | Some ((tok, match_)) -> - Ast.ExMat (_loc, tok, - (Ast.McOr (_loc, - (Ast.McArr (_loc, match_, (Ast.ExNil _loc), e1)), - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), - (Ast.ExAsf _loc)))))) - in - Ast.ExFun (_loc, - (Ast.McArr (_loc, - (Ast.PaTyc (_loc, locid, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Loc")))), - (Ast.IdLid (_loc, "t")))))))), - (Ast.ExNil _loc), e2))) in - let (txt, _) = - List.fold_left - (fun (txt, i) s -> - match s.pattern with - | None | Some (Ast.PaAny _) -> - ((Ast.ExFun (_loc, - (Ast.McArr (_loc, (Ast.PaAny _loc), - (Ast.ExNil _loc), txt)))), - i) - | Some - (Ast.PaAli (_, - (Ast.PaApp (_, _, (Ast.PaTup (_, (Ast.PaAny _))))), - p)) - -> - let p = make_ctyp_patt s.styp tvar p - in - ((Ast.ExFun (_loc, - (Ast.McArr (_loc, p, (Ast.ExNil _loc), txt)))), - i) - | Some p when Ast.is_irrefut_patt p -> - let p = make_ctyp_patt s.styp tvar p - in - ((Ast.ExFun (_loc, - (Ast.McArr (_loc, p, (Ast.ExNil _loc), txt)))), - i) - | Some _ -> - let p = - make_ctyp_patt s.styp tvar - (Ast.PaId (_loc, - (Ast.IdLid (_loc, - ("__camlp4_" ^ (string_of_int i)))))) - in - ((Ast.ExFun (_loc, - (Ast.McArr (_loc, p, (Ast.ExNil _loc), txt)))), - (succ i))) - (e, 0) psl in - let txt = - if !meta_action - then - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Obj")), - (Ast.IdLid (_loc, "magic")))))), - (MetaAst.Expr.meta_expr _loc txt)) - else txt - in - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Action")), - (Ast.IdLid (_loc, "mk")))))))), - txt) - - let srules loc t rl tvar = - List.map - (fun r -> - let sl = List.map (fun s -> s.text) r.prod in - let ac = text_of_action loc r.prod t r.action tvar in (sl, ac)) - rl - - let rec make_expr entry tvar = - function - | TXmeta (_loc, n, tl, e, t) -> - let el = - List.fold_right - (fun t el -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), - (make_expr entry "" t))), - el)) - tl (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) - in - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Smeta")))))), - (Ast.ExStr (_loc, n)))), - el)), - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Action")), - (Ast.IdLid (_loc, "mk")))))))), - (make_ctyp_expr t tvar e)))) - | TXlist (_loc, min, t, ts) -> - let txt = make_expr entry "" t.text - in - (match (min, ts) with - | (false, None) -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Slist0")))))), - txt) - | (true, None) -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Slist1")))))), - txt) - | (false, Some s) -> - let x = make_expr entry tvar s.text - in - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Slist0sep")))))), - txt)), - x) - | (true, Some s) -> - let x = make_expr entry tvar s.text - in - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Slist1sep")))))), - txt)), - x)) - | TXnext _loc -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Snext"))))) - | TXnterm (_loc, n, lev) -> - (match lev with - | Some lab -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Snterml")))))), - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Entry")), - (Ast.IdLid (_loc, "obj")))))))), - (Ast.ExTyc (_loc, n.expr, - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Entry")))), - (Ast.IdLid (_loc, "t")))))), - (Ast.TyQuo (_loc, n.tvar)))))))))), - (Ast.ExStr (_loc, lab))) - | None -> - if n.tvar = tvar - then - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Sself"))))) - else - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Snterm")))))), - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Entry")), - (Ast.IdLid (_loc, "obj")))))))), - (Ast.ExTyc (_loc, n.expr, - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Entry")))), - (Ast.IdLid (_loc, "t")))))), - (Ast.TyQuo (_loc, n.tvar)))))))))) - | TXopt (_loc, t) -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Sopt")))))), - (make_expr entry "" t)) - | TXtry (_loc, t) -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Stry")))))), - (make_expr entry "" t)) - | TXrules (_loc, rl) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdLid (_loc, "srules")))))), - entry.expr)), - (make_expr_rules _loc entry rl "")) - | TXself _loc -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Sself"))))) - | TXkwd (_loc, kwd) -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Skeyword")))))), - (Ast.ExStr (_loc, kwd))) - | TXtok (_loc, match_fun, descr) -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Stoken")))))), - (Ast.ExTup (_loc, - (Ast.ExCom (_loc, match_fun, - (Ast.ExStr (_loc, (Ast.safe_string_escaped descr)))))))) - and make_expr_rules _loc n rl tvar = - List.fold_left - (fun txt (sl, ac) -> - let sl = - List.fold_right - (fun t txt -> - let x = make_expr n tvar t - in - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), x)), - txt)) - sl (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) - in - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), - (Ast.ExTup (_loc, (Ast.ExCom (_loc, sl, ac)))))), - txt)) - (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) rl - - let expr_of_delete_rule _loc n sl = - let sl = - List.fold_right - (fun s e -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), - (make_expr n "" s.text))), - e)) - sl (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) - in ((n.expr), sl) - - let rec tvar_of_ident = - function - | Ast.IdLid (_, x) | Ast.IdUid (_, x) -> x - | Ast.IdAcc (_, (Ast.IdUid (_, x)), xs) -> - x ^ ("__" ^ (tvar_of_ident xs)) - | _ -> failwith "internal error in the Grammar extension" - - let mk_name _loc i = - { expr = Ast.ExId (_loc, i); tvar = tvar_of_ident i; loc = _loc; } - - let slist loc min sep symb = TXlist (loc, min, symb, sep) - - (* - value sstoken _loc s = - let n = mk_name _loc <:ident< $lid:"a_" ^ s$ >> in - TXnterm _loc n None - ; - - value mk_symbol p s t = - {used = []; text = s; styp = t; pattern=Some p}; - - value sslist _loc min sep s = - let rl = - let r1 = - let prod = - let n = mk_name _loc <:ident< a_list >> in - [mk_symbol <:patt< a >> (TXnterm _loc n None) (STquo _loc "a_list")] - in - let act = <:expr< a >> in - {prod = prod; action = Some act} - in - let r2 = - let prod = - [mk_symbol <:patt< a >> (slist _loc min sep s) - (STapp _loc (STlid _loc "list") s.styp)] - in - let act = <:expr< Qast.List a >> in - {prod = prod; action = Some act} - in - [r1; r2] - in - let used = - match sep with - [ Some symb -> symb.used @ s.used - | None -> s.used ] - in - let used = ["a_list" :: used] in - let text = TXrules _loc (srules _loc "a_list" rl "") in - let styp = STquo _loc "a_list" in - {used = used; text = text; styp = styp; pattern = None} - ; - - value ssopt _loc s = - let rl = - let r1 = - let prod = - let n = mk_name _loc <:ident< a_opt >> in - [mk_symbol <:patt< a >> (TXnterm _loc n None) (STquo _loc "a_opt")] - in - let act = <:expr< a >> in - {prod = prod; action = Some act} - in - let r2 = - let s = - match s.text with - [ TXkwd _loc _ | TXtok _loc _ _ -> - let rl = - [{prod = [{ (s) with pattern = Some <:patt< x >> }]; - action = Some <:expr< Qast.Str (Token.extract_string x) >>}] - in - let t = new_type_var () in - {used = []; text = TXrules _loc (srules _loc t rl ""); - styp = STquo _loc t; pattern = None} - | _ -> s ] - in - let prod = - [mk_symbol <:patt< a >> (TXopt _loc s.text) - (STapp _loc (STlid _loc "option") s.styp)] - in - let act = <:expr< Qast.Option a >> in - {prod = prod; action = Some act} - in - [r1; r2] - in - let used = ["a_opt" :: s.used] in - let text = TXrules _loc (srules _loc "a_opt" rl "") in - let styp = STquo _loc "a_opt" in - {used = used; text = text; styp = styp; pattern = None} - ; - *) - let text_of_entry _loc e = - let ent = - let x = e.name in - let _loc = e.name.loc - in - Ast.ExTyc (_loc, x.expr, - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Entry")))), - (Ast.IdLid (_loc, "t")))))), - (Ast.TyQuo (_loc, x.tvar))))) in - let pos = - match e.pos with - | Some pos -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "Some")))), pos) - | None -> Ast.ExId (_loc, (Ast.IdUid (_loc, "None"))) in - let txt = - List.fold_right - (fun level txt -> - let lab = - match level.label with - | Some lab -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "Some")))), - (Ast.ExStr (_loc, lab))) - | None -> Ast.ExId (_loc, (Ast.IdUid (_loc, "None"))) in - let ass = - match level.assoc with - | Some ass -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "Some")))), ass) - | None -> Ast.ExId (_loc, (Ast.IdUid (_loc, "None"))) in - let txt = - let rl = - srules _loc e.name.tvar level.rules e.name.tvar in - let e = make_expr_rules _loc e.name rl e.name.tvar - in - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), - (Ast.ExTup (_loc, - (Ast.ExCom (_loc, lab, - (Ast.ExCom (_loc, ass, e)))))))), - txt) - in txt) - e.levels (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]")))) - in (ent, pos, txt) - - let let_in_of_extend _loc gram gl el args = - match gl with - | None -> args - | Some nl -> - (check_use nl el; - let ll = - let same_tvar e n = e.name.tvar = n.tvar - in - List.fold_right - (fun e ll -> - match e.name.expr with - | Ast.ExId (_, (Ast.IdLid (_, _))) -> - if List.exists (same_tvar e) nl - then ll - else - if List.exists (same_tvar e) ll - then ll - else e.name :: ll - | _ -> ll) - el [] in - let local_binding_of_name { expr = e; tvar = x; loc = _loc } = - let i = - (match e with - | Ast.ExId (_, (Ast.IdLid (_, i))) -> i - | _ -> failwith "internal error in the Grammar extension") - in - Ast.BiEq (_loc, (Ast.PaId (_loc, (Ast.IdLid (_loc, i)))), - (Ast.ExTyc (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "grammar_entry_create")))), - (Ast.ExStr (_loc, i)))), - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Entry")))), - (Ast.IdLid (_loc, "t")))))), - (Ast.TyQuo (_loc, x))))))) in - let expr_of_name { expr = e; tvar = x; loc = _loc } = - Ast.ExTyc (_loc, e, - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdUid (_loc, "Entry")))), - (Ast.IdLid (_loc, "t")))))), - (Ast.TyQuo (_loc, x))))) in - let e = - (match ll with - | [] -> args - | x :: xs -> - let locals = - List.fold_right - (fun name acc -> - Ast.BiAnd (_loc, acc, - (local_binding_of_name name))) - xs (local_binding_of_name x) in - let entry_mk = - (match gram with - | Some g -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Entry")), - (Ast.IdLid (_loc, "mk")))))))), - (Ast.ExId (_loc, g))) - | None -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Entry")), - (Ast.IdLid (_loc, "mk")))))))) - in - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, - (Ast.PaId (_loc, - (Ast.IdLid (_loc, "grammar_entry_create")))), - entry_mk)), - (Ast.ExLet (_loc, Ast.ReNil, locals, args)))) - in - (match nl with - | [] -> e - | x :: xs -> - let globals = - List.fold_right - (fun name acc -> - Ast.BiAnd (_loc, acc, - (Ast.BiEq (_loc, (Ast.PaAny _loc), - (expr_of_name name))))) - xs - (Ast.BiEq (_loc, (Ast.PaAny _loc), - (expr_of_name x))) - in Ast.ExLet (_loc, Ast.ReNil, globals, e))) - - class subst gmod = - object inherit Ast.map as super - method ident = - function - | Ast.IdUid (_, x) when x = gm -> gmod - | x -> super#ident x - end - - let subst_gmod ast gmod = (new subst gmod)#expr ast - - let text_of_functorial_extend _loc gmod gram gl el = - let args = - let el = - List.map - (fun e -> - let (ent, pos, txt) = text_of_entry e.name.loc e in - let e = - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdLid (_loc, "extend")))))), - ent)), - (Ast.ExApp (_loc, - (Ast.ExFun (_loc, - (Ast.McArr (_loc, - (Ast.PaId (_loc, (Ast.IdUid (_loc, "()")))), - (Ast.ExNil _loc), - (Ast.ExTup (_loc, - (Ast.ExCom (_loc, pos, txt)))))))), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))))))) - in - if !split_ext - then - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, - (Ast.PaId (_loc, (Ast.IdLid (_loc, "aux")))), - (Ast.ExFun (_loc, - (Ast.McArr (_loc, - (Ast.PaId (_loc, (Ast.IdUid (_loc, "()")))), - (Ast.ExNil _loc), e)))))), - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdLid (_loc, "aux")))), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))))))) - else e) - el - in - match el with - | [] -> Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) - | [ e ] -> e - | e :: el -> - Ast.ExSeq (_loc, - (List.fold_left (fun acc x -> Ast.ExSem (_loc, acc, x)) e - el)) - in subst_gmod (let_in_of_extend _loc gram gl el args) gmod - - let wildcarder = - object (self) - inherit Ast.map as super - method patt = - function - | Ast.PaId (_loc, (Ast.IdLid (_, _))) -> Ast.PaAny _loc - | Ast.PaAli (_, p, _) -> self#patt p - | p -> super#patt p - end - - let mk_tok _loc p t = - let p' = wildcarder#patt p in - let match_fun = - if Ast.is_irrefut_patt p' - then - Ast.ExFun (_loc, - (Ast.McArr (_loc, p', (Ast.ExNil _loc), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "True"))))))) - else - Ast.ExFun (_loc, - (Ast.McOr (_loc, - (Ast.McArr (_loc, p', (Ast.ExNil _loc), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "True")))))), - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "False"))))))))) in - let descr = string_of_patt p' in - let text = TXtok (_loc, match_fun, descr) - in { used = []; text = text; styp = t; pattern = Some p; } - - let symbol = Gram.Entry.mk "symbol" - - let check_not_tok s = - match s with - | { text = TXtok (_loc, _, _) } -> - Loc.raise _loc - (Stream.Error - ("Deprecated syntax, use a sub rule. " ^ - "LIST0 STRING becomes LIST0 [ x = STRING -> x ]")) - | _ -> () - - let _ = Camlp4_config.antiquotations := true - - let _ = - let _ = (expr : 'expr Gram.Entry.t) - and _ = (symbol : 'symbol Gram.Entry.t) in - let grammar_entry_create = Gram.Entry.mk in - let extend_header : 'extend_header Gram.Entry.t = - grammar_entry_create "extend_header" - and semi_sep : 'semi_sep Gram.Entry.t = - grammar_entry_create "semi_sep" - and string : 'string Gram.Entry.t = grammar_entry_create "string" - and name : 'name Gram.Entry.t = grammar_entry_create "name" - and comma_patt : 'comma_patt Gram.Entry.t = - grammar_entry_create "comma_patt" - and pattern : 'pattern Gram.Entry.t = - grammar_entry_create "pattern" - and psymbol : 'psymbol Gram.Entry.t = - grammar_entry_create "psymbol" - and rule : 'rule Gram.Entry.t = grammar_entry_create "rule" - and rule_list : 'rule_list Gram.Entry.t = - grammar_entry_create "rule_list" - and assoc : 'assoc Gram.Entry.t = grammar_entry_create "assoc" - and level : 'level Gram.Entry.t = grammar_entry_create "level" - and level_list : 'level_list Gram.Entry.t = - grammar_entry_create "level_list" - and position : 'position Gram.Entry.t = - grammar_entry_create "position" - and entry : 'entry Gram.Entry.t = grammar_entry_create "entry" - and global : 'global Gram.Entry.t = grammar_entry_create "global" - and t_qualid : 't_qualid Gram.Entry.t = - grammar_entry_create "t_qualid" - and qualid : 'qualid Gram.Entry.t = grammar_entry_create "qualid" - and qualuid : 'qualuid Gram.Entry.t = - grammar_entry_create "qualuid" - and delete_rule_body : 'delete_rule_body Gram.Entry.t = - grammar_entry_create "delete_rule_body" - and extend_body : 'extend_body Gram.Entry.t = - grammar_entry_create "extend_body" - in - (Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.After "top")), - [ (None, None, - [ ([ Gram.Skeyword "GEXTEND" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Loc.raise _loc - (Stream.Error - "Deprecated syntax, use EXTEND MyGramModule ... END instead") : - 'expr)))); - ([ Gram.Skeyword "GDELETE_RULE" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Loc.raise _loc - (Stream.Error - "Deprecated syntax, use DELETE_RULE MyGramModule ... END instead") : - 'expr)))); - ([ Gram.Skeyword "DELETE_RULE"; - Gram.Snterm - (Gram.Entry.obj - (delete_rule_body : - 'delete_rule_body Gram.Entry.t)); - Gram.Skeyword "END" ], - (Gram.Action.mk - (fun _ (e : 'delete_rule_body) _ - (_loc : Gram.Loc.t) -> (e : 'expr)))); - ([ Gram.Skeyword "EXTEND"; - Gram.Snterm - (Gram.Entry.obj - (extend_body : 'extend_body Gram.Entry.t)); - Gram.Skeyword "END" ], - (Gram.Action.mk - (fun _ (e : 'extend_body) _ (_loc : Gram.Loc.t) - -> (e : 'expr)))) ]) ])) - ()); - Gram.extend (extend_header : 'extend_header Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (qualuid : 'qualuid Gram.Entry.t)) ], - (Gram.Action.mk - (fun (g : 'qualuid) (_loc : Gram.Loc.t) -> - ((None, g) : 'extend_header)))); - ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj (qualid : 'qualid Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (t_qualid : 't_qualid Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (t : 't_qualid) _ (i : 'qualid) _ - (_loc : Gram.Loc.t) -> - (((Some i), t) : 'extend_header)))) ]) ])) - ()); - Gram.extend (extend_body : 'extend_body Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (extend_header : - 'extend_header Gram.Entry.t)); - Gram.Sopt - (Gram.Snterm - (Gram.Entry.obj - (global : 'global Gram.Entry.t))); - Gram.Slist1 - (Gram.srules extend_body - [ ([ Gram.Snterm - (Gram.Entry.obj - (entry : 'entry Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi_sep : - 'semi_sep Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (e : 'entry) - (_loc : Gram.Loc.t) -> (e : 'e__16)))) ]) ], - (Gram.Action.mk - (fun (el : 'e__16 list) - (global_list : 'global option) - ((gram, g) : 'extend_header) - (_loc : Gram.Loc.t) -> - (text_of_functorial_extend _loc g gram - global_list el : - 'extend_body)))) ]) ])) - ()); - Gram.extend (delete_rule_body : 'delete_rule_body Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (qualuid : 'qualuid Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (name : 'name Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (symbol : 'symbol Gram.Entry.t))), - (Gram.Snterm - (Gram.Entry.obj - (semi_sep : 'semi_sep Gram.Entry.t)))) ], - (Gram.Action.mk - (fun (sl : 'symbol list) _ (n : 'name) - (g : 'qualuid) (_loc : Gram.Loc.t) -> - (let (e, b) = expr_of_delete_rule _loc n sl - in - subst_gmod - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, gm)), - (Ast.IdLid (_loc, - "delete_rule")))))), - e)), - b)) - g : - 'delete_rule_body)))) ]) ])) - ()); - Gram.extend (qualuid : 'qualuid Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.srules qualuid - [ ([ Gram.Stoken - (((function - | UIDENT "GLOBAL" -> true - | _ -> false), - "UIDENT \"GLOBAL\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "GLOBAL" -> (() : 'e__17) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | LIDENT ((_)) -> true - | _ -> false), - "LIDENT ((_))")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT ((_)) -> (() : 'e__17) - | _ -> assert false))) ] ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Loc.raise _loc - (Stream.Error - "Deprecated syntax, the grammar module is expected") : - 'qualuid)))) ]); - (None, None, - [ ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")) ], - (Gram.Action.mk - (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i - in Ast.IdUid (_loc, i) : 'qualuid)))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (xs : 'qualuid) _ (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let x = Gram.Token.extract_string x - in - Ast.IdAcc (_loc, (Ast.IdUid (_loc, x)), - xs) : - 'qualuid)))) ]) ])) - ()); - Gram.extend (qualuid : 'qualuid Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.srules qualuid - [ ([ Gram.Stoken - (((function - | UIDENT "GLOBAL" -> true - | _ -> false), - "UIDENT \"GLOBAL\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "GLOBAL" -> (() : 'e__18) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | LIDENT ((_)) -> true - | _ -> false), - "LIDENT ((_))")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT ((_)) -> (() : 'e__18) - | _ -> assert false))) ] ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Loc.raise _loc - (Stream.Error - "Deprecated syntax, the grammar module is expected") : - 'qualuid)))) ]); - (None, None, - [ ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")) ], - (Gram.Action.mk - (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i - in Ast.IdUid (_loc, i) : 'qualuid)))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (xs : 'qualuid) _ (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let x = Gram.Token.extract_string x - in - Ast.IdAcc (_loc, (Ast.IdUid (_loc, x)), - xs) : - 'qualuid)))) ]) ])) - ()); - Gram.extend (qualid : 'qualid Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | LIDENT ((_)) -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i - in Ast.IdLid (_loc, i) : 'qualid)))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")) ], - (Gram.Action.mk - (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i - in Ast.IdUid (_loc, i) : 'qualid)))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (xs : 'qualid) _ (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let x = Gram.Token.extract_string x - in - Ast.IdAcc (_loc, (Ast.IdUid (_loc, x)), - xs) : - 'qualid)))) ]) ])) - ()); - Gram.extend (t_qualid : 't_qualid Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | LIDENT _ | UIDENT _ -> true - | _ -> false), - "LIDENT _ | UIDENT _")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT _ | UIDENT _ -> - (Loc.raise _loc - (Stream.Error - ("Wrong EXTEND header, the grammar type must finish by 't', " - ^ - "like in EXTEND (g : Gram.t) ... END")) : - 't_qualid) - | _ -> assert false))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")); - Gram.Skeyword "."; - Gram.Stoken - (((function | LIDENT "t" -> true | _ -> false), - "LIDENT \"t\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) _ - (x : Gram.Token.t) (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT "t" -> - (let x = Gram.Token.extract_string x - in Ast.IdUid (_loc, x) : 't_qualid) - | _ -> assert false))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")); - Gram.Skeyword "."; Gram.Sself ], - (Gram.Action.mk - (fun (xs : 't_qualid) _ (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let x = Gram.Token.extract_string x - in - Ast.IdAcc (_loc, (Ast.IdUid (_loc, x)), - xs) : - 't_qualid)))) ]) ])) - ()); - Gram.extend (global : 'global Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | UIDENT "GLOBAL" -> true - | _ -> false), - "UIDENT \"GLOBAL\"")); - Gram.Skeyword ":"; - Gram.Slist1 - (Gram.Snterm - (Gram.Entry.obj (name : 'name Gram.Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (semi_sep : 'semi_sep Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (sl : 'name list) _ - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "GLOBAL" -> (sl : 'global) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (entry : 'entry Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (name : 'name Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Sopt - (Gram.Snterm - (Gram.Entry.obj - (position : 'position Gram.Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (level_list : 'level_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ll : 'level_list) (pos : 'position option) - _ (n : 'name) (_loc : Gram.Loc.t) -> - ({ name = n; pos = pos; levels = ll; } : - 'entry)))) ]) ])) - ()); - Gram.extend (position : 'position Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | UIDENT "LEVEL" -> true - | _ -> false), - "UIDENT \"LEVEL\"")); - Gram.Snterm - (Gram.Entry.obj (string : 'string Gram.Entry.t)) ], - (Gram.Action.mk - (fun (n : 'string) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "LEVEL" -> - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Sig")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, - "Grammar")), - (Ast.IdUid (_loc, "Level")))))))))), - n) : - 'position) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "AFTER" -> true - | _ -> false), - "UIDENT \"AFTER\"")); - Gram.Snterm - (Gram.Entry.obj (string : 'string Gram.Entry.t)) ], - (Gram.Action.mk - (fun (n : 'string) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "AFTER" -> - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Sig")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, - "Grammar")), - (Ast.IdUid (_loc, "After")))))))))), - n) : - 'position) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "BEFORE" -> true - | _ -> false), - "UIDENT \"BEFORE\"")); - Gram.Snterm - (Gram.Entry.obj (string : 'string Gram.Entry.t)) ], - (Gram.Action.mk - (fun (n : 'string) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "BEFORE" -> - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Sig")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, - "Grammar")), - (Ast.IdUid (_loc, - "Before")))))))))), - n) : - 'position) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "LAST" -> true - | _ -> false), - "UIDENT \"LAST\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "LAST" -> - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Sig")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Grammar")), - (Ast.IdUid (_loc, "Last"))))))))) : - 'position) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "FIRST" -> true - | _ -> false), - "UIDENT \"FIRST\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "FIRST" -> - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Sig")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Grammar")), - (Ast.IdUid (_loc, "First"))))))))) : - 'position) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (level_list : 'level_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "["; - Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (level : 'level Gram.Entry.t))), - (Gram.Skeyword "|")); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (ll : 'level list) _ (_loc : Gram.Loc.t) - -> (ll : 'level_list)))) ]) ])) - ()); - Gram.extend (level : 'level Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Sopt - (Gram.srules level - [ ([ Gram.Stoken - (((function - | STRING ((_)) -> true - | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let x = - Gram.Token.extract_string x - in x : 'e__19)))) ]); - Gram.Sopt - (Gram.Snterm - (Gram.Entry.obj - (assoc : 'assoc Gram.Entry.t))); - Gram.Snterm - (Gram.Entry.obj - (rule_list : 'rule_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (rules : 'rule_list) (ass : 'assoc option) - (lab : 'e__19 option) (_loc : Gram.Loc.t) -> - ({ label = lab; assoc = ass; rules = rules; } : - 'level)))) ]) ])) - ()); - Gram.extend (assoc : 'assoc Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | UIDENT "NONA" -> true - | _ -> false), - "UIDENT \"NONA\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "NONA" -> - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Sig")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Grammar")), - (Ast.IdUid (_loc, "NonA"))))))))) : - 'assoc) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "RIGHTA" -> true - | _ -> false), - "UIDENT \"RIGHTA\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "RIGHTA" -> - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Sig")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Grammar")), - (Ast.IdUid (_loc, "RightA"))))))))) : - 'assoc) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "LEFTA" -> true - | _ -> false), - "UIDENT \"LEFTA\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "LEFTA" -> - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Camlp4")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Sig")), - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Grammar")), - (Ast.IdUid (_loc, "LeftA"))))))))) : - 'assoc) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (rule_list : 'rule_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "["; - Gram.Slist1sep - ((Gram.Snterm - (Gram.Entry.obj (rule : 'rule Gram.Entry.t))), - (Gram.Skeyword "|")); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (rules : 'rule list) _ - (_loc : Gram.Loc.t) -> - (retype_rule_list_without_patterns _loc rules : - 'rule_list)))); - ([ Gram.Skeyword "["; Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ _ (_loc : Gram.Loc.t) -> - ([] : 'rule_list)))) ]) ])) - ()); - Gram.extend (rule : 'rule Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (psymbol : 'psymbol Gram.Entry.t))), - (Gram.Snterm - (Gram.Entry.obj - (semi_sep : 'semi_sep Gram.Entry.t)))) ], - (Gram.Action.mk - (fun (psl : 'psymbol list) (_loc : Gram.Loc.t) - -> ({ prod = psl; action = None; } : 'rule)))); - ([ Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj - (psymbol : 'psymbol Gram.Entry.t))), - (Gram.Snterm - (Gram.Entry.obj - (semi_sep : 'semi_sep Gram.Entry.t)))); - Gram.Skeyword "->"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (act : 'expr) _ (psl : 'psymbol list) - (_loc : Gram.Loc.t) -> - ({ prod = psl; action = Some act; } : 'rule)))) ]) ])) - ()); - Gram.extend (psymbol : 'psymbol Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (symbol : 'symbol Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'symbol) (_loc : Gram.Loc.t) -> - (s : 'psymbol)))); - ([ Gram.Snterm - (Gram.Entry.obj - (pattern : 'pattern Gram.Entry.t)); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (symbol : 'symbol Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'symbol) _ (p : 'pattern) - (_loc : Gram.Loc.t) -> - (match s.pattern with - | Some - (Ast.PaApp (_, - (Ast.PaId (_, (Ast.IdUid (_, u)))), - (Ast.PaTup (_, (Ast.PaAny _))))) - -> - mk_tok _loc - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, u)))), - p)) - s.styp - | _ -> { (s) with pattern = Some p; } : - 'psymbol)))); - ([ Gram.Stoken - (((function | LIDENT ((_)) -> true | _ -> false), - "LIDENT _")); - Gram.Sopt - (Gram.srules psymbol - [ ([ Gram.Stoken - (((function - | UIDENT "LEVEL" -> true - | _ -> false), - "UIDENT \"LEVEL\"")); - Gram.Stoken - (((function - | STRING ((_)) -> true - | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (s : Gram.Token.t) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "LEVEL" -> - (let s = - Gram.Token.extract_string s - in s : 'e__20) - | _ -> assert false))) ]) ], - (Gram.Action.mk - (fun (lev : 'e__20 option) (i : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i in - let name = - mk_name _loc (Ast.IdLid (_loc, i)) in - let text = TXnterm (_loc, name, lev) in - let styp = STquo (_loc, i) - in - { - used = [ i ]; - text = text; - styp = styp; - pattern = None; - } : - 'psymbol)))); - ([ Gram.Stoken - (((function | LIDENT ((_)) -> true | _ -> false), - "LIDENT _")); - Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (symbol : 'symbol Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'symbol) _ (p : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let p = Gram.Token.extract_string p - in - match s.pattern with - | Some - ((Ast.PaApp (_, - (Ast.PaId (_, (Ast.IdUid (_, u)))), - (Ast.PaTup (_, (Ast.PaAny _)))) - as p')) - -> - let match_fun = - Ast.ExFun (_loc, - (Ast.McOr (_loc, - (Ast.McArr (_loc, p', - (Ast.ExNil _loc), - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "True")))))), - (Ast.McArr (_loc, - (Ast.PaAny _loc), - (Ast.ExNil _loc), - (Ast.ExId (_loc, - (Ast.IdUid (_loc, - "False"))))))))) in - let p' = - Ast.PaAli (_loc, p', - (Ast.PaId (_loc, - (Ast.IdLid (_loc, p))))) in - let descr = u ^ " _" in - let text = - TXtok (_loc, match_fun, descr) - in - { - (s) - with - text = text; - pattern = Some p'; - } - | _ -> - { - (s) - with - pattern = - Some - (Ast.PaId (_loc, - (Ast.IdLid (_loc, p)))); - } : - 'psymbol)))) ]) ])) - ()); - Gram.extend (symbol : 'symbol Gram.Entry.t) - ((fun () -> - (None, - [ ((Some "top"), (Some Camlp4.Sig.Grammar.NonA), - [ ([ Gram.Stoken - (((function | UIDENT "TRY" -> true | _ -> false), - "UIDENT \"TRY\"")); - Gram.Sself ], - (Gram.Action.mk - (fun (s : 'symbol) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "TRY" -> - (let text = TXtry (_loc, s.text) - in - { - used = s.used; - text = text; - styp = s.styp; - pattern = None; - } : - 'symbol) - | _ -> assert false))); - ([ Gram.Stoken - (((function | UIDENT "OPT" -> true | _ -> false), - "UIDENT \"OPT\"")); - Gram.Sself ], - (Gram.Action.mk - (fun (s : 'symbol) (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "OPT" -> - (let () = check_not_tok s in - let styp = - STapp (_loc, (STlid (_loc, "option")), - s.styp) in - let text = TXopt (_loc, s.text) - in - { - used = s.used; - text = text; - styp = styp; - pattern = None; - } : - 'symbol) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "LIST1" -> true - | _ -> false), - "UIDENT \"LIST1\"")); - Gram.Sself; - Gram.Sopt - (Gram.srules symbol - [ ([ Gram.Stoken - (((function - | UIDENT "SEP" -> true - | _ -> false), - "UIDENT \"SEP\"")); - Gram.Snterm - (Gram.Entry.obj - (symbol : 'symbol Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'symbol) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "SEP" -> (t : 'e__22) - | _ -> assert false))) ]) ], - (Gram.Action.mk - (fun (sep : 'e__22 option) (s : 'symbol) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "LIST1" -> - (let () = check_not_tok s in - let used = - (match sep with - | Some symb -> symb.used @ s.used - | None -> s.used) in - let styp = - STapp (_loc, (STlid (_loc, "list")), - s.styp) in - let text = slist _loc true sep s - in - { - used = used; - text = text; - styp = styp; - pattern = None; - } : - 'symbol) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "LIST0" -> true - | _ -> false), - "UIDENT \"LIST0\"")); - Gram.Sself; - Gram.Sopt - (Gram.srules symbol - [ ([ Gram.Stoken - (((function - | UIDENT "SEP" -> true - | _ -> false), - "UIDENT \"SEP\"")); - Gram.Snterm - (Gram.Entry.obj - (symbol : 'symbol Gram.Entry.t)) ], - (Gram.Action.mk - (fun (t : 'symbol) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "SEP" -> (t : 'e__21) - | _ -> assert false))) ]) ], - (Gram.Action.mk - (fun (sep : 'e__21 option) (s : 'symbol) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "LIST0" -> - (let () = check_not_tok s in - let used = - (match sep with - | Some symb -> symb.used @ s.used - | None -> s.used) in - let styp = - STapp (_loc, (STlid (_loc, "list")), - s.styp) in - let text = slist _loc false sep s - in - { - used = used; - text = text; - styp = styp; - pattern = None; - } : - 'symbol) - | _ -> assert false))) ]); - (None, None, - [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (s_t : 'symbol) _ (_loc : Gram.Loc.t) -> - (s_t : 'symbol)))); - ([ Gram.Snterm - (Gram.Entry.obj (name : 'name Gram.Entry.t)); - Gram.Sopt - (Gram.srules symbol - [ ([ Gram.Stoken - (((function - | UIDENT "LEVEL" -> true - | _ -> false), - "UIDENT \"LEVEL\"")); - Gram.Stoken - (((function - | STRING ((_)) -> true - | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (s : Gram.Token.t) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "LEVEL" -> - (let s = - Gram.Token.extract_string s - in s : 'e__24) - | _ -> assert false))) ]) ], - (Gram.Action.mk - (fun (lev : 'e__24 option) (n : 'name) - (_loc : Gram.Loc.t) -> - ({ - used = [ n.tvar ]; - text = TXnterm (_loc, n, lev); - styp = STquo (_loc, n.tvar); - pattern = None; - } : 'symbol)))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")); - Gram.Skeyword "."; - Gram.Snterm - (Gram.Entry.obj (qualid : 'qualid Gram.Entry.t)); - Gram.Sopt - (Gram.srules symbol - [ ([ Gram.Stoken - (((function - | UIDENT "LEVEL" -> true - | _ -> false), - "UIDENT \"LEVEL\"")); - Gram.Stoken - (((function - | STRING ((_)) -> true - | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (s : Gram.Token.t) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "LEVEL" -> - (let s = - Gram.Token.extract_string s - in s : 'e__23) - | _ -> assert false))) ]) ], - (Gram.Action.mk - (fun (lev : 'e__23 option) (il : 'qualid) _ - (i : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i in - let n = - mk_name _loc - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, i)), - il)) - in - { - used = [ n.tvar ]; - text = TXnterm (_loc, n, lev); - styp = STquo (_loc, n.tvar); - pattern = None; - } : - 'symbol)))); - ([ Gram.Stoken - (((function | STRING ((_)) -> true | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (s : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let s = Gram.Token.extract_string s - in - { - used = []; - text = TXkwd (_loc, s); - styp = STtok _loc; - pattern = None; - } : - 'symbol)))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")); - Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (x : Gram.Token.t) (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ("", s) -> - (let x = Gram.Token.extract_string x in - let e = - AntiquotSyntax.parse_expr _loc s in - let match_fun = - Ast.ExFun (_loc, - (Ast.McOr (_loc, - (Ast.McArr (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, x)))), - (Ast.PaId (_loc, - (Ast.IdLid (_loc, - "camlp4_x")))))), - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdLid (_loc, - "=")))), - (Ast.ExId (_loc, - (Ast.IdLid (_loc, - "camlp4_x")))))), - e)), - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "True")))))), - (Ast.McArr (_loc, - (Ast.PaAny _loc), - (Ast.ExNil _loc), - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "False"))))))))) in - let descr = "$" ^ (x ^ (" " ^ s)) in - let text = - TXtok (_loc, match_fun, descr) in - let p = - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, x)))), - (Ast.PaTup (_loc, (Ast.PaAny _loc)))) - in - { - used = []; - text = text; - styp = STtok _loc; - pattern = Some p; - } : - 'symbol) - | _ -> assert false))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")); - Gram.Stoken - (((function | STRING ((_)) -> true | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (s : Gram.Token.t) (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let s = Gram.Token.extract_string s in - let x = Gram.Token.extract_string x - in - mk_tok _loc - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, x)))), - (Ast.PaStr (_loc, s)))) - (STtok _loc) : - 'symbol)))); - ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")) ], - (Gram.Action.mk - (fun (x : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let x = Gram.Token.extract_string x - in - mk_tok _loc - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, x)))), - (Ast.PaTup (_loc, (Ast.PaAny _loc))))) - (STstring_tok _loc) : - 'symbol)))); - ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'patt) _ (_loc : Gram.Loc.t) -> - (mk_tok _loc p (STtok _loc) : 'symbol)))); - ([ Gram.Skeyword "["; - Gram.Slist0sep - ((Gram.Snterm - (Gram.Entry.obj (rule : 'rule Gram.Entry.t))), - (Gram.Skeyword "|")); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (rl : 'rule list) _ (_loc : Gram.Loc.t) - -> - (let rl = - retype_rule_list_without_patterns _loc rl in - let t = new_type_var () - in - { - used = used_of_rule_list rl; - text = - TXrules (_loc, (srules _loc t rl "")); - styp = STquo (_loc, t); - pattern = None; - } : - 'symbol)))); - ([ Gram.Stoken - (((function - | UIDENT "NEXT" -> true - | _ -> false), - "UIDENT \"NEXT\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "NEXT" -> - ({ - used = []; - text = TXnext _loc; - styp = STself (_loc, "NEXT"); - pattern = None; - } : 'symbol) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "SELF" -> true - | _ -> false), - "UIDENT \"SELF\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "SELF" -> - ({ - used = []; - text = TXself _loc; - styp = STself (_loc, "SELF"); - pattern = None; - } : 'symbol) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (pattern : 'pattern Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ","; - Gram.Snterm - (Gram.Entry.obj - (comma_patt : 'comma_patt Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p2 : 'comma_patt) _ (p1 : 'pattern) _ - (_loc : Gram.Loc.t) -> - (Ast.PaTup (_loc, (Ast.PaCom (_loc, p1, p2))) : - 'pattern)))); - ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (p : 'pattern) _ (_loc : Gram.Loc.t) -> - (p : 'pattern)))); - ([ Gram.Skeyword "_" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.PaAny _loc : 'pattern)))); - ([ Gram.Stoken - (((function | LIDENT ((_)) -> true | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i - in Ast.PaId (_loc, (Ast.IdLid (_loc, i))) : - 'pattern)))) ]) ])) - ()); - Gram.extend (comma_patt : 'comma_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (pattern : 'pattern Gram.Entry.t)) ], - (Gram.Action.mk - (fun (p : 'pattern) (_loc : Gram.Loc.t) -> - (p : 'comma_patt)))); - ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], - (Gram.Action.mk - (fun (p2 : 'comma_patt) _ (p1 : 'comma_patt) - (_loc : Gram.Loc.t) -> - (Ast.PaCom (_loc, p1, p2) : 'comma_patt)))) ]) ])) - ()); - Gram.extend (name : 'name Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (qualid : 'qualid Gram.Entry.t)) ], - (Gram.Action.mk - (fun (il : 'qualid) (_loc : Gram.Loc.t) -> - (mk_name _loc il : 'name)))) ]) ])) - ()); - Gram.extend (string : 'string Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | ANTIQUOT ("", _) -> true - | _ -> false), - "ANTIQUOT (\"\", _)")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | ANTIQUOT ("", s) -> - (AntiquotSyntax.parse_expr _loc s : - 'string) - | _ -> assert false))); - ([ Gram.Stoken - (((function | STRING ((_)) -> true | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (s : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let s = Gram.Token.extract_string s - in Ast.ExStr (_loc, s) : 'string)))) ]) ])) - ()); - Gram.extend (semi_sep : 'semi_sep Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> (() : 'semi_sep)))) ]) ])) - ())) - - (* - EXTEND Gram - symbol: LEVEL "top" - [ NONA - [ min = [ UIDENT "SLIST0" -> False | UIDENT "SLIST1" -> True ]; - s = SELF; sep = OPT [ UIDENT "SEP"; t = symbol -> t ] -> - sslist _loc min sep s - | UIDENT "SOPT"; s = SELF -> - ssopt _loc s ] ] - ; - END; - *) - let sfold _loc n foldfun f e s = - let styp = STquo (_loc, (new_type_var ())) in - let e = - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdLid (_loc, foldfun)))))), - f)), - e) in - let t = - STapp (_loc, - (STapp (_loc, - (STtyp - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdLid (_loc, "fold")))))), - (Ast.TyAny _loc)))), - s.styp)), - styp) - in - { - used = s.used; - text = TXmeta (_loc, n, [ s.text ], e, t); - styp = styp; - pattern = None; - } - - let sfoldsep _loc n foldfun f e s sep = - let styp = STquo (_loc, (new_type_var ())) in - let e = - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdLid (_loc, foldfun)))))), - f)), - e) in - let t = - STapp (_loc, - (STapp (_loc, - (STtyp - (Ast.TyApp (_loc, - (Ast.TyId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, gm)), - (Ast.IdLid (_loc, "foldsep")))))), - (Ast.TyAny _loc)))), - s.styp)), - styp) - in - { - used = s.used @ sep.used; - text = TXmeta (_loc, n, [ s.text; sep.text ], e, t); - styp = styp; - pattern = None; - } - - let _ = - let _ = (symbol : 'symbol Gram.Entry.t) in - let grammar_entry_create = Gram.Entry.mk in - let simple_expr : 'simple_expr Gram.Entry.t = - grammar_entry_create "simple_expr" - in - (Gram.extend (symbol : 'symbol Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "top")), - [ (None, None, - [ ([ Gram.Stoken - (((function - | UIDENT "FOLD1" -> true - | _ -> false), - "UIDENT \"FOLD1\"")); - Gram.Snterm - (Gram.Entry.obj - (simple_expr : 'simple_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (simple_expr : 'simple_expr Gram.Entry.t)); - Gram.Sself; - Gram.Stoken - (((function | UIDENT "SEP" -> true | _ -> false), - "UIDENT \"SEP\"")); - Gram.Sself ], - (Gram.Action.mk - (fun (sep : 'symbol) (__camlp4_1 : Gram.Token.t) - (s : 'symbol) (e : 'simple_expr) - (f : 'simple_expr) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match (__camlp4_1, __camlp4_0) with - | (UIDENT "SEP", UIDENT "FOLD1") -> - (sfoldsep _loc "FOLD1 SEP" "sfold1sep" f - e s sep : - 'symbol) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "FOLD0" -> true - | _ -> false), - "UIDENT \"FOLD0\"")); - Gram.Snterm - (Gram.Entry.obj - (simple_expr : 'simple_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (simple_expr : 'simple_expr Gram.Entry.t)); - Gram.Sself; - Gram.Stoken - (((function | UIDENT "SEP" -> true | _ -> false), - "UIDENT \"SEP\"")); - Gram.Sself ], - (Gram.Action.mk - (fun (sep : 'symbol) (__camlp4_1 : Gram.Token.t) - (s : 'symbol) (e : 'simple_expr) - (f : 'simple_expr) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match (__camlp4_1, __camlp4_0) with - | (UIDENT "SEP", UIDENT "FOLD0") -> - (sfoldsep _loc "FOLD0 SEP" "sfold0sep" f - e s sep : - 'symbol) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "FOLD1" -> true - | _ -> false), - "UIDENT \"FOLD1\"")); - Gram.Snterm - (Gram.Entry.obj - (simple_expr : 'simple_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (simple_expr : 'simple_expr Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (s : 'symbol) (e : 'simple_expr) - (f : 'simple_expr) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "FOLD1" -> - (sfold _loc "FOLD1" "sfold1" f e s : - 'symbol) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | UIDENT "FOLD0" -> true - | _ -> false), - "UIDENT \"FOLD0\"")); - Gram.Snterm - (Gram.Entry.obj - (simple_expr : 'simple_expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (simple_expr : 'simple_expr Gram.Entry.t)); - Gram.Sself ], - (Gram.Action.mk - (fun (s : 'symbol) (e : 'simple_expr) - (f : 'simple_expr) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT "FOLD0" -> - (sfold _loc "FOLD0" "sfold0" f e s : - 'symbol) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (simple_expr : 'simple_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "("; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword ")" ], - (Gram.Action.mk - (fun _ (e : 'expr) _ (_loc : Gram.Loc.t) -> - (e : 'simple_expr)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'a_LIDENT) (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdLid (_loc, i))) : - 'simple_expr)))) ]) ])) - ())) - - let _ = - Options.add "-split_ext" (Arg.Set split_ext) - "Split EXTEND by functions to turn around a PowerPC problem." - - let _ = - Options.add "-split_gext" (Arg.Set split_ext) - "Old name for the option -split_ext." - - let _ = - Options.add "-meta_action" (Arg.Set meta_action) "Undocumented" - - end - - (* FIXME *) - module M = Register.OCamlSyntaxExtension(Id)(Make) - - end - -module M = - struct - open Camlp4 - - (* -*- camlp4r -*- *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - * - Aleksey Nogin: extra features and bug fixes. - * - Christopher Conway: extra feature (-D=) - * - Jean-vincent Loddo: definitions inside IFs. - *) - module Id = - struct let name = "Camlp4MacroParser" - let version = Sys.ocaml_version - - end - - (* -Added statements: - - At toplevel (structure item): - - DEFINE - DEFINE = - DEFINE () = - IFDEF THEN [ ELSE ] (END | ENDIF) - IFNDEF THEN [ ELSE ] (END | ENDIF) - INCLUDE - - At toplevel (signature item): - - DEFINE - IFDEF THEN [ ELSE ] (END | ENDIF) - IFNDEF THEN [ ELSE ] (END | ENDIF) - INCLUDE - - In expressions: - - IFDEF THEN [ ELSE ] (END | ENDIF) - IFNDEF THEN [ ELSE ] (END | ENDIF) - DEFINE = IN - __FILE__ - __LOCATION__ - LOCATION_OF - - In patterns: - - IFDEF THEN ELSE (END | ENDIF) - IFNDEF THEN ELSE (END | ENDIF) - - As Camlp4 options: - - -D or -D=expr define with optional value - -U undefine it - -I add to the search path for INCLUDE'd files - - After having used a DEFINE followed by "= ", you - can use it in expressions *and* in patterns. If the expression defining - the macro cannot be used as a pattern, there is an error message if - it is used in a pattern. - - You can also define a local macro in an expression usigng the DEFINE ... IN form. - Note that local macros have lowercase names and can not take parameters. - - If a macro is defined to = NOTHING, and then used as an argument to a function, - this will be equivalent to function taking one less argument. Similarly, - passing NOTHING as an argument to a macro is equivalent to "erasing" the - corresponding parameter from the macro body. - - The toplevel statement INCLUDE can be used to include a - file containing macro definitions and also any other toplevel items. - The included files are looked up in directories passed in via the -I - option, falling back to the current directory. - - The expression __FILE__ returns the current compiled file name. - The expression __LOCATION__ returns the current location of itself. - If used inside a macro, it returns the location where the macro is - called. - The expression (LOCATION_OF parameter) returns the location of the given - macro parameter. It cannot be used outside a macro definition. - -*) - open Camlp4 - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - open Sig - - include Syntax - - type 'a item_or_def = - | SdStr of 'a - | SdDef of string * ((string list) * Ast.expr) option - | SdUnd of string - | SdITE of bool * ('a item_or_def) list * ('a item_or_def) list - | SdLazy of 'a Lazy.t - - let rec list_remove x = - function - | (y, _) :: l when y = x -> l - | d :: l -> d :: (list_remove x l) - | [] -> [] - - let defined = ref [] - - let is_defined i = List.mem_assoc i !defined - - let bad_patt _loc = - Loc.raise _loc - (Failure - "this macro cannot be used in a pattern (see its definition)") - - let substp _loc env = - let rec loop = - function - | Ast.ExApp (_, e1, e2) -> Ast.PaApp (_loc, (loop e1), (loop e2)) - | Ast.ExNil _ -> Ast.PaNil _loc - | Ast.ExId (_, (Ast.IdLid (_, x))) -> - (try List.assoc x env - with | Not_found -> Ast.PaId (_loc, (Ast.IdLid (_loc, x)))) - | Ast.ExId (_, (Ast.IdUid (_, x))) -> - (try List.assoc x env - with | Not_found -> Ast.PaId (_loc, (Ast.IdUid (_loc, x)))) - | Ast.ExInt (_, x) -> Ast.PaInt (_loc, x) - | Ast.ExStr (_, s) -> Ast.PaStr (_loc, s) - | Ast.ExTup (_, x) -> Ast.PaTup (_loc, (loop x)) - | Ast.ExCom (_, x1, x2) -> Ast.PaCom (_loc, (loop x1), (loop x2)) - | Ast.ExRec (_, bi, (Ast.ExNil _)) -> - let rec substbi = - (function - | Ast.RbSem (_, b1, b2) -> - Ast.PaSem (_loc, (substbi b1), (substbi b2)) - | Ast.RbEq (_, i, e) -> Ast.PaEq (_loc, i, (loop e)) - | _ -> bad_patt _loc) - in Ast.PaRec (_loc, (substbi bi)) - | _ -> bad_patt _loc - in loop - - class reloc _loc = - object inherit Ast.map as super method loc = fun _ -> _loc end - - (* method _Loc_t _ = _loc; *) - class subst _loc env = - object inherit reloc _loc as super - method expr = - function - | (Ast.ExId (_, (Ast.IdLid (_, x))) | - Ast.ExId (_, (Ast.IdUid (_, x))) - as e) -> - (try List.assoc x env with | Not_found -> super#expr e) - | (Ast.ExApp (_loc, - (Ast.ExId (_, (Ast.IdUid (_, "LOCATION_OF")))), - (Ast.ExId (_, (Ast.IdLid (_, x))))) | - Ast.ExApp (_loc, - (Ast.ExId (_, (Ast.IdUid (_, "LOCATION_OF")))), - (Ast.ExId (_, (Ast.IdUid (_, x))))) - as e) -> - (try - let loc = Ast.loc_of_expr (List.assoc x env) in - let (a, b, c, d, e, f, g, h) = Loc.to_tuple loc - in - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), - (Ast.IdLid (_loc, "of_tuple")))))), - (Ast.ExTup (_loc, - (Ast.ExCom (_loc, - (Ast.ExStr (_loc, (Ast.safe_string_escaped a))), - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExInt (_loc, - (string_of_int b))), - (Ast.ExInt (_loc, - (string_of_int c))))), - (Ast.ExInt (_loc, - (string_of_int d))))), - (Ast.ExInt (_loc, - (string_of_int e))))), - (Ast.ExInt (_loc, (string_of_int f))))), - (Ast.ExInt (_loc, (string_of_int g))))), - (if h - then - Ast.ExId (_loc, - (Ast.IdUid (_loc, "True"))) - else - Ast.ExId (_loc, - (Ast.IdUid (_loc, "False"))))))))))) - with | Not_found -> super#expr e) - | e -> super#expr e - method patt = - function - | (Ast.PaId (_, (Ast.IdLid (_, x))) | - Ast.PaId (_, (Ast.IdUid (_, x))) - as p) -> - (try substp _loc [] (List.assoc x env) - with | Not_found -> super#patt p) - | p -> super#patt p - end - - let incorrect_number loc l1 l2 = - Loc.raise loc - (Failure - (Printf.sprintf "expected %d parameters; found %d" - (List.length l2) (List.length l1))) - - let define eo x = - ((match eo with - | Some (([], e)) -> - (Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "simple")), - [ (None, None, - [ ([ Gram.Stoken - (((function - | UIDENT camlp4_x when camlp4_x = x -> - true - | _ -> false), - "$UIDENT x")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT ((_)) -> - ((new reloc _loc)#expr e : 'expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (patt : 'patt Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "simple")), - [ (None, None, - [ ([ Gram.Stoken - (((function - | UIDENT camlp4_x when camlp4_x = x -> - true - | _ -> false), - "$UIDENT x")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT ((_)) -> - (let p = substp _loc [] e - in (new reloc _loc)#patt p : 'patt) - | _ -> assert false))) ]) ])) - ())) - | Some ((sl, e)) -> - (Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "apply")), - [ (None, None, - [ ([ Gram.Stoken - (((function - | UIDENT camlp4_x when camlp4_x = x -> - true - | _ -> false), - "$UIDENT x")); - Gram.Sself ], - (Gram.Action.mk - (fun (param : 'expr) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT ((_)) -> - (let el = - (match param with - | Ast.ExTup (_, e) -> - Ast.list_of_expr e [] - | e -> [ e ]) - in - if - (List.length el) = - (List.length sl) - then - (let env = List.combine sl el - in (new subst _loc env)#expr e) - else incorrect_number _loc el sl : - 'expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (patt : 'patt Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "simple")), - [ (None, None, - [ ([ Gram.Stoken - (((function - | UIDENT camlp4_x when camlp4_x = x -> - true - | _ -> false), - "$UIDENT x")); - Gram.Sself ], - (Gram.Action.mk - (fun (param : 'patt) - (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | UIDENT ((_)) -> - (let pl = - (match param with - | Ast.PaTup (_, p) -> - Ast.list_of_patt p [] - | p -> [ p ]) - in - if - (List.length pl) = - (List.length sl) - then - (let env = List.combine sl pl in - let p = substp _loc env e - in (new reloc _loc)#patt p) - else incorrect_number _loc pl sl : - 'patt) - | _ -> assert false))) ]) ])) - ())) - | None -> ()); - defined := (x, eo) :: !defined) - - let undef x = - try - ((let eo = List.assoc x !defined - in - match eo with - | Some (([], _)) -> - (Gram.delete_rule expr - [ Gram.Stoken - (((function - | UIDENT camlp4_x when camlp4_x = x -> true - | _ -> false), - "$UIDENT x")) ]; - Gram.delete_rule patt - [ Gram.Stoken - (((function - | UIDENT camlp4_x when camlp4_x = x -> true - | _ -> false), - "$UIDENT x")) ]) - | Some ((_, _)) -> - (Gram.delete_rule expr - [ Gram.Stoken - (((function - | UIDENT camlp4_x when camlp4_x = x -> true - | _ -> false), - "$UIDENT x")); - Gram.Sself ]; - Gram.delete_rule patt - [ Gram.Stoken - (((function - | UIDENT camlp4_x when camlp4_x = x -> true - | _ -> false), - "$UIDENT x")); - Gram.Sself ]) - | None -> ()); - defined := list_remove x !defined) - with | Not_found -> () - - let parse_def s = - match Gram.parse_string expr (Loc.mk "") s with - | Ast.ExId (_, (Ast.IdUid (_, n))) -> define None n - | Ast.ExApp (_, - (Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "=")))), - (Ast.ExId (_, (Ast.IdUid (_, n)))))), - e) -> define (Some (([], e))) n - | _ -> invalid_arg s - - (* This is a list of directories to search for INCLUDE statements. *) - let include_dirs = ref [] - - (* Add something to the above, make sure it ends with a slash. *) - let add_include_dir str = - if str <> "" - then - (let str = - if (String.get str ((String.length str) - 1)) = '/' - then str - else str ^ "/" - in include_dirs := !include_dirs @ [ str ]) - else () - - let parse_include_file rule = - let dir_ok file dir = Sys.file_exists (dir ^ file) - in - fun file -> - let file = - try - (List.find (dir_ok file) (!include_dirs @ [ "./" ])) ^ file - with | Not_found -> file in - let ch = open_in file in - let st = Stream.of_channel ch - in Gram.parse rule (Loc.mk file) st - - let rec execute_macro nil cons = - function - | SdStr i -> i - | SdDef (x, eo) -> (define eo x; nil) - | SdUnd x -> (undef x; nil) - | SdITE (b, l1, l2) -> - execute_macro_list nil cons (if b then l1 else l2) - | SdLazy l -> Lazy.force l - and execute_macro_list nil cons = - function - | [] -> nil - | hd :: tl -> (* The evaluation order is important here *) - let il1 = execute_macro nil cons hd in - let il2 = execute_macro_list nil cons tl in cons il1 il2 - - (* Stack of conditionals. *) - let stack = Stack.create () - - (* Make an SdITE value by extracting the result of the test from the stack. *) - let make_SdITE_result st1 st2 = - let test = Stack.pop stack in SdITE (test, st1, st2) - - type branch = | Then | Else - - (* Execute macro only if it belongs to the currently active branch. *) - let execute_macro_if_active_branch _loc nil cons branch macro_def = - let test = Stack.top stack in - let item = - if (test && (branch = Then)) || ((not test) && (branch = Else)) - then execute_macro nil cons macro_def - else (* ignore the macro *) nil - in SdStr item - - let _ = - let _ = (expr : 'expr Gram.Entry.t) - and _ = (sig_item : 'sig_item Gram.Entry.t) - and _ = (str_item : 'str_item Gram.Entry.t) - and _ = (patt : 'patt Gram.Entry.t) in - let grammar_entry_create = Gram.Entry.mk in - let macro_def : 'macro_def Gram.Entry.t = - grammar_entry_create "macro_def" - and uident : 'uident Gram.Entry.t = grammar_entry_create "uident" - and opt_macro_value : 'opt_macro_value Gram.Entry.t = - grammar_entry_create "opt_macro_value" - and endif : 'endif Gram.Entry.t = grammar_entry_create "endif" - and sglist_else : 'sglist_else Gram.Entry.t = - grammar_entry_create "sglist_else" - and sglist_then : 'sglist_then Gram.Entry.t = - grammar_entry_create "sglist_then" - and smlist_else : 'smlist_else Gram.Entry.t = - grammar_entry_create "smlist_else" - and smlist_then : 'smlist_then Gram.Entry.t = - grammar_entry_create "smlist_then" - and else_expr : 'else_expr Gram.Entry.t = - grammar_entry_create "else_expr" - and else_macro_def_sig : 'else_macro_def_sig Gram.Entry.t = - grammar_entry_create "else_macro_def_sig" - and else_macro_def : 'else_macro_def Gram.Entry.t = - grammar_entry_create "else_macro_def" - and uident_eval_ifndef : 'uident_eval_ifndef Gram.Entry.t = - grammar_entry_create "uident_eval_ifndef" - and uident_eval_ifdef : 'uident_eval_ifdef Gram.Entry.t = - grammar_entry_create "uident_eval_ifdef" - and macro_def_sig : 'macro_def_sig Gram.Entry.t = - grammar_entry_create "macro_def_sig" - in - (Gram.extend (str_item : 'str_item Gram.Entry.t) - ((fun () -> - ((Some Camlp4.Sig.Grammar.First), - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (macro_def : 'macro_def Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'macro_def) (_loc : Gram.Loc.t) -> - (execute_macro (Ast.StNil _loc) - (fun a b -> Ast.StSem (_loc, a, b)) x : - 'str_item)))) ]) ])) - ()); - Gram.extend (sig_item : 'sig_item Gram.Entry.t) - ((fun () -> - ((Some Camlp4.Sig.Grammar.First), - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (macro_def_sig : - 'macro_def_sig Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'macro_def_sig) (_loc : Gram.Loc.t) -> - (execute_macro (Ast.SgNil _loc) - (fun a b -> Ast.SgSem (_loc, a, b)) x : - 'sig_item)))) ]) ])) - ()); - Gram.extend (macro_def : 'macro_def Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "INCLUDE"; - Gram.Stoken - (((function | STRING ((_)) -> true | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (fname : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - (let fname = Gram.Token.extract_string fname - in - SdLazy - (lazy - (parse_include_file str_items fname)) : - 'macro_def)))); - ([ Gram.Skeyword "IFNDEF"; - Gram.Snterm - (Gram.Entry.obj - (uident_eval_ifndef : - 'uident_eval_ifndef Gram.Entry.t)); - Gram.Skeyword "THEN"; - Gram.Snterm - (Gram.Entry.obj - (smlist_then : 'smlist_then Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (else_macro_def : - 'else_macro_def Gram.Entry.t)) ], - (Gram.Action.mk - (fun (st2 : 'else_macro_def) - (st1 : 'smlist_then) _ _ _ - (_loc : Gram.Loc.t) -> - (make_SdITE_result st1 st2 : 'macro_def)))); - ([ Gram.Skeyword "IFDEF"; - Gram.Snterm - (Gram.Entry.obj - (uident_eval_ifdef : - 'uident_eval_ifdef Gram.Entry.t)); - Gram.Skeyword "THEN"; - Gram.Snterm - (Gram.Entry.obj - (smlist_then : 'smlist_then Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (else_macro_def : - 'else_macro_def Gram.Entry.t)) ], - (Gram.Action.mk - (fun (st2 : 'else_macro_def) - (st1 : 'smlist_then) _ _ _ - (_loc : Gram.Loc.t) -> - (make_SdITE_result st1 st2 : 'macro_def)))); - ([ Gram.Skeyword "UNDEF"; - Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'uident) _ (_loc : Gram.Loc.t) -> - (SdUnd i : 'macro_def)))); - ([ Gram.Skeyword "DEFINE"; - Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (opt_macro_value : - 'opt_macro_value Gram.Entry.t)) ], - (Gram.Action.mk - (fun (def : 'opt_macro_value) (i : 'uident) _ - (_loc : Gram.Loc.t) -> - (SdDef (i, def) : 'macro_def)))) ]) ])) - ()); - Gram.extend (macro_def_sig : 'macro_def_sig Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "INCLUDE"; - Gram.Stoken - (((function | STRING ((_)) -> true | _ -> false), - "STRING _")) ], - (Gram.Action.mk - (fun (fname : Gram.Token.t) _ - (_loc : Gram.Loc.t) -> - (let fname = Gram.Token.extract_string fname - in - SdLazy - (lazy - (parse_include_file sig_items fname)) : - 'macro_def_sig)))); - ([ Gram.Skeyword "IFNDEF"; - Gram.Snterm - (Gram.Entry.obj - (uident_eval_ifndef : - 'uident_eval_ifndef Gram.Entry.t)); - Gram.Skeyword "THEN"; - Gram.Snterm - (Gram.Entry.obj - (sglist_then : 'sglist_then Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (else_macro_def_sig : - 'else_macro_def_sig Gram.Entry.t)) ], - (Gram.Action.mk - (fun (sg2 : 'else_macro_def_sig) - (sg1 : 'sglist_then) _ _ _ - (_loc : Gram.Loc.t) -> - (make_SdITE_result sg1 sg2 : 'macro_def_sig)))); - ([ Gram.Skeyword "IFDEF"; - Gram.Snterm - (Gram.Entry.obj - (uident_eval_ifdef : - 'uident_eval_ifdef Gram.Entry.t)); - Gram.Skeyword "THEN"; - Gram.Snterm - (Gram.Entry.obj - (sglist_then : 'sglist_then Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (else_macro_def_sig : - 'else_macro_def_sig Gram.Entry.t)) ], - (Gram.Action.mk - (fun (sg2 : 'else_macro_def_sig) - (sg1 : 'sglist_then) _ _ _ - (_loc : Gram.Loc.t) -> - (make_SdITE_result sg1 sg2 : 'macro_def_sig)))); - ([ Gram.Skeyword "UNDEF"; - Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'uident) _ (_loc : Gram.Loc.t) -> - (SdUnd i : 'macro_def_sig)))); - ([ Gram.Skeyword "DEFINE"; - Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'uident) _ (_loc : Gram.Loc.t) -> - (SdDef (i, None) : 'macro_def_sig)))) ]) ])) - ()); - Gram.extend - (uident_eval_ifdef : 'uident_eval_ifdef Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'uident) (_loc : Gram.Loc.t) -> - (Stack.push (is_defined i) stack : - 'uident_eval_ifdef)))) ]) ])) - ()); - Gram.extend - (uident_eval_ifndef : 'uident_eval_ifndef Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (i : 'uident) (_loc : Gram.Loc.t) -> - (Stack.push (not (is_defined i)) stack : - 'uident_eval_ifndef)))) ]) ])) - ()); - Gram.extend (else_macro_def : 'else_macro_def Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - ([] : 'else_macro_def)))); - ([ Gram.Skeyword "ELSE"; - Gram.Snterm - (Gram.Entry.obj - (smlist_else : 'smlist_else Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (st : 'smlist_else) _ (_loc : Gram.Loc.t) - -> (st : 'else_macro_def)))) ]) ])) - ()); - Gram.extend - (else_macro_def_sig : 'else_macro_def_sig Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - ([] : 'else_macro_def_sig)))); - ([ Gram.Skeyword "ELSE"; - Gram.Snterm - (Gram.Entry.obj - (sglist_else : 'sglist_else Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (st : 'sglist_else) _ (_loc : Gram.Loc.t) - -> (st : 'else_macro_def_sig)))) ]) ])) - ()); - Gram.extend (else_expr : 'else_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))) : - 'else_expr)))); - ([ Gram.Skeyword "ELSE"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (e : 'expr) _ (_loc : Gram.Loc.t) -> - (e : 'else_expr)))) ]) ])) - ()); - Gram.extend (smlist_then : 'smlist_then Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist1 - (Gram.srules smlist_then - [ ([ Gram.Snterm - (Gram.Entry.obj - (str_item : - 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (si : 'str_item) - (_loc : Gram.Loc.t) -> - (SdStr si : 'e__25)))); - ([ Gram.Snterm - (Gram.Entry.obj - (macro_def : - 'macro_def Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (d : 'macro_def) - (_loc : Gram.Loc.t) -> - (execute_macro_if_active_branch - _loc (Ast.StNil _loc) - (fun a b -> - Ast.StSem (_loc, a, b)) - Then d : - 'e__25)))) ]) ], - (Gram.Action.mk - (fun (sml : 'e__25 list) (_loc : Gram.Loc.t) -> - (sml : 'smlist_then)))) ]) ])) - ()); - Gram.extend (smlist_else : 'smlist_else Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist1 - (Gram.srules smlist_else - [ ([ Gram.Snterm - (Gram.Entry.obj - (str_item : - 'str_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (si : 'str_item) - (_loc : Gram.Loc.t) -> - (SdStr si : 'e__26)))); - ([ Gram.Snterm - (Gram.Entry.obj - (macro_def : - 'macro_def Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (d : 'macro_def) - (_loc : Gram.Loc.t) -> - (execute_macro_if_active_branch - _loc (Ast.StNil _loc) - (fun a b -> - Ast.StSem (_loc, a, b)) - Else d : - 'e__26)))) ]) ], - (Gram.Action.mk - (fun (sml : 'e__26 list) (_loc : Gram.Loc.t) -> - (sml : 'smlist_else)))) ]) ])) - ()); - Gram.extend (sglist_then : 'sglist_then Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist1 - (Gram.srules sglist_then - [ ([ Gram.Snterm - (Gram.Entry.obj - (sig_item : - 'sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (si : 'sig_item) - (_loc : Gram.Loc.t) -> - (SdStr si : 'e__27)))); - ([ Gram.Snterm - (Gram.Entry.obj - (macro_def_sig : - 'macro_def_sig Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (d : 'macro_def_sig) - (_loc : Gram.Loc.t) -> - (execute_macro_if_active_branch - _loc (Ast.SgNil _loc) - (fun a b -> - Ast.SgSem (_loc, a, b)) - Then d : - 'e__27)))) ]) ], - (Gram.Action.mk - (fun (sgl : 'e__27 list) (_loc : Gram.Loc.t) -> - (sgl : 'sglist_then)))) ]) ])) - ()); - Gram.extend (sglist_else : 'sglist_else Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Slist1 - (Gram.srules sglist_else - [ ([ Gram.Snterm - (Gram.Entry.obj - (sig_item : - 'sig_item Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (si : 'sig_item) - (_loc : Gram.Loc.t) -> - (SdStr si : 'e__28)))); - ([ Gram.Snterm - (Gram.Entry.obj - (macro_def_sig : - 'macro_def_sig Gram.Entry.t)); - Gram.Snterm - (Gram.Entry.obj - (semi : 'semi Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (d : 'macro_def_sig) - (_loc : Gram.Loc.t) -> - (execute_macro_if_active_branch - _loc (Ast.SgNil _loc) - (fun a b -> - Ast.SgSem (_loc, a, b)) - Else d : - 'e__28)))) ]) ], - (Gram.Action.mk - (fun (sgl : 'e__28 list) (_loc : Gram.Loc.t) -> - (sgl : 'sglist_else)))) ]) ])) - ()); - Gram.extend (endif : 'endif Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "ENDIF" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> (() : 'endif)))); - ([ Gram.Skeyword "END" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> (() : 'endif)))) ]) ])) - ()); - Gram.extend (opt_macro_value : 'opt_macro_value Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([], - (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (None : 'opt_macro_value)))); - ([ Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (Some (([], e)) : 'opt_macro_value)))); - ([ Gram.Skeyword "("; - Gram.Slist1sep - ((Gram.srules opt_macro_value - [ ([ Gram.Stoken - (((function - | LIDENT ((_)) -> true - | _ -> false), - "LIDENT _")) ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (let x = - Gram.Token.extract_string x - in x : 'e__29)))) ]), - (Gram.Skeyword ",")); - Gram.Skeyword ")"; Gram.Skeyword "="; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ _ (pl : 'e__29 list) _ - (_loc : Gram.Loc.t) -> - (Some ((pl, e)) : 'opt_macro_value)))) ]) ])) - ()); - Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "top")), - [ (None, None, - [ ([ Gram.Skeyword "DEFINE"; - Gram.Stoken - (((function | LIDENT ((_)) -> true | _ -> false), - "LIDENT _")); - Gram.Skeyword "="; Gram.Sself; - Gram.Skeyword "IN"; Gram.Sself ], - (Gram.Action.mk - (fun (body : 'expr) _ (def : 'expr) _ - (i : Gram.Token.t) _ (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i - in (new subst _loc [ (i, def) ])#expr body : - 'expr)))); - ([ Gram.Skeyword "IFNDEF"; - Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); - Gram.Skeyword "THEN"; Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (else_expr : 'else_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e2 : 'else_expr) (e1 : 'expr) _ - (i : 'uident) _ (_loc : Gram.Loc.t) -> - (if is_defined i then e2 else e1 : 'expr)))); - ([ Gram.Skeyword "IFDEF"; - Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); - Gram.Skeyword "THEN"; Gram.Sself; - Gram.Snterm - (Gram.Entry.obj - (else_expr : 'else_expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e2 : 'else_expr) (e1 : 'expr) _ - (i : 'uident) _ (_loc : Gram.Loc.t) -> - (if is_defined i then e1 else e2 : 'expr)))) ]) ])) - ()); - Gram.extend (patt : 'patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "IFNDEF"; - Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); - Gram.Skeyword "THEN"; Gram.Sself; - Gram.Skeyword "ELSE"; Gram.Sself; - Gram.Snterm - (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (p2 : 'patt) _ (p1 : 'patt) _ - (i : 'uident) _ (_loc : Gram.Loc.t) -> - (if is_defined i then p2 else p1 : 'patt)))); - ([ Gram.Skeyword "IFDEF"; - Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); - Gram.Skeyword "THEN"; Gram.Sself; - Gram.Skeyword "ELSE"; Gram.Sself; - Gram.Snterm - (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], - (Gram.Action.mk - (fun _ (p2 : 'patt) _ (p1 : 'patt) _ - (i : 'uident) _ (_loc : Gram.Loc.t) -> - (if is_defined i then p1 else p2 : 'patt)))) ]) ])) - ()); - Gram.extend (uident : 'uident Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | UIDENT ((_)) -> true | _ -> false), - "UIDENT _")) ], - (Gram.Action.mk - (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) -> - (let i = Gram.Token.extract_string i in i : - 'uident)))) ]) ])) - ()); - Gram.extend - (* dirty hack to allow polymorphic variants using the introduced keywords. *) - (expr : 'expr Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Before "simple")), - [ (None, None, - [ ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.ExVrn (_loc, s) : 'expr)))); - ([ Gram.Skeyword "`"; - Gram.srules expr - [ ([ Gram.Skeyword "IN" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__30)))); - ([ Gram.Skeyword "DEFINE" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__30)))); - ([ Gram.Skeyword "ENDIF" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__30)))); - ([ Gram.Skeyword "END" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__30)))); - ([ Gram.Skeyword "ELSE" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__30)))); - ([ Gram.Skeyword "THEN" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__30)))); - ([ Gram.Skeyword "IFNDEF" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__30)))); - ([ Gram.Skeyword "IFDEF" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__30)))) ] ], - (Gram.Action.mk - (fun (kwd : 'e__30) _ (_loc : Gram.Loc.t) -> - (Ast.ExVrn (_loc, kwd) : 'expr)))) ]) ])) - ()); - Gram.extend (* idem *) (patt : 'patt Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Before "simple")), - [ (None, None, - [ ([ Gram.Skeyword "`"; - Gram.Snterm - (Gram.Entry.obj - (a_ident : 'a_ident Gram.Entry.t)) ], - (Gram.Action.mk - (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) -> - (Ast.PaVrn (_loc, s) : 'patt)))); - ([ Gram.Skeyword "`"; - Gram.srules patt - [ ([ Gram.Skeyword "ENDIF" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__31)))); - ([ Gram.Skeyword "END" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__31)))); - ([ Gram.Skeyword "ELSE" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__31)))); - ([ Gram.Skeyword "THEN" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__31)))); - ([ Gram.Skeyword "IFNDEF" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__31)))); - ([ Gram.Skeyword "IFDEF" ], - (Gram.Action.mk - (fun (x : Gram.Token.t) - (_loc : Gram.Loc.t) -> - (Gram.Token.extract_string x : 'e__31)))) ] ], - (Gram.Action.mk - (fun (kwd : 'e__31) _ (_loc : Gram.Loc.t) -> - (Ast.PaVrn (_loc, kwd) : 'patt)))) ]) ])) - ())) - - let _ = - Options.add "-D" (Arg.String parse_def) - " Define for IFDEF instruction." - - let _ = - Options.add "-U" (Arg.String undef) - " Undefine for IFDEF instruction." - - let _ = - Options.add "-I" (Arg.String add_include_dir) - " Add a directory to INCLUDE search path." - - end - - let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () - - module MakeNothing (AstFilters : Camlp4.Sig.AstFilters) = - struct - open AstFilters - - open Ast - - (* Remove NOTHING and expanse __FILE__ and __LOCATION__ *) - let map_expr = - function - | Ast.ExApp (_, e, (Ast.ExId (_, (Ast.IdUid (_, "NOTHING"))))) | - Ast.ExFun (_, - (Ast.McArr (_, (Ast.PaId (_, (Ast.IdUid (_, "NOTHING")))), - (Ast.ExNil _), e))) - -> e - | Ast.ExId (_loc, (Ast.IdLid (_, "__FILE__"))) -> - Ast.ExStr (_loc, - (Ast.safe_string_escaped (Loc.file_name _loc))) - | Ast.ExId (_loc, (Ast.IdLid (_, "__LOCATION__"))) -> - let (a, b, c, d, e, f, g, h) = Loc.to_tuple _loc - in - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), - (Ast.IdLid (_loc, "of_tuple")))))), - (Ast.ExTup (_loc, - (Ast.ExCom (_loc, - (Ast.ExStr (_loc, (Ast.safe_string_escaped a))), - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExInt (_loc, - (string_of_int b))), - (Ast.ExInt (_loc, - (string_of_int c))))), - (Ast.ExInt (_loc, (string_of_int d))))), - (Ast.ExInt (_loc, (string_of_int e))))), - (Ast.ExInt (_loc, (string_of_int f))))), - (Ast.ExInt (_loc, (string_of_int g))))), - (if h - then Ast.ExId (_loc, (Ast.IdUid (_loc, "True"))) - else Ast.ExId (_loc, (Ast.IdUid (_loc, "False"))))))))))) - | e -> e - - let _ = register_str_item_filter (Ast.map_expr map_expr)#str_item - - end - - let _ = let module M = Camlp4.Register.AstFilter(Id)(MakeNothing) in () - - end - -module D = - struct - open Camlp4 - - (* -*- camlp4r -*- *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Nicolas Pouillard: initial version - *) - module Id = - struct let name = "Camlp4DebugParser" - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - open Sig - - include Syntax - - module StringSet = Set.Make(String) - - let debug_mode = - try - let str = Sys.getenv "STATIC_CAMLP4_DEBUG" in - let rec loop acc i = - try - let pos = String.index_from str i ':' - in - loop (StringSet.add (String.sub str i (pos - i)) acc) - (pos + 1) - with - | Not_found -> - StringSet.add (String.sub str i ((String.length str) - i)) - acc in - let sections = loop StringSet.empty 0 - in - if StringSet.mem "*" sections - then (fun _ -> true) - else (fun x -> StringSet.mem x sections) - with | Not_found -> (fun _ -> false) - - let rec apply accu = - function - | [] -> accu - | x :: xs -> - let _loc = Ast.loc_of_expr x - in apply (Ast.ExApp (_loc, accu, x)) xs - - let mk_debug_mode _loc = - function - | None -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Debug")), - (Ast.IdLid (_loc, "mode"))))) - | Some m -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, m)), - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Debug")), - (Ast.IdLid (_loc, "mode"))))))) - - let mk_debug _loc m fmt section args = - let call = - apply - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Debug")), - (Ast.IdLid (_loc, "printf")))))), - (Ast.ExStr (_loc, section)))), - (Ast.ExStr (_loc, fmt)))) - args - in - Ast.ExIfe (_loc, - (Ast.ExApp (_loc, (mk_debug_mode _loc m), - (Ast.ExStr (_loc, section)))), - call, (Ast.ExId (_loc, (Ast.IdUid (_loc, "()"))))) - - let _ = - let _ = (expr : 'expr Gram.Entry.t) in - let grammar_entry_create = Gram.Entry.mk in - let end_or_in : 'end_or_in Gram.Entry.t = - grammar_entry_create "end_or_in" - and start_debug : 'start_debug Gram.Entry.t = - grammar_entry_create "start_debug" - in - (Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj - (start_debug : 'start_debug Gram.Entry.t)); - Gram.Stoken - (((function | LIDENT ((_)) -> true | _ -> false), - "LIDENT _")); - Gram.Stoken - (((function | STRING ((_)) -> true | _ -> false), - "STRING _")); - Gram.Slist0 - (Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - ".")); - Gram.Snterm - (Gram.Entry.obj - (end_or_in : 'end_or_in Gram.Entry.t)) ], - (Gram.Action.mk - (fun (x : 'end_or_in) (args : 'expr list) - (fmt : Gram.Token.t) (section : Gram.Token.t) - (m : 'start_debug) (_loc : Gram.Loc.t) -> - (let fmt = Gram.Token.extract_string fmt in - let section = - Gram.Token.extract_string section - in - match (x, (debug_mode section)) with - | (None, false) -> - Ast.ExId (_loc, - (Ast.IdUid (_loc, "()"))) - | (Some e, false) -> e - | (None, _) -> - mk_debug _loc m fmt section args - | (Some e, _) -> - Ast.ExLet (_loc, Ast.ReNil, - (Ast.BiEq (_loc, - (Ast.PaId (_loc, - (Ast.IdUid (_loc, "()")))), - (mk_debug _loc m fmt section args))), - e) : - 'expr)))) ]) ])) - ()); - Gram.extend (end_or_in : 'end_or_in Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Skeyword "in"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (e : 'expr) _ (_loc : Gram.Loc.t) -> - (Some e : 'end_or_in)))); - ([ Gram.Skeyword "end" ], - (Gram.Action.mk - (fun _ (_loc : Gram.Loc.t) -> - (None : 'end_or_in)))) ]) ])) - ()); - Gram.extend (start_debug : 'start_debug Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function - | LIDENT "camlp4_debug" -> true - | _ -> false), - "LIDENT \"camlp4_debug\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT "camlp4_debug" -> - (Some "Camlp4" : 'start_debug) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | LIDENT "debug" -> true - | _ -> false), - "LIDENT \"debug\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT "debug" -> (None : 'start_debug) - | _ -> assert false))) ]) ])) - ())) - - end - - let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () - - end - -module L = - struct - open Camlp4 - - (* -*- camlp4r -*- *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2007 Institut National de Recherche en Informatique et *) - (* en Automatique. All rights reserved. This file is distributed under *) - (* the terms of the GNU Library General Public License, with the special *) - (* exception on linking described in LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Nao Hirokawa: initial version - * - Nicolas Pouillard: revised syntax version - *) - module Id = - struct - let name = "Camlp4ListComprehension" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - open Sig - - include Syntax - - let rec loop n = - function - | [] -> None - | [ (x, _) ] -> if n = 1 then Some x else None - | _ :: l -> loop (n - 1) l - - let stream_peek_nth n strm = loop n (Stream.npeek n strm) - - (* usual trick *) - let test_patt_lessminus = - Gram.Entry.of_parser "test_patt_lessminus" - (fun strm -> - let rec skip_patt n = - match stream_peek_nth n strm with - | Some (KEYWORD "<-") -> n - | Some (KEYWORD ("[" | "[<")) -> - skip_patt ((ignore_upto "]" (n + 1)) + 1) - | Some (KEYWORD "(") -> - skip_patt ((ignore_upto ")" (n + 1)) + 1) - | Some (KEYWORD "{") -> - skip_patt ((ignore_upto "}" (n + 1)) + 1) - | Some (KEYWORD ("as" | "::" | "," | "_")) | - Some (LIDENT _ | UIDENT _) -> skip_patt (n + 1) - | Some _ | None -> raise Stream.Failure - and ignore_upto end_kwd n = - match stream_peek_nth n strm with - | Some (KEYWORD prm) when prm = end_kwd -> n - | Some (KEYWORD ("[" | "[<")) -> - ignore_upto end_kwd ((ignore_upto "]" (n + 1)) + 1) - | Some (KEYWORD "(") -> - ignore_upto end_kwd ((ignore_upto ")" (n + 1)) + 1) - | Some (KEYWORD "{") -> - ignore_upto end_kwd ((ignore_upto "}" (n + 1)) + 1) - | Some _ -> ignore_upto end_kwd (n + 1) - | None -> raise Stream.Failure - in skip_patt 1) - - let map _loc p e l = - match (p, e) with - | (Ast.PaId (_, (Ast.IdLid (_, x))), - Ast.ExId (_, (Ast.IdLid (_, y)))) when x = y -> l - | _ -> - if Ast.is_irrefut_patt p - then - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "List")), - (Ast.IdLid (_loc, "map")))))), - (Ast.ExFun (_loc, - (Ast.McArr (_loc, p, (Ast.ExNil _loc), e)))))), - l) - else - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "List")), - (Ast.IdLid (_loc, "fold_right")))))), - (Ast.ExFun (_loc, - (Ast.McOr (_loc, - (Ast.McArr (_loc, p, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "True")))), - (Ast.ExApp (_loc, - (Ast.ExFun (_loc, - (Ast.McArr (_loc, - (Ast.PaId (_loc, - (Ast.IdLid (_loc, "x")))), - (Ast.ExNil _loc), - (Ast.ExFun (_loc, - (Ast.McArr (_loc, - (Ast.PaId (_loc, - (Ast.IdLid (_loc, "xs")))), - (Ast.ExNil _loc), - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, - "::")))), - (Ast.ExId (_loc, - (Ast.IdLid (_loc, - "x")))))), - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "xs")))))))))))))), - e)))), - (Ast.McArr (_loc, (Ast.PaAny _loc), - (Ast.ExNil _loc), - (Ast.ExFun (_loc, - (Ast.McArr (_loc, - (Ast.PaId (_loc, - (Ast.IdLid (_loc, "l")))), - (Ast.ExNil _loc), - (Ast.ExId (_loc, - (Ast.IdLid (_loc, "l")))))))))))))))), - l)), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))))) - - let filter _loc p b l = - if Ast.is_irrefut_patt p - then - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "List")), - (Ast.IdLid (_loc, "filter")))))), - (Ast.ExFun (_loc, - (Ast.McArr (_loc, p, (Ast.ExNil _loc), b)))))), - l) - else - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "List")), - (Ast.IdLid (_loc, "filter")))))), - (Ast.ExFun (_loc, - (Ast.McOr (_loc, - (Ast.McArr (_loc, p, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "True")))), b)), - (Ast.McArr (_loc, (Ast.PaAny _loc), (Ast.ExNil _loc), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "False")))))))))))), - l) - - let concat _loc l = - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "List")), - (Ast.IdLid (_loc, "concat")))))), - l) - - let rec compr _loc e = - function - | [ `gen ((p, l)) ] -> map _loc p e l - | `gen ((p, l)) :: `cond b :: items -> - compr _loc e ((`gen ((p, (filter _loc p b l)))) :: items) - | `gen ((p, l)) :: ((`gen ((_, _)) :: _ as is)) -> - concat _loc (map _loc p (compr _loc e is) l) - | _ -> raise Stream.Failure - - let _ = - Gram.delete_rule expr - [ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t)); - Gram.Skeyword "]" ] - - let is_revised = - try - (Gram.delete_rule expr - [ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t)); - Gram.Skeyword "::"; - Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Skeyword "]" ]; - true) - with | Struct.Grammar.Delete.Rule_not_found _ -> false - - let comprehension_or_sem_expr_for_list = - Gram.Entry.mk "comprehension_or_sem_expr_for_list" - - let _ = - let _ = (expr : 'expr Gram.Entry.t) - and _ = - (comprehension_or_sem_expr_for_list : - 'comprehension_or_sem_expr_for_list Gram.Entry.t) in - let grammar_entry_create = Gram.Entry.mk in - let item : 'item Gram.Entry.t = grammar_entry_create "item" - in - (Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "simple")), - [ (None, None, - [ ([ Gram.Skeyword "["; - Gram.Snterm - (Gram.Entry.obj - (comprehension_or_sem_expr_for_list : - 'comprehension_or_sem_expr_for_list Gram. - Entry.t)); - Gram.Skeyword "]" ], - (Gram.Action.mk - (fun _ (e : 'comprehension_or_sem_expr_for_list) - _ (_loc : Gram.Loc.t) -> (e : 'expr)))) ]) ])) - ()); - Gram.extend - (comprehension_or_sem_expr_for_list : - 'comprehension_or_sem_expr_for_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top") ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))))) : - 'comprehension_or_sem_expr_for_list)))); - ([ Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top"); - Gram.Skeyword "|"; - Gram.Slist1sep - ((Gram.Snterm - (Gram.Entry.obj (item : 'item Gram.Entry.t))), - (Gram.Skeyword ";")) ], - (Gram.Action.mk - (fun (l : 'item list) _ (e : 'expr) - (_loc : Gram.Loc.t) -> - (compr _loc e l : - 'comprehension_or_sem_expr_for_list)))); - ([ Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top"); - Gram.Skeyword ";" ], - (Gram.Action.mk - (fun _ (e : 'expr) (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - (Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))))) : - 'comprehension_or_sem_expr_for_list)))); - ([ Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top"); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (sem_expr_for_list : - 'sem_expr_for_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (mk : 'sem_expr_for_list) _ (e : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - (mk - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "[]")))))) : - 'comprehension_or_sem_expr_for_list)))) ]) ])) - ()); - Gram.extend (item : 'item Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ (* NP: These rules rely on being on this particular order. Which should - be improved. *) - Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top") ], - (Gram.Action.mk - (fun (e : 'expr) (_loc : Gram.Loc.t) -> - (`cond e : 'item)))); - ([ Gram.Stry - (Gram.srules item - [ ([ Gram.Snterm - (Gram.Entry.obj - (patt : 'patt Gram.Entry.t)); - Gram.Skeyword "<-" ], - (Gram.Action.mk - (fun _ (p : 'patt) (_loc : Gram.Loc.t) - -> (p : 'e__32)))) ]); - Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top") ], - (Gram.Action.mk - (fun (e : 'expr) (p : 'e__32) - (_loc : Gram.Loc.t) -> - (`gen ((p, e)) : 'item)))) ]) ])) - ())) - - let _ = - if is_revised - then - (let _ = (expr : 'expr Gram.Entry.t) - and _ = - (comprehension_or_sem_expr_for_list : - 'comprehension_or_sem_expr_for_list Gram.Entry.t) - in - Gram.extend - (comprehension_or_sem_expr_for_list : - 'comprehension_or_sem_expr_for_list Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top"); - Gram.Skeyword "::"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (last : 'expr) _ (e : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - last) : - 'comprehension_or_sem_expr_for_list)))); - ([ Gram.Snterml - ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)), - "top"); - Gram.Skeyword ";"; - Gram.Snterm - (Gram.Entry.obj - (sem_expr_for_list : - 'sem_expr_for_list Gram.Entry.t)); - Gram.Skeyword "::"; - Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], - (Gram.Action.mk - (fun (last : 'expr) _ - (mk : 'sem_expr_for_list) _ (e : 'expr) - (_loc : Gram.Loc.t) -> - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "::")))), - e)), - (mk last)) : - 'comprehension_or_sem_expr_for_list)))) ]) ])) - ())) - else () - - end - - let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () - - end - -module P = - struct - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Nicolas Pouillard: initial version - *) - let _ = Camlp4.Register.enable_dump_ocaml_ast_printer () - - end - -module B = - struct - (* camlp4r *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - open Camlp4 - - open PreCast.Syntax - - open PreCast - - open Format - - module CleanAst = Camlp4.Struct.CleanAst.Make(Ast) - - module SSet = Set.Make(String) - - let pa_r = "Camlp4OCamlRevisedParser" - - let pa_rr = "Camlp4OCamlReloadedParser" - - let pa_o = "Camlp4OCamlParser" - - let pa_rp = "Camlp4OCamlRevisedParserParser" - - let pa_op = "Camlp4OCamlParserParser" - - let pa_g = "Camlp4GrammarParser" - - let pa_m = "Camlp4MacroParser" - - let pa_qb = "Camlp4QuotationCommon" - - let pa_q = "Camlp4QuotationExpander" - - let pa_rq = "Camlp4OCamlRevisedQuotationExpander" - - let pa_oq = "Camlp4OCamlOriginalQuotationExpander" - - let pa_l = "Camlp4ListComprehension" - - open Register - - let dyn_loader = - ref (fun _ -> raise (Match_failure ("./camlp4/Camlp4Bin.ml", 45, 24))) - - let rcall_callback = ref (fun () -> ()) - - let loaded_modules = ref SSet.empty - - let add_to_loaded_modules name = - loaded_modules := SSet.add name !loaded_modules - - let (objext, libext) = - if DynLoader.is_native then (".cmxs", ".cmxs") else (".cmo", ".cma") - - let rewrite_and_load n x = - let dyn_loader = !dyn_loader () in - let find_in_path = DynLoader.find_in_path dyn_loader in - let real_load name = - (add_to_loaded_modules name; DynLoader.load dyn_loader name) in - let load = - List.iter - (fun n -> - if - (SSet.mem n !loaded_modules) || - (List.mem n !Register.loaded_modules) - then () - else - (add_to_loaded_modules n; - DynLoader.load dyn_loader (n ^ objext))) - in - ((match (n, (String.lowercase x)) with - | (("Parsers" | ""), - ("pa_r.cmo" | "r" | "ocamlr" | "ocamlrevised" | - "camlp4ocamlrevisedparser.cmo")) - -> load [ pa_r ] - | (("Parsers" | ""), - ("rr" | "reloaded" | "ocamlreloaded" | - "camlp4ocamlreloadedparser.cmo")) - -> load [ pa_rr ] - | (("Parsers" | ""), - ("pa_o.cmo" | "o" | "ocaml" | "camlp4ocamlparser.cmo")) -> - load [ pa_r; pa_o ] - | (("Parsers" | ""), - ("pa_rp.cmo" | "rp" | "rparser" | - "camlp4ocamlrevisedparserparser.cmo")) - -> load [ pa_r; pa_rp ] - | (("Parsers" | ""), - ("pa_op.cmo" | "op" | "parser" | "camlp4ocamlparserparser.cmo")) - -> load [ pa_r; pa_o; pa_rp; pa_op ] - | (("Parsers" | ""), - ("pa_extend.cmo" | "pa_extend_m.cmo" | "g" | "grammar" | - "camlp4grammarparser.cmo")) - -> load [ pa_g ] - | (("Parsers" | ""), - ("pa_macro.cmo" | "m" | "macro" | "camlp4macroparser.cmo")) -> - load [ pa_m ] - | (("Parsers" | ""), ("q" | "camlp4quotationexpander.cmo")) -> - load [ pa_qb; pa_q ] - | (("Parsers" | ""), - ("q_mlast.cmo" | "rq" | - "camlp4ocamlrevisedquotationexpander.cmo")) - -> load [ pa_qb; pa_rq ] - | (("Parsers" | ""), - ("oq" | "camlp4ocamloriginalquotationexpander.cmo")) -> - load [ pa_r; pa_o; pa_qb; pa_oq ] - | (("Parsers" | ""), "rf") -> - load [ pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m ] - | (("Parsers" | ""), "of") -> - load - [ pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_q; pa_g; pa_l; pa_m ] - | (("Parsers" | ""), ("comp" | "camlp4listcomprehension.cmo")) -> - load [ pa_l ] - | (("Filters" | ""), ("lift" | "camlp4astlifter.cmo")) -> - load [ "Camlp4AstLifter" ] - | (("Filters" | ""), ("exn" | "camlp4exceptiontracer.cmo")) -> - load [ "Camlp4ExceptionTracer" ] - | (("Filters" | ""), ("prof" | "camlp4profiler.cmo")) -> - load [ "Camlp4Profiler" ] - | (* 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" ] - | (("Filters" | ""), ("striploc" | "camlp4locationstripper.cmo")) - -> load [ "Camlp4LocationStripper" ] - | (("Printers" | ""), - ("pr_r.cmo" | "r" | "ocamlr" | "camlp4ocamlrevisedprinter.cmo")) - -> Register.enable_ocamlr_printer () - | (("Printers" | ""), - ("pr_o.cmo" | "o" | "ocaml" | "camlp4ocamlprinter.cmo")) -> - Register.enable_ocaml_printer () - | (("Printers" | ""), - ("pr_dump.cmo" | "p" | "dumpocaml" | "camlp4ocamlastdumper.cmo")) - -> Register.enable_dump_ocaml_ast_printer () - | (("Printers" | ""), ("d" | "dumpcamlp4" | "camlp4astdumper.cmo")) - -> Register.enable_dump_camlp4_ast_printer () - | (("Printers" | ""), ("a" | "auto" | "camlp4autoprinter.cmo")) -> - load [ "Camlp4AutoPrinter" ] - | _ -> - let y = "Camlp4" ^ (n ^ ("/" ^ (x ^ objext))) - in real_load (try find_in_path y with | Not_found -> x)); - !rcall_callback ()) - - let print_warning = eprintf "%a:\n%s@." Loc.print - - let rec parse_file dyn_loader name pa getdir = - let directive_handler = - Some - (fun ast -> - match getdir ast with - | Some x -> - (match x with - | (_, "load", s) -> (rewrite_and_load "" s; None) - | (_, "directory", s) -> - (DynLoader.include_dir dyn_loader s; None) - | (_, "use", s) -> Some (parse_file dyn_loader s pa getdir) - | (_, "default_quotation", s) -> - (Quotation.default := s; None) - | (loc, _, _) -> - Loc.raise loc (Stream.Error "bad directive")) - | None -> None) in - let loc = Loc.mk name - in - (current_warning := 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 phr = - try pa ?directive_handler loc cs with | x -> (clear (); raise x) - in (clear (); phr)) - - let output_file = ref None - - let process dyn_loader name pa pr clean fold_filters getdir = - let ast = parse_file dyn_loader name pa getdir in - let ast = fold_filters (fun t filter -> filter t) ast in - let ast = clean ast - in pr ?input_file: (Some name) ?output_file: !output_file ast - - let gind = - function - | Ast.SgDir (loc, n, (Ast.ExStr (_, s))) -> Some ((loc, n, s)) - | _ -> None - - let gimd = - function - | Ast.StDir (loc, n, (Ast.ExStr (_, s))) -> Some ((loc, n, s)) - | _ -> None - - let process_intf dyn_loader name = - process dyn_loader name CurrentParser.parse_interf CurrentPrinter. - print_interf (new CleanAst.clean_ast)#sig_item AstFilters. - fold_interf_filters gind - - let process_impl dyn_loader name = - process dyn_loader name CurrentParser.parse_implem CurrentPrinter. - print_implem (new CleanAst.clean_ast)#str_item AstFilters. - fold_implem_filters gimd - - let just_print_the_version () = - (printf "%s@." Camlp4_config.version; exit 0) - - let print_version () = - (eprintf "Camlp4 version %s@." Camlp4_config.version; exit 0) - - let print_stdlib () = - (printf "%s@." Camlp4_config.camlp4_standard_library; exit 0) - - let usage ini_sl ext_sl = - (eprintf - "\ -Usage: camlp4 [load-options] [--] [other-options]\n\ -Options:\n\ -.ml Parse this implementation file\n\ -.mli Parse this interface file\n\ -.%s Load this module inside the Camlp4 core@." - (if DynLoader.is_native then "cmxs " else "(cmo|cma)"); - Options.print_usage_list ini_sl; - (* loop (ini_sl @ ext_sl) where rec loop = - fun - [ [(y, _, _) :: _] when y = "-help" -> () - | [_ :: sl] -> loop sl - | [] -> eprintf " -help Display this list of options.@." ]; *) - if ext_sl <> [] - then - (eprintf "Options added by loaded object files:@."; - Options.print_usage_list ext_sl) - else ()) - - let warn_noassert () = - eprintf - "\ -camlp4 warning: option -noassert is obsolete\n\ -You should give the -noassert option to the ocaml compiler instead.@." - - type file_kind = - | Intf of string - | Impl of string - | Str of string - | ModuleImpl of string - | IncludeDir of string - - let search_stdlib = ref true - - let print_loaded_modules = ref false - - let (task, do_task) = - let t = ref None in - let task f x = - let () = Camlp4_config.current_input_file := x - in - t := - Some - (if !t = None then (fun _ -> f x) else (fun usage -> usage ())) in - let do_task usage = match !t with | Some f -> f usage | None -> () - in (task, do_task) - - let input_file x = - let dyn_loader = !dyn_loader () - in - (!rcall_callback (); - (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 -> - let (f, o) = Filename.open_temp_file "from_string" ".ml" - in - (output_string o s; - close_out o; - task (process_impl dyn_loader) f; - at_exit (fun () -> Sys.remove f)) - | ModuleImpl file_name -> rewrite_and_load "" file_name - | IncludeDir dir -> DynLoader.include_dir dyn_loader dir); - !rcall_callback ()) - - let initial_spec_list = - [ ("-I", (Arg.String (fun x -> input_file (IncludeDir x))), - " Add directory in search patch for object files."); - ("-where", (Arg.Unit print_stdlib), - "Print camlp4 library directory and exit."); - ("-nolib", (Arg.Clear search_stdlib), - "No automatic search for object files in library directory."); - ("-intf", (Arg.String (fun x -> input_file (Intf x))), - " Parse as an interface, whatever its extension."); - ("-impl", (Arg.String (fun x -> input_file (Impl x))), - " Parse as an implementation, whatever its extension."); - ("-str", (Arg.String (fun x -> input_file (Str x))), - " Parse as an implementation."); - ("-unsafe", (Arg.Set Camlp4_config.unsafe), - "Generate unsafe accesses to array and strings."); - ("-noassert", (Arg.Unit warn_noassert), - "Obsolete, do not use this option."); - ("-verbose", (Arg.Set Camlp4_config.verbose), - "More verbose in parsing errors."); - ("-loc", (Arg.Set_string Loc.name), - (" Name of the location variable (default: " ^ - (!Loc.name ^ ")."))); - ("-QD", (Arg.String (fun x -> Quotation.dump_file := Some x)), - " Dump quotation expander result in case of syntax error."); - ("-o", (Arg.String (fun x -> output_file := Some x)), - " Output on instead of standard output."); - ("-v", (Arg.Unit print_version), "Print Camlp4 version and exit."); - ("-version", (Arg.Unit just_print_the_version), - "Print Camlp4 version number and exit."); - ("-vnum", (Arg.Unit just_print_the_version), - "Print Camlp4 version number and exit."); - ("-no_quot", (Arg.Clear Camlp4_config.quotations), - "Don't parse quotations, allowing to use, e.g. \"<:>\" as token."); - ("-loaded-modules", (Arg.Set print_loaded_modules), - "Print the list of loaded modules."); - ("-parser", (Arg.String (rewrite_and_load "Parsers")), - " Load the parser Camlp4Parsers/.cm(o|a|xs)"); - ("-printer", (Arg.String (rewrite_and_load "Printers")), - " Load the printer Camlp4Printers/.cm(o|a|xs)"); - ("-filter", (Arg.String (rewrite_and_load "Filters")), - " Load the filter Camlp4Filters/.cm(o|a|xs)"); - ("-ignore", (Arg.String ignore), "ignore the next argument"); - ("--", (Arg.Unit ignore), "Deprecated, does nothing") ] - - let _ = Options.init initial_spec_list - - let anon_fun name = - input_file - (if Filename.check_suffix name ".mli" - then Intf name - else - if Filename.check_suffix name ".ml" - then Impl name - else - if Filename.check_suffix name objext - then ModuleImpl name - else - if Filename.check_suffix name libext - then ModuleImpl name - else raise (Arg.Bad ("don't know what to do with " ^ name))) - - let main argv = - let usage () = - (usage initial_spec_list (Options.ext_spec_list ()); exit 0) - in - try - let dynloader = - DynLoader.mk ~ocaml_stdlib: !search_stdlib - ~camlp4_stdlib: !search_stdlib () - in - (dyn_loader := (fun () -> dynloader); - let call_callback () = - Register.iter_and_take_callbacks - (fun (name, module_callback) -> - let () = add_to_loaded_modules name in module_callback ()) - in - (call_callback (); - rcall_callback := call_callback; - (match Options.parse anon_fun argv with - | [] -> () - | ("-help" | "--help" | "-h" | "-?") :: _ -> usage () - | s :: _ -> - (eprintf "%s: unknown or misused option\n" s; - eprintf "Use option -help for usage@."; - exit 2)); - do_task usage; - call_callback (); - if !print_loaded_modules - then SSet.iter (eprintf "%s@.") !loaded_modules - else ())) - with - | Arg.Bad s -> - (eprintf "Error: %s\n" s; - eprintf "Use option -help for usage@."; - exit 2) - | Arg.Help _ -> usage () - | exc -> (eprintf "@[%a@]@." ErrorHandler.print exc; exit 2) - - let _ = main Sys.argv - - end - - diff -Nru ocaml-4.01.0/camlp4/boot/camlp4boot.ml4 ocaml-4.02.3/camlp4/boot/camlp4boot.ml4 --- ocaml-4.01.0/camlp4/boot/camlp4boot.ml4 2012-08-02 10:17:59.000000000 +0200 +++ ocaml-4.02.3/camlp4/boot/camlp4boot.ml4 1970-01-01 01:00:00.000000000 +0100 @@ -1,10 +0,0 @@ -module R = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml"; end; -module Camlp4QuotationCommon = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml"; end; -module Q = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4QuotationExpander.ml"; end; -module Rp = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml"; end; -module G = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4GrammarParser.ml"; end; -module M = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4MacroParser.ml"; end; -module D = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4DebugParser.ml"; end; -module L = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4ListComprehension.ml"; end; -module P = struct INCLUDE "camlp4/Camlp4Printers/Camlp4OCamlAstDumper.ml"; end; -module B = struct INCLUDE "camlp4/Camlp4Bin.ml"; end; diff -Nru ocaml-4.01.0/camlp4/boot/Camlp4.ml ocaml-4.02.3/camlp4/boot/Camlp4.ml --- ocaml-4.01.0/camlp4/boot/Camlp4.ml 2013-08-30 13:39:33.000000000 +0200 +++ ocaml-4.02.3/camlp4/boot/Camlp4.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,21644 +0,0 @@ -module Debug : - sig - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - (* camlp4r *) - type section = string - - val mode : section -> bool - - val printf : section -> ('a, Format.formatter, unit) format -> 'a - - end = - struct - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - (* camlp4r *) - open Format - - module Debug = struct let mode _ = false - end - - type section = string - - let out_channel = - try - let f = Sys.getenv "CAMLP4_DEBUG_FILE" - in - open_out_gen [ Open_wronly; Open_creat; Open_append; Open_text ] - 0o666 f - with | Not_found -> Pervasives.stderr - - module StringSet = Set.Make(String) - - let mode = - try - let str = Sys.getenv "CAMLP4_DEBUG" in - let rec loop acc i = - try - let pos = String.index_from str i ':' - in - loop (StringSet.add (String.sub str i (pos - i)) acc) (pos + 1) - with - | Not_found -> - StringSet.add (String.sub str i ((String.length str) - i)) acc in - let sections = loop StringSet.empty 0 - in - if StringSet.mem "*" sections - then (fun _ -> true) - else (fun x -> StringSet.mem x sections) - with | Not_found -> (fun _ -> false) - - let formatter = - let header = "camlp4-debug: " in - let at_bol = ref true - in - make_formatter - (fun buf pos len -> - for i = pos to (pos + len) - 1 do - if !at_bol then output_string out_channel header else (); - let ch = buf.[i] - in (output_char out_channel ch; at_bol := ch = '\n') - done) - (fun () -> flush out_channel) - - let printf section fmt = fprintf formatter ("%s: " ^^ fmt) section - - end - -module Options : - sig - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - type spec_list = (string * Arg.spec * string) list - - val init : spec_list -> unit - - val add : string -> Arg.spec -> string -> unit - - (** Add an option to the command line options. *) - val print_usage_list : spec_list -> unit - - val ext_spec_list : unit -> spec_list - - val parse : (string -> unit) -> string array -> string list - - end = - struct - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - type spec_list = (string * Arg.spec * string) list - - open Format - - let rec action_arg s sl = - function - | Arg.Unit f -> if s = "" then (f (); Some sl) else None - | Arg.Bool f -> - if s = "" - then - (match sl with - | s :: sl -> - (try (f (bool_of_string s); Some sl) - with | Invalid_argument "bool_of_string" -> None) - | [] -> None) - else - (try (f (bool_of_string s); Some sl) - with | Invalid_argument "bool_of_string" -> None) - | Arg.Set r -> if s = "" then (r := true; Some sl) else None - | Arg.Clear r -> if s = "" then (r := false; Some sl) else None - | Arg.Rest f -> (List.iter f (s :: sl); Some []) - | Arg.String f -> - if s = "" - then (match sl with | s :: sl -> (f s; Some sl) | [] -> None) - else (f s; Some sl) - | Arg.Set_string r -> - if s = "" - then (match sl with | s :: sl -> (r := s; Some sl) | [] -> None) - else (r := s; Some sl) - | Arg.Int f -> - if s = "" - then - (match sl with - | s :: sl -> - (try (f (int_of_string s); Some sl) - with | Failure "int_of_string" -> None) - | [] -> None) - else - (try (f (int_of_string s); Some sl) - with | Failure "int_of_string" -> None) - | Arg.Set_int r -> - if s = "" - then - (match sl with - | s :: sl -> - (try (r := int_of_string s; Some sl) - with | Failure "int_of_string" -> None) - | [] -> None) - else - (try (r := int_of_string s; Some sl) - with | Failure "int_of_string" -> None) - | Arg.Float f -> - if s = "" - then - (match sl with - | s :: sl -> (f (float_of_string s); Some sl) - | [] -> None) - else (f (float_of_string s); Some sl) - | Arg.Set_float r -> - if s = "" - then - (match sl with - | s :: sl -> (r := float_of_string s; Some sl) - | [] -> None) - else (r := float_of_string s; Some sl) - | Arg.Tuple specs -> - let rec action_args s sl = - (function - | [] -> Some sl - | spec :: spec_list -> - (match action_arg s sl spec with - | None -> action_args "" [] spec_list - | Some (s :: sl) -> action_args s sl spec_list - | Some sl -> action_args "" sl spec_list)) - in action_args s sl specs - | Arg.Symbol (syms, f) -> - (match if s = "" then sl else s :: sl with - | s :: sl when List.mem s syms -> (f s; Some sl) - | _ -> None) - - let common_start s1 s2 = - let rec loop i = - if (i == (String.length s1)) || (i == (String.length s2)) - then i - else if s1.[i] == s2.[i] then loop (i + 1) else i - in loop 0 - - let parse_arg fold s sl = - fold - (fun (name, action, _) acu -> - let i = common_start s name - in - if i == (String.length name) - then - (try - action_arg (String.sub s i ((String.length s) - i)) sl - action - with | Arg.Bad _ -> acu) - else acu) - None - - let rec parse_aux fold anon_fun = - function - | [] -> [] - | s :: sl -> - if ((String.length s) > 1) && (s.[0] = '-') - then - (match parse_arg fold s sl with - | Some sl -> parse_aux fold anon_fun sl - | None -> s :: (parse_aux fold anon_fun sl)) - else ((anon_fun s : unit); parse_aux fold anon_fun sl) - - let align_doc key s = - let s = - let rec loop i = - if i = (String.length s) - then "" - else - if s.[i] = ' ' - then loop (i + 1) - else String.sub s i ((String.length s) - i) - in loop 0 in - let (p, s) = - if (String.length s) > 0 - then - if s.[0] = '<' - then - (let rec loop i = - if i = (String.length s) - then ("", s) - else - if s.[i] <> '>' - then loop (i + 1) - else - (let p = String.sub s 0 (i + 1) in - let rec loop i = - if i >= (String.length s) - then (p, "") - else - if s.[i] = ' ' - then loop (i + 1) - else (p, (String.sub s i ((String.length s) - i))) - in loop (i + 1)) - in loop 0) - else ("", s) - else ("", "") in - let tab = - String.make (max 1 ((16 - (String.length key)) - (String.length p))) - ' ' - in p ^ (tab ^ s) - - let make_symlist l = - match l with - | [] -> "" - | h :: t -> - (List.fold_left (fun x y -> x ^ ("|" ^ y)) ("{" ^ h) t) ^ "}" - - let print_usage_list l = - List.iter - (fun (key, spec, doc) -> - match spec with - | Arg.Symbol (symbs, _) -> - let s = make_symlist symbs in - let synt = key ^ (" " ^ s) - in eprintf " %s %s\n" synt (align_doc synt doc) - | _ -> eprintf " %s %s\n" key (align_doc key doc)) - l - - let remaining_args argv = - let rec loop l i = - if i == (Array.length argv) then l else loop (argv.(i) :: l) (i + 1) - in List.rev (loop [] (!Arg.current + 1)) - - let init_spec_list = ref [] - - let ext_spec_list = ref [] - - let init spec_list = init_spec_list := spec_list - - let add name spec descr = - ext_spec_list := (name, spec, descr) :: !ext_spec_list - - let fold f init = - let spec_list = !init_spec_list @ !ext_spec_list in - let specs = Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) spec_list - in List.fold_right f specs init - - let parse anon_fun argv = - let remaining_args = remaining_args argv - in parse_aux fold anon_fun remaining_args - - let ext_spec_list () = !ext_spec_list - - end - -module Sig = - struct - (* camlp4r *) - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2006 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 OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - (** Camlp4 signature repository *) - (** {6 Basic signatures} *) - (** Signature with just a type. *) - module type Type = sig type t - end - - (** Signature for errors modules, an Error modules can be registred with - the {!ErrorHandler.Register} functor in order to be well printed. *) - module type Error = - sig - type t - - exception E of t - - val to_string : t -> string - - val print : Format.formatter -> t -> unit - - end - - (** A signature for extensions identifiers. *) - module type Id = - sig - (** The name of the extension, typically the module name. *) - val name : string - - (** The version of the extension, typically $ Id$ with a versionning system. *) - val 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 - - val default_warning : warning - - val current_warning : warning ref - - val print_warning : warning - - end - - end - - (** {6 Advanced signatures} *) - (** A signature for locations. *) - module type Loc = - sig - (** The type of locations. Note that, as for OCaml locations, - character numbers in locations refer to character numbers in the - parsed character stream, while line numbers refer to line - numbers in the source file. The source file and the parsed - character stream differ, for instance, when the parsed character - stream contains a line number directive. The line number - directive will only update the file-name field and the - line-number field of the position. It makes therefore no sense - to use character numbers with the source file if the sources - contain line number directives. *) - type t - - (** Return a start location for the given file name. - This location starts at the begining of the file. *) - val mk : string -> t - - (** The [ghost] location can be used when no location - information is available. *) - val ghost : t - - (** {6 Conversion functions} *) - (** Return a location where both positions are set the given position. *) - val of_lexing_position : Lexing.position -> t - - (** Return an OCaml location. *) - val to_ocaml_location : t -> Camlp4_import.Location.t - - (** Return a location from an OCaml location. *) - val of_ocaml_location : Camlp4_import.Location.t -> t - - (** Return a location from ocamllex buffer. *) - val of_lexbuf : Lexing.lexbuf -> t - - (** Return a location from [(file_name, start_line, start_bol, start_off, - stop_line, stop_bol, stop_off, ghost)]. *) - val of_tuple : - (string * int * int * int * int * int * int * bool) -> t - - (** Return [(file_name, start_line, start_bol, start_off, - stop_line, stop_bol, stop_off, ghost)]. *) - val to_tuple : - t -> (string * int * int * int * int * int * int * bool) - - (** [merge loc1 loc2] Return a location that starts at [loc1] and end at - [loc2]. *) - val merge : t -> t -> t - - (** The stop pos becomes equal to the start pos. *) - val join : t -> t - - (** [move selector n loc] - Return the location where positions are moved. - Affected positions are chosen with [selector]. - Returned positions have their character offset plus [n]. *) - val move : [ | `start | `stop | `both ] -> int -> t -> t - - (** [shift n loc] Return the location where the new start position is the old - stop position, and where the new stop position character offset is the - old one plus [n]. *) - val shift : int -> t -> t - - (** [move_line n loc] Return the location with the old line count plus [n]. - The "begin of line" of both positions become the current offset. *) - val move_line : int -> t -> t - - (** {6 Accessors} *) - (** Return the file name *) - val file_name : t -> string - - (** Return the line number of the begining of this location. *) - val start_line : t -> int - - (** Return the line number of the ending of this location. *) - val stop_line : t -> int - - (** Returns the number of characters from the begining of the stream - to the begining of the line of location's begining. *) - val start_bol : t -> int - - (** Returns the number of characters from the begining of the stream - to the begining of the line of location's ending. *) - val stop_bol : t -> int - - (** Returns the number of characters from the begining of the stream - of the begining of this location. *) - val start_off : t -> int - - (** Return the number of characters from the begining of the stream - of the ending of this location. *) - val stop_off : t -> int - - (** Return the start position as a Lexing.position. *) - val start_pos : t -> Lexing.position - - (** Return the stop position as a Lexing.position. *) - val stop_pos : t -> Lexing.position - - (** Generally, return true if this location does not come - from an input stream. *) - val is_ghost : t -> bool - - (** Return the associated ghost location. *) - val ghostify : t -> t - - (** Return the location with the give file name *) - val set_file_name : string -> t -> t - - (** [strictly_before loc1 loc2] True if the stop position of [loc1] is - strictly_before the start position of [loc2]. *) - val strictly_before : t -> t -> bool - - (** Return the location with an absolute file name. *) - val make_absolute : t -> t - - (** Print the location into the formatter in a format suitable for error - reporting. *) - val print : Format.formatter -> t -> unit - - (** Print the location in a short format useful for debugging. *) - val dump : Format.formatter -> t -> unit - - (** Same as {!print} but return a string instead of printting it. *) - val to_string : t -> string - - (** [Exc_located loc e] is an encapsulation of the exception [e] with - the input location [loc]. To be used in quotation expanders - and in grammars to specify some input location for an error. - Do not raise this exception directly: rather use the following - function [Loc.raise]. *) - exception Exc_located of t * exn - - (** [raise loc e], if [e] is already an [Exc_located] exception, - re-raise it, else raise the exception [Exc_located loc e]. *) - val raise : t -> exn -> 'a - - (** The name of the location variable used in grammars and in - the predefined quotations for OCaml syntax trees. Default: [_loc]. *) - val name : string ref - - end - - (** Abstract syntax tree minimal signature. - Types of this signature are abstract. - See the {!Camlp4Ast} signature for a concrete definition. *) - module type Ast = - sig - (** {6 Syntactic categories as abstract types} *) - type loc - - type meta_bool - - type 'a meta_option - - type 'a meta_list - - type ctyp - - type patt - - type expr - - type module_type - - type sig_item - - type with_constr - - type module_expr - - type str_item - - type class_type - - type class_sig_item - - type class_expr - - type class_str_item - - type match_case - - type ident - - type binding - - type rec_binding - - type module_binding - - type rec_flag - - type direction_flag - - type mutable_flag - - type private_flag - - type virtual_flag - - type row_var_flag - - type override_flag - - (** {6 Location accessors} *) - val loc_of_ctyp : ctyp -> loc - - val loc_of_patt : patt -> loc - - val loc_of_expr : expr -> loc - - val loc_of_module_type : module_type -> loc - - val loc_of_module_expr : module_expr -> loc - - val loc_of_sig_item : sig_item -> loc - - val loc_of_str_item : str_item -> loc - - val loc_of_class_type : class_type -> loc - - val loc_of_class_sig_item : class_sig_item -> loc - - val loc_of_class_expr : class_expr -> loc - - val loc_of_class_str_item : class_str_item -> loc - - val loc_of_with_constr : with_constr -> loc - - val loc_of_binding : binding -> loc - - val loc_of_rec_binding : rec_binding -> loc - - val loc_of_module_binding : module_binding -> loc - - val loc_of_match_case : match_case -> loc - - val 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: - - This example swap pairs expression contents: - open Camlp4.PreCast; - [class swap = object - inherit Ast.map as super; - method expr e = - match super#expr e with - \[ <:expr\@_loc< ($e1$, $e2$) >> -> <:expr< ($e2$, $e1$) >> - | e -> e \]; - end; - value _loc = Loc.ghost; - value map = (new swap)#expr; - assert (map <:expr< fun x -> (x, 42) >> = <:expr< fun x -> (42, x) >>);] - *) - class map : - object ('self_type) - method string : string -> string - method list : - 'a 'b. ('self_type -> 'a -> 'b) -> 'a list -> 'b list - method meta_bool : meta_bool -> meta_bool - method meta_option : - 'a 'b. - ('self_type -> 'a -> 'b) -> 'a meta_option -> 'b meta_option - method meta_list : - 'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_list -> 'b meta_list - method loc : loc -> loc - method expr : expr -> expr - method patt : patt -> patt - method ctyp : ctyp -> ctyp - method str_item : str_item -> str_item - method sig_item : sig_item -> sig_item - method module_expr : module_expr -> module_expr - method module_type : module_type -> module_type - method class_expr : class_expr -> class_expr - method class_type : class_type -> class_type - method class_sig_item : class_sig_item -> class_sig_item - method class_str_item : class_str_item -> class_str_item - method with_constr : with_constr -> with_constr - method binding : binding -> binding - method rec_binding : rec_binding -> rec_binding - method module_binding : module_binding -> module_binding - method match_case : match_case -> match_case - method ident : ident -> ident - method override_flag : override_flag -> override_flag - method mutable_flag : mutable_flag -> mutable_flag - method private_flag : private_flag -> private_flag - method virtual_flag : virtual_flag -> virtual_flag - method direction_flag : direction_flag -> direction_flag - method rec_flag : rec_flag -> rec_flag - method row_var_flag : row_var_flag -> row_var_flag - method unknown : 'a. 'a -> 'a - end - - (** Fold style traversal *) - class fold : - object ('self_type) - method string : string -> 'self_type - method list : - 'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type - method meta_bool : meta_bool -> 'self_type - method meta_option : - 'a. - ('self_type -> 'a -> 'self_type) -> - 'a meta_option -> 'self_type - method meta_list : - 'a. - ('self_type -> 'a -> 'self_type) -> - 'a meta_list -> 'self_type - method loc : loc -> 'self_type - method expr : expr -> 'self_type - method patt : patt -> 'self_type - method ctyp : ctyp -> 'self_type - method str_item : str_item -> 'self_type - method sig_item : sig_item -> 'self_type - method module_expr : module_expr -> 'self_type - method module_type : module_type -> 'self_type - method class_expr : class_expr -> 'self_type - method class_type : class_type -> 'self_type - method class_sig_item : class_sig_item -> 'self_type - method class_str_item : class_str_item -> 'self_type - method with_constr : with_constr -> 'self_type - method binding : binding -> 'self_type - method rec_binding : rec_binding -> 'self_type - method module_binding : module_binding -> 'self_type - method match_case : match_case -> 'self_type - method ident : ident -> 'self_type - method rec_flag : rec_flag -> 'self_type - method direction_flag : direction_flag -> 'self_type - method mutable_flag : mutable_flag -> 'self_type - method private_flag : private_flag -> 'self_type - method virtual_flag : virtual_flag -> 'self_type - method row_var_flag : row_var_flag -> 'self_type - method override_flag : override_flag -> 'self_type - method unknown : 'a. 'a -> 'self_type - end - - end - - (** 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 - *) - module type Camlp4Ast = - sig - (** The inner module for locations *) - module Loc : Loc - - (****************************************************************************) - (* *) - (* OCaml *) - (* *) - (* INRIA Rocquencourt *) - (* *) - (* Copyright 2007 Institut National de Recherche en Informatique et *) - (* en Automatique. All rights reserved. This file is distributed under *) - (* the terms of the GNU Library General Public License, with the special *) - (* exception on linking described in LICENSE at the top of the OCaml *) - (* source tree. *) - (* *) - (****************************************************************************) - (* Note: when you modify these types you must increment - ast magic numbers defined in Camlp4_config.ml. *) - type loc = - Loc. - t - and meta_bool = - | BTrue | BFalse | BAnt of string - and rec_flag = - | ReRecursive | ReNil | ReAnt of string - and direction_flag = - | DiTo | DiDownto | DiAnt of string - and mutable_flag = - | MuMutable | MuNil | MuAnt of string - and private_flag = - | PrPrivate | PrNil | PrAnt of string - and virtual_flag = - | ViVirtual | ViNil | ViAnt of string - and override_flag = - | OvOverride | OvNil | OvAnt of string - and row_var_flag = - | RvRowVar | RvNil | RvAnt of string - and 'a meta_option = - | ONone | OSome of 'a | OAnt of string - and 'a meta_list = - | LNil | LCons of 'a * 'a meta_list | LAnt of string - and ident = - | IdAcc of loc * ident * ident - | (* i . i *) - IdApp of loc * ident * ident - | (* i i *) - IdLid of loc * string - | (* foo *) - IdUid of loc * string - | (* Bar *) - IdAnt of loc * string - and (* $s$ *) - ctyp = - | TyNil of loc - | TyAli of loc * ctyp * ctyp - | (* t as t *) - (* list 'a as 'a *) - TyAny of loc - | (* _ *) - TyApp of loc * ctyp * ctyp - | (* t t *) - (* list 'a *) - TyArr of loc * ctyp * ctyp - | (* t -> t *) - (* int -> string *) - TyCls of loc * ident - | (* #i *) - (* #point *) - TyLab of loc * string * ctyp - | (* ~s:t *) - TyId of loc * ident - | (* i *) - (* Lazy.t *) - TyMan of loc * ctyp * ctyp - | (* t == t *) - (* type t = [ A | B ] == Foo.t *) - (* type t 'a 'b 'c = t constraint t = t constraint t = t *) - TyDcl of loc * string * ctyp list * ctyp * (ctyp * ctyp) list - | (* < (t)? (..)? > *) - (* < move : int -> 'a .. > as 'a *) - TyObj of loc * ctyp * row_var_flag - | TyOlb of loc * string * ctyp - | (* ?s:t *) - TyPol of loc * ctyp * ctyp - | (* ! t . t *) - (* ! 'a . list 'a -> 'a *) - TyTypePol of loc * ctyp * ctyp - | (* type t . t *) - (* type a . list a -> a *) - TyQuo of loc * string - | (* 's *) - TyQuP of loc * string - | (* +'s *) - TyQuM of loc * string - | (* -'s *) - TyAnP of loc - | (* +_ *) - TyAnM of loc - | (* -_ *) - TyVrn of loc * string - | (* `s *) - TyRec of loc * ctyp - | (* { t } *) - (* { foo : int ; bar : mutable string } *) - TyCol of loc * ctyp * ctyp - | (* t : t *) - TySem of loc * ctyp * ctyp - | (* t; t *) - TyCom of loc * ctyp * ctyp - | (* t, t *) - TySum of loc * ctyp - | (* [ t ] *) - (* [ A of int and string | B ] *) - TyOf of loc * ctyp * ctyp - | (* t of t *) - (* A of int *) - TyAnd of loc * ctyp * ctyp - | (* t and t *) - TyOr of loc * ctyp * ctyp - | (* t | t *) - TyPrv of loc * ctyp - | (* private t *) - TyMut of loc * ctyp - | (* mutable t *) - TyTup of loc * ctyp - | (* ( t ) *) - (* (int * string) *) - TySta of loc * ctyp * ctyp - | (* t * t *) - TyVrnEq of loc * ctyp - | (* [ = t ] *) - TyVrnSup of loc * ctyp - | (* [ > t ] *) - TyVrnInf of loc * ctyp - | (* [ < t ] *) - TyVrnInfSup of loc * ctyp * ctyp - | (* [ < t > t ] *) - TyAmp of loc * ctyp * ctyp - | (* t & t *) - TyOfAmp of loc * ctyp * ctyp - | (* t of & t *) - TyPkg of loc * module_type - | (* (module S) *) - TyAnt of loc * string - and (* $s$ *) - patt = - | PaNil of loc - | PaId of loc * ident - | (* i *) - PaAli of loc * patt * patt - | (* p as p *) - (* (Node x y as n) *) - PaAnt of loc * string - | (* $s$ *) - PaAny of loc - | (* _ *) - PaApp of loc * patt * patt - | (* p p *) - (* fun x y -> *) - PaArr of loc * patt - | (* [| p |] *) - PaCom of loc * patt * patt - | (* p, p *) - PaSem of loc * patt * patt - | (* p; p *) - PaChr of loc * string - | (* c *) - (* 'x' *) - PaInt of loc * string - | PaInt32 of loc * string - | PaInt64 of loc * string - | PaNativeInt of loc * string - | PaFlo of loc * string - | PaLab of loc * string * patt - | (* ~s or ~s:(p) *) - (* ?s or ?s:(p) *) - PaOlb of loc * string * patt - | (* ?s:(p = e) or ?(p = e) *) - PaOlbi of loc * string * patt * expr - | PaOrp of loc * patt * patt - | (* p | p *) - PaRng of loc * patt * patt - | (* p .. p *) - PaRec of loc * patt - | (* { p } *) - PaEq of loc * ident * patt - | (* i = p *) - PaStr of loc * string - | (* s *) - PaTup of loc * patt - | (* ( p ) *) - PaTyc of loc * patt * ctyp - | (* (p : t) *) - PaTyp of loc * ident - | (* #i *) - PaVrn of loc * string - | (* `s *) - PaLaz of loc * patt - | (* lazy p *) - PaMod of loc * string - and (* (module M) *) - expr = - | ExNil of loc - | ExId of loc * ident - | (* i *) - ExAcc of loc * expr * expr - | (* e.e *) - ExAnt of loc * string - | (* $s$ *) - ExApp of loc * expr * expr - | (* e e *) - ExAre of loc * expr * expr - | (* e.(e) *) - ExArr of loc * expr - | (* [| e |] *) - ExSem of loc * expr * expr - | (* e; e *) - ExAsf of loc - | (* assert False *) - ExAsr of loc * expr - | (* assert e *) - ExAss of loc * expr * expr - | (* e := e *) - ExChr of loc * string - | (* 'c' *) - ExCoe of loc * expr * ctyp * ctyp - | (* (e : t) or (e : t :> t) *) - ExFlo of loc * string - | (* 3.14 *) - (* for s = e to/downto e do { e } *) - ExFor of loc * string * expr * expr * direction_flag * expr - | ExFun of loc * match_case - | (* fun [ mc ] *) - ExIfe of loc * expr * expr * expr - | (* if e then e else e *) - ExInt of loc * string - | (* 42 *) - ExInt32 of loc * string - | ExInt64 of loc * string - | ExNativeInt of loc * string - | ExLab of loc * string * expr - | (* ~s or ~s:e *) - ExLaz of loc * expr - | (* lazy e *) - (* let b in e or let rec b in e *) - ExLet of loc * rec_flag * binding * expr - | (* let module s = me in e *) - ExLmd of loc * string * module_expr * expr - | (* match e with [ mc ] *) - ExMat of loc * expr * match_case - | (* new i *) - ExNew of loc * ident - | (* object ((p))? (cst)? end *) - ExObj of loc * patt * class_str_item - | (* ?s or ?s:e *) - ExOlb of loc * string * expr - | (* {< rb >} *) - ExOvr of loc * rec_binding - | (* { rb } or { (e) with rb } *) - ExRec of loc * rec_binding * expr - | (* do { e } *) - ExSeq of loc * expr - | (* e#s *) - ExSnd of loc * expr * string - | (* e.[e] *) - ExSte of loc * expr * expr - | (* s *) - (* "foo" *) - ExStr of loc * string - | (* try e with [ mc ] *) - ExTry of loc * expr * match_case - | (* (e) *) - ExTup of loc * expr - | (* e, e *) - ExCom of loc * expr * expr - | (* (e : t) *) - ExTyc of loc * expr * ctyp - | (* `s *) - ExVrn of loc * string - | (* while e do { e } *) - ExWhi of loc * expr * expr - | (* let open i in e *) - ExOpI of loc * ident * expr - | (* fun (type t) -> e *) - (* let f x (type t) y z = e *) - ExFUN of loc * string * expr - | (* (module ME : S) which is represented as (module (ME : S)) *) - ExPkg of loc * module_expr - and module_type = - | MtNil of loc - | (* i *) - (* A.B.C *) - MtId of loc * ident - | (* functor (s : mt) -> mt *) - MtFun of loc * string * module_type * module_type - | (* 's *) - MtQuo of loc * string - | (* sig sg end *) - MtSig of loc * sig_item - | (* mt with wc *) - MtWit of loc * module_type * with_constr - | (* module type of m *) - MtOf of loc * module_expr - | MtAnt of loc * string - and (* $s$ *) - sig_item = - | SgNil of loc - | (* class cict *) - SgCls of loc * class_type - | (* class type cict *) - SgClt of loc * class_type - | (* sg ; sg *) - SgSem of loc * sig_item * sig_item - | (* # s or # s e *) - SgDir of loc * string * expr - | (* exception t *) - SgExc of loc * ctyp - | (* external s : t = s ... s *) - SgExt of loc * string * ctyp * string meta_list - | (* include mt *) - SgInc of loc * module_type - | (* module s : mt *) - SgMod of loc * string * module_type - | (* module rec mb *) - SgRecMod of loc * module_binding - | (* module type s = mt *) - SgMty of loc * string * module_type - | (* open i *) - SgOpn of loc * ident - | (* type t *) - SgTyp of loc * ctyp - | (* value s : t *) - SgVal of loc * string * ctyp - | SgAnt of loc * string - and (* $s$ *) - with_constr = - | WcNil of loc - | (* type t = t *) - WcTyp of loc * ctyp * ctyp - | (* module i = i *) - WcMod of loc * ident * ident - | (* type t := t *) - WcTyS of loc * ctyp * ctyp - | (* module i := i *) - WcMoS of loc * ident * ident - | (* wc and wc *) - WcAnd of loc * with_constr * with_constr - | WcAnt of loc * string - and (* $s$ *) - binding = - | BiNil of loc - | (* bi and bi *) - (* let a = 42 and c = 43 *) - BiAnd of loc * binding * binding - | (* p = e *) - (* let patt = expr *) - BiEq of loc * patt * expr - | BiAnt of loc * string - and (* $s$ *) - rec_binding = - | RbNil of loc - | (* rb ; rb *) - RbSem of loc * rec_binding * rec_binding - | (* i = e *) - RbEq of loc * ident * expr - | RbAnt of loc * string - and (* $s$ *) - module_binding = - | MbNil of loc - | (* mb and mb *) - (* module rec (s : mt) = me and (s : mt) = me *) - MbAnd of loc * module_binding * module_binding - | (* s : mt = me *) - MbColEq of loc * string * module_type * module_expr - | (* s : mt *) - MbCol of loc * string * module_type - | MbAnt of loc * string - and (* $s$ *) - match_case = - | McNil of loc - | (* a | a *) - McOr of loc * match_case * match_case - | (* p (when e)? -> e *) - McArr of loc * patt * expr * expr - | McAnt of loc * string - and (* $s$ *) - module_expr = - | MeNil of loc - | (* i *) - MeId of loc * ident - | (* me me *) - MeApp of loc * module_expr * module_expr - | (* functor (s : mt) -> me *) - MeFun of loc * string * module_type * module_expr - | (* struct st end *) - MeStr of loc * str_item - | (* (me : mt) *) - MeTyc of loc * module_expr * module_type - | (* (value e) *) - (* (value e : S) which is represented as (value (e : S)) *) - MePkg of loc * expr - | MeAnt of loc * string - and (* $s$ *) - str_item = - | StNil of loc - | (* class cice *) - StCls of loc * class_expr - | (* class type cict *) - StClt of loc * class_type - | (* st ; st *) - StSem of loc * str_item * str_item - | (* # s or # s e *) - StDir of loc * string * expr - | (* exception t or exception t = i *) - StExc of loc * ctyp * (*FIXME*) ident meta_option - | (* e *) - StExp of loc * expr - | (* external s : t = s ... s *) - StExt of loc * string * ctyp * string meta_list - | (* include me *) - StInc of loc * module_expr - | (* module s = me *) - StMod of loc * string * module_expr - | (* module rec mb *) - StRecMod of loc * module_binding - | (* module type s = mt *) - StMty of loc * string * module_type - | (* open i *) - StOpn of loc * ident - | (* type t *) - StTyp of loc * ctyp - | (* value (rec)? bi *) - StVal of loc * rec_flag * binding - | StAnt of loc * string - and (* $s$ *) - class_type = - | CtNil of loc - | (* (virtual)? i ([ t ])? *) - CtCon of loc * virtual_flag * ident * ctyp - | (* [t] -> ct *) - CtFun of loc * ctyp * class_type - | (* object ((t))? (csg)? end *) - CtSig of loc * ctyp * class_sig_item - | (* ct and ct *) - CtAnd of loc * class_type * class_type - | (* ct : ct *) - CtCol of loc * class_type * class_type - | (* ct = ct *) - CtEq of loc * class_type * class_type - | (* $s$ *) - CtAnt of loc * string - and class_sig_item = - | CgNil of loc - | (* type t = t *) - CgCtr of loc * ctyp * ctyp - | (* csg ; csg *) - CgSem of loc * class_sig_item * class_sig_item - | (* inherit ct *) - CgInh of loc * class_type - | (* method s : t or method private s : t *) - CgMth of loc * string * private_flag * ctyp - | (* value (virtual)? (mutable)? s : t *) - CgVal of loc * string * mutable_flag * virtual_flag * ctyp - | (* method virtual (private)? s : t *) - CgVir of loc * string * private_flag * ctyp - | CgAnt of loc * string - and (* $s$ *) - class_expr = - | CeNil of loc - | (* ce e *) - CeApp of loc * class_expr * expr - | (* (virtual)? i ([ t ])? *) - CeCon of loc * virtual_flag * ident * ctyp - | (* fun p -> ce *) - CeFun of loc * patt * class_expr - | (* let (rec)? bi in ce *) - CeLet of loc * rec_flag * binding * class_expr - | (* object ((p))? (cst)? end *) - CeStr of loc * patt * class_str_item - | (* ce : ct *) - CeTyc of loc * class_expr * class_type - | (* ce and ce *) - CeAnd of loc * class_expr * class_expr - | (* ce = ce *) - CeEq of loc * class_expr * class_expr - | (* $s$ *) - CeAnt of loc * string - and class_str_item = - | CrNil of loc - | (* cst ; cst *) - CrSem of loc * class_str_item * class_str_item - | (* type t = t *) - CrCtr of loc * ctyp * ctyp - | (* inherit(!)? ce (as s)? *) - CrInh of loc * override_flag * class_expr * string - | (* initializer e *) - CrIni of loc * expr - | (* method(!)? (private)? s : t = e or method(!)? (private)? s = e *) - CrMth of loc * string * override_flag * private_flag * expr * ctyp - | (* value(!)? (mutable)? s = e *) - CrVal of loc * string * override_flag * mutable_flag * expr - | (* method virtual (private)? s : t *) - CrVir of loc * string * private_flag * ctyp - | (* value virtual (mutable)? s : t *) - CrVvr of loc * string * mutable_flag * ctyp - | CrAnt of loc * string - - val loc_of_ctyp : ctyp -> loc - - val loc_of_patt : patt -> loc - - val loc_of_expr : expr -> loc - - val loc_of_module_type : module_type -> loc - - val loc_of_module_expr : module_expr -> loc - - val loc_of_sig_item : sig_item -> loc - - val loc_of_str_item : str_item -> loc - - val loc_of_class_type : class_type -> loc - - val loc_of_class_sig_item : class_sig_item -> loc - - val loc_of_class_expr : class_expr -> loc - - val loc_of_class_str_item : class_str_item -> loc - - val loc_of_with_constr : with_constr -> loc - - val loc_of_binding : binding -> loc - - val loc_of_rec_binding : rec_binding -> loc - - val loc_of_module_binding : module_binding -> loc - - val loc_of_match_case : match_case -> loc - - val loc_of_ident : ident -> loc - - module Meta : - sig - module type META_LOC = - sig - val meta_loc_patt : loc -> loc -> patt - - val meta_loc_expr : loc -> loc -> expr - - end - - module MetaLoc : - sig - val meta_loc_patt : loc -> loc -> patt - - val meta_loc_expr : loc -> loc -> expr - - end - - module MetaGhostLoc : - sig - val meta_loc_patt : loc -> 'a -> patt - - val meta_loc_expr : loc -> 'a -> expr - - end - - module MetaLocVar : - sig - val meta_loc_patt : loc -> 'a -> patt - - val meta_loc_expr : loc -> 'a -> expr - - end - - module Make (MetaLoc : META_LOC) : - sig - module Expr : - sig - val meta_string : loc -> string -> expr - - val meta_int : loc -> string -> expr - - val meta_float : loc -> string -> expr - - val meta_char : loc -> string -> expr - - val meta_bool : loc -> bool -> expr - - val meta_list : - (loc -> 'a -> expr) -> loc -> 'a list -> expr - - val meta_binding : loc -> binding -> expr - - val meta_rec_binding : loc -> rec_binding -> expr - - val meta_class_expr : loc -> class_expr -> expr - - val meta_class_sig_item : loc -> class_sig_item -> expr - - val meta_class_str_item : loc -> class_str_item -> expr - - val meta_class_type : loc -> class_type -> expr - - val meta_ctyp : loc -> ctyp -> expr - - val meta_expr : loc -> expr -> expr - - val meta_ident : loc -> ident -> expr - - val meta_match_case : loc -> match_case -> expr - - val meta_module_binding : loc -> module_binding -> expr - - val meta_module_expr : loc -> module_expr -> expr - - val meta_module_type : loc -> module_type -> expr - - val meta_patt : loc -> patt -> expr - - val meta_sig_item : loc -> sig_item -> expr - - val meta_str_item : loc -> str_item -> expr - - val meta_with_constr : loc -> with_constr -> expr - - val meta_rec_flag : loc -> rec_flag -> expr - - val meta_mutable_flag : loc -> mutable_flag -> expr - - val meta_virtual_flag : loc -> virtual_flag -> expr - - val meta_private_flag : loc -> private_flag -> expr - - val meta_row_var_flag : loc -> row_var_flag -> expr - - val meta_override_flag : loc -> override_flag -> expr - - val meta_direction_flag : loc -> direction_flag -> expr - - end - - module Patt : - sig - val meta_string : loc -> string -> patt - - val meta_int : loc -> string -> patt - - val meta_float : loc -> string -> patt - - val meta_char : loc -> string -> patt - - val meta_bool : loc -> bool -> patt - - val meta_list : - (loc -> 'a -> patt) -> loc -> 'a list -> patt - - val meta_binding : loc -> binding -> patt - - val meta_rec_binding : loc -> rec_binding -> patt - - val meta_class_expr : loc -> class_expr -> patt - - val meta_class_sig_item : loc -> class_sig_item -> patt - - val meta_class_str_item : loc -> class_str_item -> patt - - val meta_class_type : loc -> class_type -> patt - - val meta_ctyp : loc -> ctyp -> patt - - val meta_expr : loc -> expr -> patt - - val meta_ident : loc -> ident -> patt - - val meta_match_case : loc -> match_case -> patt - - val meta_module_binding : loc -> module_binding -> patt - - val meta_module_expr : loc -> module_expr -> patt - - val meta_module_type : loc -> module_type -> patt - - val meta_patt : loc -> patt -> patt - - val meta_sig_item : loc -> sig_item -> patt - - val meta_str_item : loc -> str_item -> patt - - val meta_with_constr : loc -> with_constr -> patt - - val meta_rec_flag : loc -> rec_flag -> patt - - val meta_mutable_flag : loc -> mutable_flag -> patt - - val meta_virtual_flag : loc -> virtual_flag -> patt - - val meta_private_flag : loc -> private_flag -> patt - - val meta_row_var_flag : loc -> row_var_flag -> patt - - val meta_override_flag : loc -> override_flag -> patt - - val meta_direction_flag : loc -> direction_flag -> patt - - end - - end - - end - - class map : - object ('self_type) - method string : string -> string - method list : - 'a 'b. ('self_type -> 'a -> 'b) -> 'a list -> 'b list - method meta_bool : meta_bool -> meta_bool - method meta_option : - 'a 'b. - ('self_type -> 'a -> 'b) -> 'a meta_option -> 'b meta_option - method meta_list : - 'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_list -> 'b meta_list - method loc : loc -> loc - method expr : expr -> expr - method patt : patt -> patt - method ctyp : ctyp -> ctyp - method str_item : str_item -> str_item - method sig_item : sig_item -> sig_item - method module_expr : module_expr -> module_expr - method module_type : module_type -> module_type - method class_expr : class_expr -> class_expr - method class_type : class_type -> class_type - method class_sig_item : class_sig_item -> class_sig_item - method class_str_item : class_str_item -> class_str_item - method with_constr : with_constr -> with_constr - method binding : binding -> binding - method rec_binding : rec_binding -> rec_binding - method module_binding : module_binding -> module_binding - method match_case : match_case -> match_case - method ident : ident -> ident - method mutable_flag : mutable_flag -> mutable_flag - method private_flag : private_flag -> private_flag - method virtual_flag : virtual_flag -> virtual_flag - method direction_flag : direction_flag -> direction_flag - method rec_flag : rec_flag -> rec_flag - method row_var_flag : row_var_flag -> row_var_flag - method override_flag : override_flag -> override_flag - method unknown : 'a. 'a -> 'a - end - - class fold : - object ('self_type) - method string : string -> 'self_type - method list : - 'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type - method meta_bool : meta_bool -> 'self_type - method meta_option : - 'a. - ('self_type -> 'a -> 'self_type) -> - 'a meta_option -> 'self_type - method meta_list : - 'a. - ('self_type -> 'a -> 'self_type) -> - 'a meta_list -> 'self_type - method loc : loc -> 'self_type - method expr : expr -> 'self_type - method patt : patt -> 'self_type - method ctyp : ctyp -> 'self_type - method str_item : str_item -> 'self_type - method sig_item : sig_item -> 'self_type - method module_expr : module_expr -> 'self_type - method module_type : module_type -> 'self_type - method class_expr : class_expr -> 'self_type - method class_type : class_type -> 'self_type - method class_sig_item : class_sig_item -> 'self_type - method class_str_item : class_str_item -> 'self_type - method with_constr : with_constr -> 'self_type - method binding : binding -> 'self_type - method rec_binding : rec_binding -> 'self_type - method module_binding : module_binding -> 'self_type - method match_case : match_case -> 'self_type - method ident : ident -> 'self_type - method rec_flag : rec_flag -> 'self_type - method direction_flag : direction_flag -> 'self_type - method mutable_flag : mutable_flag -> 'self_type - method private_flag : private_flag -> 'self_type - method virtual_flag : virtual_flag -> 'self_type - method row_var_flag : row_var_flag -> 'self_type - method override_flag : override_flag -> 'self_type - method unknown : 'a. 'a -> 'self_type - end - - val map_expr : (expr -> expr) -> map - - val map_patt : (patt -> patt) -> map - - val map_ctyp : (ctyp -> ctyp) -> map - - val map_str_item : (str_item -> str_item) -> map - - val map_sig_item : (sig_item -> sig_item) -> map - - val map_loc : (loc -> loc) -> map - - val ident_of_expr : expr -> ident - - val ident_of_patt : patt -> ident - - val ident_of_ctyp : ctyp -> ident - - val biAnd_of_list : binding list -> binding - - val rbSem_of_list : rec_binding list -> rec_binding - - val paSem_of_list : patt list -> patt - - val paCom_of_list : patt list -> patt - - val tyOr_of_list : ctyp list -> ctyp - - val tyAnd_of_list : ctyp list -> ctyp - - val tyAmp_of_list : ctyp list -> ctyp - - val tySem_of_list : ctyp list -> ctyp - - val tyCom_of_list : ctyp list -> ctyp - - val tySta_of_list : ctyp list -> ctyp - - val stSem_of_list : str_item list -> str_item - - val sgSem_of_list : sig_item list -> sig_item - - val crSem_of_list : class_str_item list -> class_str_item - - val cgSem_of_list : class_sig_item list -> class_sig_item - - val ctAnd_of_list : class_type list -> class_type - - val ceAnd_of_list : class_expr list -> class_expr - - val wcAnd_of_list : with_constr list -> with_constr - - val meApp_of_list : module_expr list -> module_expr - - val mbAnd_of_list : module_binding list -> module_binding - - val mcOr_of_list : match_case list -> match_case - - val idAcc_of_list : ident list -> ident - - val idApp_of_list : ident list -> ident - - val exSem_of_list : expr list -> expr - - val exCom_of_list : expr list -> expr - - val list_of_ctyp : ctyp -> ctyp list -> ctyp list - - val list_of_binding : binding -> binding list -> binding list - - val list_of_rec_binding : - rec_binding -> rec_binding list -> rec_binding list - - val list_of_with_constr : - with_constr -> with_constr list -> with_constr list - - val list_of_patt : patt -> patt list -> patt list - - val list_of_expr : expr -> expr list -> expr list - - val list_of_str_item : str_item -> str_item list -> str_item list - - val list_of_sig_item : sig_item -> sig_item list -> sig_item list - - val list_of_class_sig_item : - class_sig_item -> class_sig_item list -> class_sig_item list - - val list_of_class_str_item : - class_str_item -> class_str_item list -> class_str_item list - - val list_of_class_type : - class_type -> class_type list -> class_type list - - val list_of_class_expr : - class_expr -> class_expr list -> class_expr list - - val list_of_module_expr : - module_expr -> module_expr list -> module_expr list - - val list_of_module_binding : - module_binding -> module_binding list -> module_binding list - - val list_of_match_case : - match_case -> match_case list -> match_case list - - val list_of_ident : ident -> ident list -> ident list - - val safe_string_escaped : string -> string - - val is_irrefut_patt : patt -> bool - - val is_constructor : ident -> bool - - val is_patt_constructor : patt -> bool - - val is_expr_constructor : expr -> bool - - val ty_of_stl : (Loc.t * string * (ctyp list)) -> ctyp - - val ty_of_sbt : (Loc.t * string * bool * ctyp) -> ctyp - - val bi_of_pe : (patt * expr) -> binding - - val pel_of_binding : binding -> (patt * expr) list - - val binding_of_pel : (patt * expr) list -> binding - - val sum_type_of_list : (Loc.t * string * (ctyp list)) list -> ctyp - - val record_type_of_list : (Loc.t * string * bool * ctyp) list -> ctyp - - end - - module Camlp4AstToAst (M : Camlp4Ast) : Ast with type loc = M.loc - and type meta_bool = M.meta_bool - and type 'a meta_option = 'a M.meta_option - and type 'a meta_list = 'a M.meta_list and type ctyp = M.ctyp - and type patt = M.patt and type expr = M.expr - and type module_type = M.module_type and type sig_item = M.sig_item - and type with_constr = M.with_constr - and type module_expr = M.module_expr and type str_item = M.str_item - and type class_type = M.class_type - and type class_sig_item = M.class_sig_item - and type class_expr = M.class_expr - and type class_str_item = M.class_str_item and type binding = M.binding - and type rec_binding = M.rec_binding - and type module_binding = M.module_binding - and type match_case = M.match_case and type ident = M.ident - and type rec_flag = M.rec_flag - and type direction_flag = M.direction_flag - and type mutable_flag = M.mutable_flag - and type private_flag = M.private_flag - and type virtual_flag = M.virtual_flag - and type row_var_flag = M.row_var_flag - and type override_flag = M.override_flag = M - - module MakeCamlp4Ast (Loc : Type) = - struct - type loc = - Loc. - t - and meta_bool = - | BTrue | BFalse | BAnt of string - and rec_flag = - | ReRecursive | ReNil | ReAnt of string - and direction_flag = - | DiTo | DiDownto | DiAnt of string - and mutable_flag = - | MuMutable | MuNil | MuAnt of string - and private_flag = - | PrPrivate | PrNil | PrAnt of string - and virtual_flag = - | ViVirtual | ViNil | ViAnt of string - and override_flag = - | OvOverride | OvNil | OvAnt of string - and row_var_flag = - | RvRowVar | RvNil | RvAnt of string - and 'a meta_option = - | ONone | OSome of 'a | OAnt of string - and 'a meta_list = - | LNil | LCons of 'a * 'a meta_list | LAnt of string - and ident = - | IdAcc of loc * ident * ident - | IdApp of loc * ident * ident - | IdLid of loc * string - | IdUid of loc * string - | IdAnt of loc * string - and ctyp = - | TyNil of loc - | TyAli of loc * ctyp * ctyp - | TyAny of loc - | TyApp of loc * ctyp * ctyp - | TyArr of loc * ctyp * ctyp - | TyCls of loc * ident - | TyLab of loc * string * ctyp - | TyId of loc * ident - | TyMan of loc * ctyp * ctyp - | TyDcl of loc * string * ctyp list * ctyp * (ctyp * ctyp) list - | TyObj of loc * ctyp * row_var_flag - | TyOlb of loc * string * ctyp - | TyPol of loc * ctyp * ctyp - | TyTypePol of loc * ctyp * ctyp - | TyQuo of loc * string - | TyQuP of loc * string - | TyQuM of loc * string - | TyAnP of loc - | TyAnM of loc - | TyVrn of loc * string - | TyRec of loc * ctyp - | TyCol of loc * ctyp * ctyp - | TySem of loc * ctyp * ctyp - | TyCom of loc * ctyp * ctyp - | TySum of loc * ctyp - | TyOf of loc * ctyp * ctyp - | TyAnd of loc * ctyp * ctyp - | TyOr of loc * ctyp * ctyp - | TyPrv of loc * ctyp - | TyMut of loc * ctyp - | TyTup of loc * ctyp - | TySta of loc * ctyp * ctyp - | TyVrnEq of loc * ctyp - | TyVrnSup of loc * ctyp - | TyVrnInf of loc * ctyp - | TyVrnInfSup of loc * ctyp * ctyp - | TyAmp of loc * ctyp * ctyp - | TyOfAmp of loc * ctyp * ctyp - | TyPkg of loc * module_type - | TyAnt of loc * string - and patt = - | PaNil of loc - | PaId of loc * ident - | PaAli of loc * patt * patt - | PaAnt of loc * string - | PaAny of loc - | PaApp of loc * patt * patt - | PaArr of loc * patt - | PaCom of loc * patt * patt - | PaSem of loc * patt * patt - | PaChr of loc * string - | PaInt of loc * string - | PaInt32 of loc * string - | PaInt64 of loc * string - | PaNativeInt of loc * string - | PaFlo of loc * string - | PaLab of loc * string * patt - | PaOlb of loc * string * patt - | PaOlbi of loc * string * patt * expr - | PaOrp of loc * patt * patt - | PaRng of loc * patt * patt - | PaRec of loc * patt - | PaEq of loc * ident * patt - | PaStr of loc * string - | PaTup of loc * patt - | PaTyc of loc * patt * ctyp - | PaTyp of loc * ident - | PaVrn of loc * string - | PaLaz of loc * patt - | PaMod of loc * string - and expr = - | ExNil of loc - | ExId of loc * ident - | ExAcc of loc * expr * expr - | ExAnt of loc * string - | ExApp of loc * expr * expr - | ExAre of loc * expr * expr - | ExArr of loc * expr - | ExSem of loc * expr * expr - | ExAsf of loc - | ExAsr of loc * expr - | ExAss of loc * expr * expr - | ExChr of loc * string - | ExCoe of loc * expr * ctyp * ctyp - | ExFlo of loc * string - | ExFor of loc * string * expr * expr * direction_flag * expr - | ExFun of loc * match_case - | ExIfe of loc * expr * expr * expr - | ExInt of loc * string - | ExInt32 of loc * string - | ExInt64 of loc * string - | ExNativeInt of loc * string - | ExLab of loc * string * expr - | ExLaz of loc * expr - | ExLet of loc * rec_flag * binding * expr - | ExLmd of loc * string * module_expr * expr - | ExMat of loc * expr * match_case - | ExNew of loc * ident - | ExObj of loc * patt * class_str_item - | ExOlb of loc * string * expr - | ExOvr of loc * rec_binding - | ExRec of loc * rec_binding * expr - | ExSeq of loc * expr - | ExSnd of loc * expr * string - | ExSte of loc * expr * expr - | ExStr of loc * string - | ExTry of loc * expr * match_case - | ExTup of loc * expr - | ExCom of loc * expr * expr - | ExTyc of loc * expr * ctyp - | ExVrn of loc * string - | ExWhi of loc * expr * expr - | ExOpI of loc * ident * expr - | ExFUN of loc * string * expr - | ExPkg of loc * module_expr - and module_type = - | MtNil of loc - | MtId of loc * ident - | MtFun of loc * string * module_type * module_type - | MtQuo of loc * string - | MtSig of loc * sig_item - | MtWit of loc * module_type * with_constr - | MtOf of loc * module_expr - | MtAnt of loc * string - and sig_item = - | SgNil of loc - | SgCls of loc * class_type - | SgClt of loc * class_type - | SgSem of loc * sig_item * sig_item - | SgDir of loc * string * expr - | SgExc of loc * ctyp - | SgExt of loc * string * ctyp * string meta_list - | SgInc of loc * module_type - | SgMod of loc * string * module_type - | SgRecMod of loc * module_binding - | SgMty of loc * string * module_type - | SgOpn of loc * ident - | SgTyp of loc * ctyp - | SgVal of loc * string * ctyp - | SgAnt of loc * string - and with_constr = - | WcNil of loc - | WcTyp of loc * ctyp * ctyp - | WcMod of loc * ident * ident - | WcTyS of loc * ctyp * ctyp - | WcMoS of loc * ident * ident - | WcAnd of loc * with_constr * with_constr - | WcAnt of loc * string - and binding = - | BiNil of loc - | BiAnd of loc * binding * binding - | BiEq of loc * patt * expr - | BiAnt of loc * string - and rec_binding = - | RbNil of loc - | RbSem of loc * rec_binding * rec_binding - | RbEq of loc * ident * expr - | RbAnt of loc * string - and module_binding = - | MbNil of loc - | MbAnd of loc * module_binding * module_binding - | MbColEq of loc * string * module_type * module_expr - | MbCol of loc * string * module_type - | MbAnt of loc * string - and match_case = - | McNil of loc - | McOr of loc * match_case * match_case - | McArr of loc * patt * expr * expr - | McAnt of loc * string - and module_expr = - | MeNil of loc - | MeId of loc * ident - | MeApp of loc * module_expr * module_expr - | MeFun of loc * string * module_type * module_expr - | MeStr of loc * str_item - | MeTyc of loc * module_expr * module_type - | MePkg of loc * expr - | MeAnt of loc * string - and str_item = - | StNil of loc - | StCls of loc * class_expr - | StClt of loc * class_type - | StSem of loc * str_item * str_item - | StDir of loc * string * expr - | StExc of loc * ctyp * ident meta_option - | StExp of loc * expr - | StExt of loc * string * ctyp * string meta_list - | StInc of loc * module_expr - | StMod of loc * string * module_expr - | StRecMod of loc * module_binding - | StMty of loc * string * module_type - | StOpn of loc * ident - | StTyp of loc * ctyp - | StVal of loc * rec_flag * binding - | StAnt of loc * string - and class_type = - | CtNil of loc - | CtCon of loc * virtual_flag * ident * ctyp - | CtFun of loc * ctyp * class_type - | CtSig of loc * ctyp * class_sig_item - | CtAnd of loc * class_type * class_type - | CtCol of loc * class_type * class_type - | CtEq of loc * class_type * class_type - | CtAnt of loc * string - and class_sig_item = - | CgNil of loc - | CgCtr of loc * ctyp * ctyp - | CgSem of loc * class_sig_item * class_sig_item - | CgInh of loc * class_type - | CgMth of loc * string * private_flag * ctyp - | CgVal of loc * string * mutable_flag * virtual_flag * ctyp - | CgVir of loc * string * private_flag * ctyp - | CgAnt of loc * string - and class_expr = - | CeNil of loc - | CeApp of loc * class_expr * expr - | CeCon of loc * virtual_flag * ident * ctyp - | CeFun of loc * patt * class_expr - | CeLet of loc * rec_flag * binding * class_expr - | CeStr of loc * patt * class_str_item - | CeTyc of loc * class_expr * class_type - | CeAnd of loc * class_expr * class_expr - | CeEq of loc * class_expr * class_expr - | CeAnt of loc * string - and class_str_item = - | CrNil of loc - | CrSem of loc * class_str_item * class_str_item - | CrCtr of loc * ctyp * ctyp - | CrInh of loc * override_flag * class_expr * string - | CrIni of loc * expr - | CrMth of loc * string * override_flag * private_flag * expr - * ctyp - | CrVal of loc * string * override_flag * mutable_flag * expr - | CrVir of loc * string * private_flag * ctyp - | CrVvr of loc * string * mutable_flag * ctyp - | CrAnt of loc * string - - end - - type ('a, 'loc) stream_filter = - ('a * 'loc) Stream.t -> ('a * 'loc) Stream.t - - module type AstFilters = - sig - module Ast : Camlp4Ast - - type 'a filter = 'a -> 'a - - val register_sig_item_filter : Ast.sig_item filter -> unit - - val register_str_item_filter : Ast.str_item filter -> unit - - val register_topphrase_filter : Ast.str_item filter -> unit - - val fold_interf_filters : - ('a -> Ast.sig_item filter -> 'a) -> 'a -> 'a - - val fold_implem_filters : - ('a -> Ast.str_item filter -> 'a) -> 'a -> 'a - - val fold_topphrase_filters : - ('a -> Ast.str_item filter -> 'a) -> 'a -> 'a - - end - - module type DynAst = - sig - module Ast : Ast - - type 'a tag - - val ctyp_tag : Ast.ctyp tag - - val patt_tag : Ast.patt tag - - val expr_tag : Ast.expr tag - - val module_type_tag : Ast.module_type tag - - val sig_item_tag : Ast.sig_item tag - - val with_constr_tag : Ast.with_constr tag - - val module_expr_tag : Ast.module_expr tag - - val str_item_tag : Ast.str_item tag - - val class_type_tag : Ast.class_type tag - - val class_sig_item_tag : Ast.class_sig_item tag - - val class_expr_tag : Ast.class_expr tag - - val class_str_item_tag : Ast.class_str_item tag - - val match_case_tag : Ast.match_case tag - - val ident_tag : Ast.ident tag - - val binding_tag : Ast.binding tag - - val rec_binding_tag : Ast.rec_binding tag - - val module_binding_tag : Ast.module_binding tag - - val string_of_tag : 'a tag -> string - - module Pack (X : sig type 'a t - end) : - sig - type pack - - val pack : 'a tag -> 'a X.t -> pack - - val unpack : 'a tag -> pack -> 'a X.t - - val print_tag : Format.formatter -> pack -> unit - - end - - end - - type quotation = - { q_name : string; q_loc : string; q_shift : int; q_contents : string - } - - module type Quotation = - sig - module Ast : Ast - - module DynAst : DynAst with module Ast = Ast - - open Ast - - type 'a expand_fun = loc -> string option -> string -> 'a - - val add : string -> 'a DynAst.tag -> 'a expand_fun -> unit - - val find : string -> 'a DynAst.tag -> 'a expand_fun - - val default : string ref - - val parse_quotation_result : - (loc -> string -> 'a) -> loc -> quotation -> string -> string -> 'a - - val translate : (string -> string) ref - - val expand : loc -> quotation -> 'a DynAst.tag -> 'a - - val dump_file : (string option) ref - - module Error : Error - - end - - module type Token = - sig - module Loc : Loc - - type t - - val to_string : t -> string - - val print : Format.formatter -> t -> unit - - val match_keyword : string -> t -> bool - - val extract_string : t -> string - - module Filter : - sig - type token_filter = (t, Loc.t) stream_filter - - type t - - val mk : (string -> bool) -> t - - val define_filter : t -> (token_filter -> token_filter) -> unit - - val filter : t -> token_filter - - val keyword_added : t -> string -> bool -> unit - - val keyword_removed : t -> string -> unit - - end - - module Error : Error - - end - - type camlp4_token = - | KEYWORD of string - | SYMBOL of string - | LIDENT of string - | UIDENT of string - | ESCAPED_IDENT of string - | INT of int * string - | INT32 of int32 * string - | INT64 of int64 * string - | NATIVEINT of nativeint * string - | FLOAT of float * string - | CHAR of char * string - | STRING of string * string - | LABEL of string - | OPTLABEL of string - | QUOTATION of quotation - | ANTIQUOT of string * string - | COMMENT of string - | BLANKS of string - | NEWLINE - | LINE_DIRECTIVE of int * string option - | EOI - - module type Camlp4Token = Token with type t = camlp4_token - - module type DynLoader = - sig - type t - - exception Error of string * string - - val mk : ?ocaml_stdlib: bool -> ?camlp4_stdlib: bool -> unit -> t - - val fold_load_path : t -> (string -> 'a -> 'a) -> 'a -> 'a - - val load : t -> string -> unit - - val include_dir : t -> string -> unit - - val find_in_path : t -> string -> string - - val is_native : bool - - end - - module Grammar = - struct - module type Action = - sig - type t - - val mk : 'a -> t - - val get : t -> 'a - - val getf : t -> 'a -> 'b - - val getf2 : t -> 'a -> 'b -> 'c - - end - - type assoc = | NonA | RightA | LeftA - - type position = - | First - | Last - | Before of string - | After of string - | Level of string - - module type Structure = - sig - module Loc : Loc - - module Action : Action - - module Token : Token with module Loc = Loc - - type gram - - type internal_entry - - type tree - - type token_pattern = ((Token.t -> bool) * string) - - type token_info - - type token_stream = (Token.t * token_info) Stream.t - - val token_location : token_info -> Loc.t - - type symbol = - | Smeta of string * symbol list * Action.t - | Snterm of internal_entry - | Snterml of internal_entry * string - | Slist0 of symbol - | Slist0sep of symbol * symbol - | Slist1 of symbol - | Slist1sep of symbol * symbol - | Sopt of symbol - | Stry of symbol - | Sself - | Snext - | Stoken of token_pattern - | Skeyword of string - | Stree of tree - - type production_rule = ((symbol list) * Action.t) - - type single_extend_statment = - ((string option) * (assoc option) * (production_rule list)) - - type extend_statment = - ((position option) * (single_extend_statment list)) - - type delete_statment = symbol list - - type ('a, 'b, 'c) fold = - internal_entry -> - symbol list -> ('a Stream.t -> 'b) -> 'a Stream.t -> 'c - - type ('a, 'b, 'c) foldsep = - internal_entry -> - symbol list -> - ('a Stream.t -> 'b) -> - ('a Stream.t -> unit) -> 'a Stream.t -> 'c - - end - - module type Dynamic = - sig - include Structure - - val mk : unit -> gram - - module Entry : - sig - type 'a t - - val mk : gram -> string -> 'a t - - val of_parser : - gram -> string -> (token_stream -> 'a) -> 'a t - - val setup_parser : 'a t -> (token_stream -> 'a) -> unit - - val name : 'a t -> string - - val print : Format.formatter -> 'a t -> unit - - val dump : Format.formatter -> 'a t -> unit - - val obj : 'a t -> internal_entry - - val clear : 'a t -> unit - - end - - val get_filter : gram -> Token.Filter.t - - type 'a not_filtered - - val extend : 'a Entry.t -> extend_statment -> unit - - val delete_rule : 'a Entry.t -> delete_statment -> unit - - val srules : - 'a Entry.t -> ((symbol list) * Action.t) list -> symbol - - val sfold0 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold - - val sfold1 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold - - val sfold0sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) foldsep - - val lex : - gram -> - Loc.t -> - char Stream.t -> ((Token.t * Loc.t) Stream.t) not_filtered - - val lex_string : - gram -> - Loc.t -> string -> ((Token.t * Loc.t) Stream.t) not_filtered - - val filter : - gram -> - ((Token.t * Loc.t) Stream.t) not_filtered -> token_stream - - val parse : 'a Entry.t -> Loc.t -> char Stream.t -> 'a - - val parse_string : 'a Entry.t -> Loc.t -> string -> 'a - - val parse_tokens_before_filter : - 'a Entry.t -> ((Token.t * Loc.t) Stream.t) not_filtered -> 'a - - val parse_tokens_after_filter : 'a Entry.t -> token_stream -> 'a - - end - - module type Static = - sig - include Structure - - module Entry : - sig - type 'a t - - val mk : string -> 'a t - - val of_parser : string -> (token_stream -> 'a) -> 'a t - - val setup_parser : 'a t -> (token_stream -> 'a) -> unit - - val name : 'a t -> string - - val print : Format.formatter -> 'a t -> unit - - val dump : Format.formatter -> 'a t -> unit - - val obj : 'a t -> internal_entry - - val clear : 'a t -> unit - - end - - val get_filter : unit -> Token.Filter.t - - type 'a not_filtered - - val extend : 'a Entry.t -> extend_statment -> unit - - val delete_rule : 'a Entry.t -> delete_statment -> unit - - val srules : - 'a Entry.t -> ((symbol list) * Action.t) list -> symbol - - val sfold0 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold - - val sfold1 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold - - val sfold0sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) foldsep - - val lex : - Loc.t -> - char Stream.t -> ((Token.t * Loc.t) Stream.t) not_filtered - - val lex_string : - Loc.t -> string -> ((Token.t * Loc.t) Stream.t) not_filtered - - val filter : - ((Token.t * Loc.t) Stream.t) not_filtered -> token_stream - - val parse : 'a Entry.t -> Loc.t -> char Stream.t -> 'a - - val parse_string : 'a Entry.t -> Loc.t -> string -> 'a - - val parse_tokens_before_filter : - 'a Entry.t -> ((Token.t * Loc.t) Stream.t) not_filtered -> 'a - - val parse_tokens_after_filter : 'a Entry.t -> token_stream -> 'a - - end - - end - - module type Lexer = - sig - module Loc : Loc - - module Token : Token with module Loc = Loc - - module Error : Error - - val mk : unit -> Loc.t -> char Stream.t -> (Token.t * Loc.t) Stream.t - - end - - module Parser (Ast : Ast) = - struct - module type SIMPLE = - sig - val parse_expr : Ast.loc -> string -> Ast.expr - - val parse_patt : Ast.loc -> string -> Ast.patt - - end - - module type S = - sig - val parse_implem : - ?directive_handler: (Ast.str_item -> Ast.str_item option) -> - Ast.loc -> char Stream.t -> Ast.str_item - - val parse_interf : - ?directive_handler: (Ast.sig_item -> Ast.sig_item option) -> - Ast.loc -> char Stream.t -> Ast.sig_item - - end - - end - - module Printer (Ast : Ast) = - struct - module type S = - sig - val print_interf : - ?input_file: string -> - ?output_file: string -> Ast.sig_item -> unit - - val print_implem : - ?input_file: string -> - ?output_file: string -> Ast.str_item -> unit - - end - - end - - module type Syntax = - sig - 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 Quotation : Quotation with module Ast = Ast - - module AntiquotSyntax : Parser(Ast).SIMPLE - - include Warning(Loc).S - - include Parser(Ast).S - - include Printer(Ast).S - - end - - module type Camlp4Syntax = - sig - module Loc : Loc - - module Ast : Camlp4Ast with module Loc = Loc - - module Token : Camlp4Token with module Loc = Loc - - module Gram : Grammar.Static with module Loc = Loc - and module Token = Token - - 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 - - val interf : ((Ast.sig_item list) * (Loc.t option)) Gram.Entry.t - - val implem : ((Ast.str_item list) * (Loc.t option)) Gram.Entry.t - - val top_phrase : (Ast.str_item option) Gram.Entry.t - - val use_file : ((Ast.str_item list) * (Loc.t option)) Gram.Entry.t - - val a_CHAR : string Gram.Entry.t - - val a_FLOAT : string Gram.Entry.t - - val a_INT : string Gram.Entry.t - - val a_INT32 : string Gram.Entry.t - - val a_INT64 : string Gram.Entry.t - - val a_LABEL : string Gram.Entry.t - - val a_LIDENT : string Gram.Entry.t - - val a_NATIVEINT : string Gram.Entry.t - - val a_OPTLABEL : string Gram.Entry.t - - val a_STRING : string Gram.Entry.t - - val a_UIDENT : string Gram.Entry.t - - val a_ident : string Gram.Entry.t - - val amp_ctyp : Ast.ctyp Gram.Entry.t - - val and_ctyp : Ast.ctyp Gram.Entry.t - - val match_case : Ast.match_case Gram.Entry.t - - val match_case0 : Ast.match_case Gram.Entry.t - - val match_case_quot : Ast.match_case Gram.Entry.t - - val binding : Ast.binding Gram.Entry.t - - val binding_quot : Ast.binding Gram.Entry.t - - val rec_binding_quot : Ast.rec_binding Gram.Entry.t - - val class_declaration : Ast.class_expr Gram.Entry.t - - val class_description : Ast.class_type Gram.Entry.t - - val class_expr : Ast.class_expr Gram.Entry.t - - val class_expr_quot : Ast.class_expr Gram.Entry.t - - val class_fun_binding : Ast.class_expr Gram.Entry.t - - val class_fun_def : Ast.class_expr Gram.Entry.t - - val class_info_for_class_expr : Ast.class_expr Gram.Entry.t - - val class_info_for_class_type : Ast.class_type Gram.Entry.t - - val class_longident : Ast.ident Gram.Entry.t - - val class_longident_and_param : Ast.class_expr Gram.Entry.t - - val class_name_and_param : (string * Ast.ctyp) Gram.Entry.t - - val class_sig_item : Ast.class_sig_item Gram.Entry.t - - val class_sig_item_quot : Ast.class_sig_item Gram.Entry.t - - val class_signature : Ast.class_sig_item Gram.Entry.t - - val class_str_item : Ast.class_str_item Gram.Entry.t - - val class_str_item_quot : Ast.class_str_item Gram.Entry.t - - val class_structure : Ast.class_str_item Gram.Entry.t - - val class_type : Ast.class_type Gram.Entry.t - - val class_type_declaration : Ast.class_type Gram.Entry.t - - val class_type_longident : Ast.ident Gram.Entry.t - - val class_type_longident_and_param : Ast.class_type Gram.Entry.t - - val class_type_plus : Ast.class_type Gram.Entry.t - - val class_type_quot : Ast.class_type Gram.Entry.t - - val comma_ctyp : Ast.ctyp Gram.Entry.t - - val comma_expr : Ast.expr Gram.Entry.t - - val comma_ipatt : Ast.patt Gram.Entry.t - - val comma_patt : Ast.patt Gram.Entry.t - - val comma_type_parameter : Ast.ctyp Gram.Entry.t - - val constrain : (Ast.ctyp * Ast.ctyp) Gram.Entry.t - - val constructor_arg_list : Ast.ctyp Gram.Entry.t - - val constructor_declaration : Ast.ctyp Gram.Entry.t - - val constructor_declarations : Ast.ctyp Gram.Entry.t - - val ctyp : Ast.ctyp Gram.Entry.t - - val ctyp_quot : Ast.ctyp Gram.Entry.t - - val cvalue_binding : Ast.expr Gram.Entry.t - - val direction_flag : Ast.direction_flag Gram.Entry.t - - val direction_flag_quot : Ast.direction_flag Gram.Entry.t - - val dummy : unit Gram.Entry.t - - val eq_expr : (string -> Ast.patt -> Ast.patt) Gram.Entry.t - - val expr : Ast.expr Gram.Entry.t - - val expr_eoi : Ast.expr Gram.Entry.t - - val expr_quot : Ast.expr Gram.Entry.t - - val field_expr : Ast.rec_binding Gram.Entry.t - - val field_expr_list : Ast.rec_binding Gram.Entry.t - - val fun_binding : Ast.expr Gram.Entry.t - - val fun_def : Ast.expr Gram.Entry.t - - val ident : Ast.ident Gram.Entry.t - - val ident_quot : Ast.ident Gram.Entry.t - - val ipatt : Ast.patt Gram.Entry.t - - val ipatt_tcon : Ast.patt Gram.Entry.t - - val label : string Gram.Entry.t - - val label_declaration : Ast.ctyp Gram.Entry.t - - val label_declaration_list : Ast.ctyp Gram.Entry.t - - val label_expr : Ast.rec_binding Gram.Entry.t - - val label_expr_list : Ast.rec_binding Gram.Entry.t - - val label_ipatt : Ast.patt Gram.Entry.t - - val label_ipatt_list : Ast.patt Gram.Entry.t - - val label_longident : Ast.ident Gram.Entry.t - - val label_patt : Ast.patt Gram.Entry.t - - val label_patt_list : Ast.patt Gram.Entry.t - - val labeled_ipatt : Ast.patt Gram.Entry.t - - val let_binding : Ast.binding Gram.Entry.t - - val meth_list : (Ast.ctyp * Ast.row_var_flag) Gram.Entry.t - - val meth_decl : Ast.ctyp Gram.Entry.t - - val module_binding : Ast.module_binding Gram.Entry.t - - val module_binding0 : Ast.module_expr Gram.Entry.t - - val module_binding_quot : Ast.module_binding Gram.Entry.t - - val module_declaration : Ast.module_type Gram.Entry.t - - val module_expr : Ast.module_expr Gram.Entry.t - - val module_expr_quot : Ast.module_expr Gram.Entry.t - - val module_longident : Ast.ident Gram.Entry.t - - val module_longident_with_app : Ast.ident Gram.Entry.t - - val module_rec_declaration : Ast.module_binding Gram.Entry.t - - val module_type : Ast.module_type Gram.Entry.t - - val package_type : Ast.module_type Gram.Entry.t - - val module_type_quot : Ast.module_type Gram.Entry.t - - val more_ctyp : Ast.ctyp Gram.Entry.t - - val name_tags : Ast.ctyp Gram.Entry.t - - val opt_as_lident : string Gram.Entry.t - - val opt_class_self_patt : Ast.patt Gram.Entry.t - - val opt_class_self_type : Ast.ctyp Gram.Entry.t - - val opt_comma_ctyp : Ast.ctyp Gram.Entry.t - - val opt_dot_dot : Ast.row_var_flag Gram.Entry.t - - val row_var_flag_quot : Ast.row_var_flag Gram.Entry.t - - val opt_eq_ctyp : Ast.ctyp Gram.Entry.t - - val opt_expr : Ast.expr Gram.Entry.t - - val opt_meth_list : Ast.ctyp Gram.Entry.t - - val opt_mutable : Ast.mutable_flag Gram.Entry.t - - val mutable_flag_quot : Ast.mutable_flag Gram.Entry.t - - val opt_override : Ast.override_flag Gram.Entry.t - - val override_flag_quot : Ast.override_flag Gram.Entry.t - - val opt_polyt : Ast.ctyp Gram.Entry.t - - val opt_private : Ast.private_flag Gram.Entry.t - - val private_flag_quot : Ast.private_flag Gram.Entry.t - - val opt_rec : Ast.rec_flag Gram.Entry.t - - val rec_flag_quot : Ast.rec_flag Gram.Entry.t - - val opt_virtual : Ast.virtual_flag Gram.Entry.t - - val virtual_flag_quot : Ast.virtual_flag Gram.Entry.t - - val opt_when_expr : Ast.expr Gram.Entry.t - - val patt : Ast.patt Gram.Entry.t - - val patt_as_patt_opt : Ast.patt Gram.Entry.t - - val patt_eoi : Ast.patt Gram.Entry.t - - val patt_quot : Ast.patt Gram.Entry.t - - val patt_tcon : Ast.patt Gram.Entry.t - - val phrase : Ast.str_item Gram.Entry.t - - val poly_type : Ast.ctyp Gram.Entry.t - - val row_field : Ast.ctyp Gram.Entry.t - - val sem_expr : Ast.expr Gram.Entry.t - - val sem_expr_for_list : (Ast.expr -> Ast.expr) Gram.Entry.t - - val sem_patt : Ast.patt Gram.Entry.t - - val sem_patt_for_list : (Ast.patt -> Ast.patt) Gram.Entry.t - - val semi : unit Gram.Entry.t - - val sequence : Ast.expr Gram.Entry.t - - val do_sequence : Ast.expr Gram.Entry.t - - val sig_item : Ast.sig_item Gram.Entry.t - - val sig_item_quot : Ast.sig_item Gram.Entry.t - - val sig_items : Ast.sig_item Gram.Entry.t - - val star_ctyp : Ast.ctyp Gram.Entry.t - - val str_item : Ast.str_item Gram.Entry.t - - val str_item_quot : Ast.str_item Gram.Entry.t - - val str_items : Ast.str_item Gram.Entry.t - - val type_constraint : unit Gram.Entry.t - - val type_declaration : Ast.ctyp Gram.Entry.t - - val type_ident_and_parameters : - (string * (Ast.ctyp list)) Gram.Entry.t - - val type_kind : Ast.ctyp Gram.Entry.t - - val type_longident : Ast.ident Gram.Entry.t - - val type_longident_and_parameters : Ast.ctyp Gram.Entry.t - - val type_parameter : Ast.ctyp Gram.Entry.t - - val type_parameters : (Ast.ctyp -> Ast.ctyp) Gram.Entry.t - - val typevars : Ast.ctyp Gram.Entry.t - - val val_longident : Ast.ident Gram.Entry.t - - val value_let : unit Gram.Entry.t - - val value_val : unit Gram.Entry.t - - val with_constr : Ast.with_constr Gram.Entry.t - - val with_constr_quot : Ast.with_constr Gram.Entry.t - - val prefixop : Ast.expr Gram.Entry.t - - val infixop0 : Ast.expr Gram.Entry.t - - val infixop1 : Ast.expr Gram.Entry.t - - val infixop2 : Ast.expr Gram.Entry.t - - val infixop3 : Ast.expr Gram.Entry.t - - val infixop4 : Ast.expr Gram.Entry.t - - end - - 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 Quotation = Syn.Quotation - - end - -module ErrorHandler : - sig - val print : Format.formatter -> exn -> unit - - val try_print : Format.formatter -> exn -> unit - - val to_string : exn -> string - - val try_to_string : exn -> string - - val register : (Format.formatter -> exn -> unit) -> unit - - module Register (Error : Sig.Error) : sig end - - module ObjTools : - sig - val print : Format.formatter -> Obj.t -> unit - - val print_desc : Format.formatter -> Obj.t -> unit - - val to_string : Obj.t -> string - - val desc : Obj.t -> string - - end - - end = - struct - open Format - - module ObjTools = - struct - let desc obj = - if Obj.is_block obj - then "tag = " ^ (string_of_int (Obj.tag obj)) - else "int_val = " ^ (string_of_int (Obj.obj obj)) - - let rec to_string r = - if Obj.is_int r - then - (let i : int = Obj.magic r - in (string_of_int i) ^ (" | CstTag" ^ (string_of_int (i + 1)))) - else - (let rec get_fields acc = - function - | 0 -> acc - | n -> let n = n - 1 in get_fields ((Obj.field r n) :: acc) n in - let rec is_list r = - if Obj.is_int r - then r = (Obj.repr 0) - else - (let s = Obj.size r - and t = Obj.tag r - in (t = 0) && ((s = 2) && (is_list (Obj.field r 1)))) in - let rec get_list r = - if Obj.is_int r - then [] - else - (let h = Obj.field r 0 - and t = get_list (Obj.field r 1) - in h :: t) in - let opaque name = "<" ^ (name ^ ">") in - let s = Obj.size r - and t = Obj.tag r - in - match t with - | _ when is_list r -> - let fields = get_list r - in - "[" ^ - ((String.concat "; " (List.map to_string fields)) ^ - "]") - | 0 -> - let fields = get_fields [] s - in - "(" ^ - ((String.concat ", " (List.map to_string fields)) ^ - ")") - | x when x = Obj.lazy_tag -> opaque "lazy" - | x when x = Obj.closure_tag -> opaque "closure" - | x when x = Obj.object_tag -> - let fields = get_fields [] s in - let (_class, id, slots) = - (match fields with - | h :: h' :: t -> (h, h', t) - | _ -> assert false) - in - "Object #" ^ - ((to_string id) ^ - (" (" ^ - ((String.concat ", " (List.map to_string slots)) - ^ ")"))) - | x when x = Obj.infix_tag -> opaque "infix" - | x when x = Obj.forward_tag -> opaque "forward" - | x when x < Obj.no_scan_tag -> - let fields = get_fields [] s - in - "Tag" ^ - ((string_of_int t) ^ - (" (" ^ - ((String.concat ", " (List.map to_string fields)) - ^ ")"))) - | x when x = Obj.string_tag -> - "\"" ^ ((String.escaped (Obj.magic r : string)) ^ "\"") - | x when x = Obj.double_tag -> - Camlp4_import.Oprint.float_repres (Obj.magic r : float) - | x when x = Obj.abstract_tag -> opaque "abstract" - | x when x = Obj.custom_tag -> opaque "custom" - | x when x = Obj.final_tag -> opaque "final" - | _ -> - failwith - ("ObjTools.to_string: unknown tag (" ^ - ((string_of_int t) ^ ")"))) - - let print ppf x = fprintf ppf "%s" (to_string x) - - let print_desc ppf x = fprintf ppf "%s" (desc x) - - end - - let default_handler ppf x = - let x = Obj.repr x - in - (fprintf ppf "Camlp4: Uncaught exception: %s" - (Obj.obj (Obj.field (Obj.field x 0) 0) : string); - if (Obj.size x) > 1 - then - (pp_print_string ppf " ("; - for i = 1 to (Obj.size x) - 1 do - if i > 1 then pp_print_string ppf ", " else (); - ObjTools.print ppf (Obj.field x i) - done; - pp_print_char ppf ')') - else (); - fprintf ppf "@.") - - let handler = - ref (fun ppf default_handler exn -> default_handler ppf exn) - - let register f = - let current_handler = !handler - in - handler := - fun ppf default_handler exn -> - try f ppf exn - with | exn -> current_handler ppf default_handler exn - - module Register (Error : Sig.Error) = - struct - let _ = - let current_handler = !handler - in - handler := - fun ppf default_handler -> - function - | Error.E x -> Error.print ppf x - | x -> current_handler ppf default_handler x - - end - - let gen_print ppf default_handler = - function - | Out_of_memory -> fprintf ppf "Out of memory" - | Assert_failure ((file, line, char)) -> - fprintf ppf "Assertion failed, file %S, line %d, char %d" file line - char - | Match_failure ((file, line, char)) -> - fprintf ppf "Pattern matching failed, file %S, line %d, char %d" - file line char - | Failure str -> fprintf ppf "Failure: %S" str - | Invalid_argument str -> fprintf ppf "Invalid argument: %S" str - | Sys_error str -> fprintf ppf "I/O error: %S" str - | Stream.Failure -> fprintf ppf "Parse failure" - | Stream.Error str -> fprintf ppf "Parse error: %s" str - | x -> !handler ppf default_handler x - - let print ppf = gen_print ppf default_handler - - let try_print ppf = gen_print ppf (fun _ -> raise) - - let to_string exn = - let buf = Buffer.create 128 in - let () = bprintf buf "%a" print exn in Buffer.contents buf - - let try_to_string exn = - let buf = Buffer.create 128 in - let () = bprintf buf "%a" try_print exn in Buffer.contents buf - - end - -module Struct = - struct - module Loc : sig include Sig.Loc - end = - struct - open Format - - type pos = { line : int; bol : int; off : int } - - type t = - { file_name : string; start : pos; stop : pos; ghost : bool - } - - let dump_sel f x = - let s = - match x with - | `start -> "`start" - | `stop -> "`stop" - | `both -> "`both" - | _ -> "" - in pp_print_string f s - - let dump_pos f x = - fprintf f "@[{ line = %d ;@ bol = %d ;@ off = %d } : pos@]" - x.line x.bol x.off - - let dump_long f x = - fprintf f - "@[{ file_name = %s ;@ start = %a (%d-%d);@ stop = %a (%d);@ ghost = %b@ } : Loc.t@]" - x.file_name dump_pos x.start (x.start.off - x.start.bol) - (x.stop.off - x.start.bol) dump_pos x.stop - (x.stop.off - x.stop.bol) x.ghost - - let dump f x = - fprintf f "[%S: %d:%d-%d %d:%d%t]" x.file_name x.start.line - (x.start.off - x.start.bol) (x.stop.off - x.start.bol) - x.stop.line (x.stop.off - x.stop.bol) - (fun o -> if x.ghost then fprintf o " (ghost)" else ()) - - let start_pos = { line = 1; bol = 0; off = 0; } - - let ghost = - { - file_name = "ghost-location"; - start = start_pos; - stop = start_pos; - ghost = true; - } - - let mk file_name = - { - file_name = file_name; - start = start_pos; - stop = start_pos; - ghost = false; - } - - let of_tuple (file_name, start_line, start_bol, start_off, stop_line, - stop_bol, stop_off, ghost) - = - { - file_name = file_name; - start = { line = start_line; bol = start_bol; off = start_off; }; - stop = { line = stop_line; bol = stop_bol; off = stop_off; }; - ghost = ghost; - } - - let to_tuple { - file_name = file_name; - start = - { - line = start_line; - bol = start_bol; - off = start_off - }; - stop = - { line = stop_line; bol = stop_bol; off = stop_off }; - ghost = ghost - } = - (file_name, start_line, start_bol, start_off, stop_line, stop_bol, - stop_off, ghost) - - let pos_of_lexing_position p = - let pos = - { - line = p.Lexing.pos_lnum; - bol = p.Lexing.pos_bol; - off = p.Lexing.pos_cnum; - } - in pos - - let pos_to_lexing_position p file_name = - { - Lexing.pos_fname = file_name; - pos_lnum = p.line; - pos_bol = p.bol; - pos_cnum = p.off; - } - - let better_file_name a b = - match (a, b) with - | ("", "") -> a - | ("", x) -> x - | (x, "") -> x - | ("-", x) -> x - | (x, "-") -> x - | (x, _) -> x - - let of_lexbuf lb = - let start = Lexing.lexeme_start_p lb - and stop = Lexing.lexeme_end_p lb in - let loc = - { - file_name = - better_file_name start.Lexing.pos_fname stop.Lexing.pos_fname; - start = pos_of_lexing_position start; - stop = pos_of_lexing_position stop; - ghost = false; - } - in loc - - let of_lexing_position pos = - let loc = - { - file_name = pos.Lexing.pos_fname; - start = pos_of_lexing_position pos; - stop = pos_of_lexing_position pos; - ghost = false; - } - in loc - - let to_ocaml_location x = - { - 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; - } - - let 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 = g; - } - in res - - let start_pos x = pos_to_lexing_position x.start x.file_name - - let stop_pos x = pos_to_lexing_position x.stop x.file_name - - let merge a b = - if a == b - then a - else - (let r = - match ((a.ghost), (b.ghost)) with - | (false, false) -> { (a) with stop = b.stop; } - | (true, true) -> { (a) with stop = b.stop; } - | (true, _) -> { (a) with stop = b.stop; } - | (_, true) -> { (b) with start = a.start; } - in r) - - let join x = { (x) with stop = x.start; } - - let map f start_stop_both x = - match start_stop_both with - | `start -> { (x) with start = f x.start; } - | `stop -> { (x) with stop = f x.stop; } - | `both -> { (x) with start = f x.start; stop = f x.stop; } - - let move_pos chars x = { (x) with off = x.off + chars; } - - let move s chars x = map (move_pos chars) s x - - let move_line lines x = - let move_line_pos x = - { (x) with line = x.line + lines; bol = x.off; } - in map move_line_pos `both x - - let shift width x = - { (x) with start = x.stop; stop = move_pos width x.stop; } - - let file_name x = x.file_name - - let start_line x = x.start.line - - let stop_line x = x.stop.line - - let start_bol x = x.start.bol - - let stop_bol x = x.stop.bol - - let start_off x = x.start.off - - let stop_off x = x.stop.off - - let is_ghost x = x.ghost - - let set_file_name s x = { (x) with file_name = s; } - - let ghostify x = { (x) with ghost = true; } - - let make_absolute x = - let pwd = Sys.getcwd () - in - if Filename.is_relative x.file_name - then { (x) with file_name = Filename.concat pwd x.file_name; } - else x - - let strictly_before x y = - let b = (x.stop.off < y.start.off) && (x.file_name = y.file_name) - in b - - let to_string x = - let (a, b) = ((x.start), (x.stop)) in - let res = - sprintf "File \"%s\", line %d, characters %d-%d" x.file_name - a.line (a.off - a.bol) (b.off - a.bol) - in - if x.start.line <> x.stop.line - then - sprintf "%s (end at line %d, character %d)" res x.stop.line - (b.off - b.bol) - else res - - let print out x = pp_print_string out (to_string x) - - let check x msg = - if - ((start_line x) > (stop_line x)) || - (((start_bol x) > (stop_bol x)) || - (((start_off x) > (stop_off x)) || - (((start_line x) < 0) || - (((stop_line x) < 0) || - (((start_bol x) < 0) || - (((stop_bol x) < 0) || - (((start_off x) < 0) || ((stop_off x) < 0)))))))) - then - (eprintf "*** Warning: (%s) strange positions ***\n%a@\n" msg - print x; - false) - else true - - exception Exc_located of t * exn - - let _ = - ErrorHandler.register - (fun ppf -> - function - | Exc_located (loc, exn) -> - fprintf ppf "%a:@\n%a" print loc ErrorHandler.print exn - | exn -> raise exn) - - let name = ref "_loc" - - let raise loc exc = - match exc with - | Exc_located (_, _) -> raise exc - | _ -> raise (Exc_located (loc, exc)) - - end - - module Token : - sig - module Make (Loc : Sig.Loc) : Sig.Camlp4Token with module Loc = Loc - - module Eval : - sig - val char : string -> char - - val string : ?strict: unit -> string -> string - - end - - end = - struct - open Format - - module Make (Loc : Sig.Loc) : Sig.Camlp4Token with module Loc = Loc = - struct - module Loc = Loc - - open Sig - - type t = camlp4_token - - type token = t - - let to_string = - function - | KEYWORD s -> sprintf "KEYWORD %S" s - | SYMBOL s -> sprintf "SYMBOL %S" s - | LIDENT s -> sprintf "LIDENT %S" s - | UIDENT s -> sprintf "UIDENT %S" s - | INT (_, s) -> sprintf "INT %s" s - | INT32 (_, s) -> sprintf "INT32 %sd" s - | INT64 (_, s) -> sprintf "INT64 %sd" s - | NATIVEINT (_, s) -> sprintf "NATIVEINT %sd" s - | FLOAT (_, s) -> sprintf "FLOAT %s" s - | CHAR (_, s) -> sprintf "CHAR '%s'" s - | STRING (_, s) -> sprintf "STRING \"%s\"" s - | LABEL s -> sprintf "LABEL %S" s - | OPTLABEL s -> sprintf "OPTLABEL %S" s - | ANTIQUOT (n, s) -> sprintf "ANTIQUOT %s: %S" n s - | QUOTATION x -> - sprintf - "QUOTATION { q_name=%S; q_loc=%S; q_shift=%d; q_contents=%S }" - x.q_name x.q_loc x.q_shift x.q_contents - | COMMENT s -> sprintf "COMMENT %S" s - | BLANKS s -> sprintf "BLANKS %S" s - | NEWLINE -> sprintf "NEWLINE" - | EOI -> sprintf "EOI" - | ESCAPED_IDENT s -> sprintf "ESCAPED_IDENT %S" s - | LINE_DIRECTIVE (i, None) -> sprintf "LINE_DIRECTIVE %d" i - | LINE_DIRECTIVE (i, (Some s)) -> - sprintf "LINE_DIRECTIVE %d %S" i s - - let print ppf x = pp_print_string ppf (to_string x) - - let match_keyword kwd = - function | KEYWORD kwd' when kwd = kwd' -> true | _ -> false - - let extract_string = - function - | KEYWORD s | SYMBOL s | LIDENT s | UIDENT s | INT (_, s) | - INT32 (_, s) | INT64 (_, s) | NATIVEINT (_, s) | - FLOAT (_, s) | CHAR (_, s) | STRING (_, s) | LABEL s | - OPTLABEL s | COMMENT s | BLANKS s | ESCAPED_IDENT s -> s - | tok -> - invalid_arg - ("Cannot extract a string from this token: " ^ - (to_string tok)) - - module Error = - struct - type t = - | Illegal_token of string - | Keyword_as_label of string - | Illegal_token_pattern of string * string - | Illegal_constructor of string - - exception E of t - - let print ppf = - function - | Illegal_token s -> fprintf ppf "Illegal token (%s)" s - | Keyword_as_label kwd -> - fprintf ppf - "`%s' is a keyword, it cannot be used as label name" - kwd - | Illegal_token_pattern (p_con, p_prm) -> - fprintf ppf "Illegal token pattern: %s %S" p_con p_prm - | Illegal_constructor con -> - fprintf ppf "Illegal constructor %S" con - - let to_string x = - let b = Buffer.create 50 in - let () = bprintf b "%a" print x in Buffer.contents b - - end - - let _ = let module M = ErrorHandler.Register(Error) in () - - module Filter = - struct - type token_filter = (t, Loc.t) stream_filter - - type t = - { is_kwd : string -> bool; mutable filter : token_filter - } - - let err error loc = - raise (Loc.Exc_located (loc, (Error.E error))) - - let keyword_conversion tok is_kwd = - match tok with - | SYMBOL s | LIDENT s | UIDENT s when is_kwd s -> KEYWORD s - | ESCAPED_IDENT s -> LIDENT s - | _ -> tok - - let check_keyword_as_label tok loc is_kwd = - let s = - match tok with | LABEL s -> s | OPTLABEL s -> s | _ -> "" - in - if (s <> "") && (is_kwd s) - then err (Error.Keyword_as_label s) loc - else () - - let check_unknown_keywords tok loc = - match tok with - | SYMBOL s -> err (Error.Illegal_token s) loc - | _ -> () - - let error_no_respect_rules p_con p_prm = - raise - (Error.E (Error.Illegal_token_pattern (p_con, p_prm))) - - let check_keyword _ = true - - let error_on_unknown_keywords = ref false - - let rec ignore_layout (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some - (((COMMENT _ | BLANKS _ | NEWLINE | - LINE_DIRECTIVE (_, _)), - _)) - -> (Stream.junk __strm; ignore_layout __strm) - | Some x -> - (Stream.junk __strm; - let s = __strm - in - Stream.icons x - (Stream.slazy (fun _ -> ignore_layout s))) - | _ -> Stream.sempty - - let mk is_kwd = { is_kwd = is_kwd; filter = ignore_layout; } - - let filter x = - let f tok loc = - let tok = keyword_conversion tok x.is_kwd - in - (check_keyword_as_label tok loc x.is_kwd; - if !error_on_unknown_keywords - then check_unknown_keywords tok loc - else (); - (tok, loc)) in - let rec filter (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some ((tok, loc)) -> - (Stream.junk __strm; - let s = __strm - in - Stream.lcons (fun _ -> f tok loc) - (Stream.slazy (fun _ -> filter s))) - | _ -> Stream.sempty in - let rec tracer (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some (((_tok, _loc) as x)) -> - (Stream.junk __strm; - let xs = __strm - in - Stream.icons x (Stream.slazy (fun _ -> tracer xs))) - | _ -> Stream.sempty - in fun strm -> tracer (x.filter (filter strm)) - - let define_filter x f = x.filter <- f x.filter - - let keyword_added _ _ _ = () - - let keyword_removed _ _ = () - - end - - end - - module Eval = - struct - let valch x = (Char.code x) - (Char.code '0') - - let valch_hex x = - let d = Char.code x - in - if d >= 97 - then d - 87 - else if d >= 65 then d - 55 else d - 48 - - let rec skip_indent (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some (' ' | '\t') -> (Stream.junk __strm; skip_indent __strm) - | _ -> () - - let skip_opt_linefeed (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some '\n' -> (Stream.junk __strm; ()) - | _ -> () - - let chr c = - if (c < 0) || (c > 255) - then failwith "invalid char token" - else Char.chr c - - let rec backslash (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some '\n' -> (Stream.junk __strm; '\n') - | Some '\r' -> (Stream.junk __strm; '\r') - | Some 'n' -> (Stream.junk __strm; '\n') - | Some 'r' -> (Stream.junk __strm; '\r') - | Some 't' -> (Stream.junk __strm; '\t') - | Some 'b' -> (Stream.junk __strm; '\b') - | Some '\\' -> (Stream.junk __strm; '\\') - | Some '"' -> (Stream.junk __strm; '"') - | Some '\'' -> (Stream.junk __strm; '\'') - | Some ' ' -> (Stream.junk __strm; ' ') - | Some (('0' .. '9' as c1)) -> - (Stream.junk __strm; - (match Stream.peek __strm with - | Some (('0' .. '9' as c2)) -> - (Stream.junk __strm; - (match Stream.peek __strm with - | Some (('0' .. '9' as c3)) -> - (Stream.junk __strm; - chr - (((100 * (valch c1)) + (10 * (valch c2))) + - (valch c3))) - | _ -> raise (Stream.Error ""))) - | _ -> raise (Stream.Error ""))) - | Some 'x' -> - (Stream.junk __strm; - (match Stream.peek __strm with - | Some (('0' .. '9' | 'a' .. 'f' | 'A' .. 'F' as c1)) -> - (Stream.junk __strm; - (match Stream.peek __strm with - | Some - (('0' .. '9' | 'a' .. 'f' | 'A' .. 'F' as c2)) - -> - (Stream.junk __strm; - chr ((16 * (valch_hex c1)) + (valch_hex c2))) - | _ -> raise (Stream.Error ""))) - | _ -> raise (Stream.Error ""))) - | _ -> raise Stream.Failure - - let rec backslash_in_string strict store (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some '\n' -> (Stream.junk __strm; skip_indent __strm) - | Some '\r' -> - (Stream.junk __strm; - let s = __strm in (skip_opt_linefeed s; skip_indent s)) - | _ -> - (match try Some (backslash __strm) - with | Stream.Failure -> None - with - | Some x -> store x - | _ -> - (match Stream.peek __strm with - | Some c when not strict -> - (Stream.junk __strm; store '\\'; store c) - | _ -> failwith "invalid string token")) - - let char s = - if (String.length s) = 1 - then s.[0] - else - if (String.length s) = 0 - then failwith "invalid char token" - else - (let (__strm : _ Stream.t) = Stream.of_string s - in - match Stream.peek __strm with - | Some '\\' -> - (Stream.junk __strm; - (try backslash __strm - with | Stream.Failure -> raise (Stream.Error ""))) - | _ -> failwith "invalid char token") - - let string ?strict s = - let buf = Buffer.create 23 in - let store = Buffer.add_char buf in - let rec parse (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some '\\' -> - (Stream.junk __strm; - let _ = - (try backslash_in_string (strict <> None) store __strm - with | Stream.Failure -> raise (Stream.Error "")) - in parse __strm) - | Some c -> - (Stream.junk __strm; - let s = __strm in (store c; parse s)) - | _ -> Buffer.contents buf - in parse (Stream.of_string s) - - end - - end - - module Lexer = - struct - module TokenEval = Token.Eval - - module Make (Token : Sig.Camlp4Token) = - struct - module Loc = Token.Loc - - module Token = Token - - open Lexing - - open Sig - - module Error = - struct - type t = - | Illegal_character of char - | Illegal_escape of string - | Unterminated_comment - | Unterminated_string - | Unterminated_quotation - | Unterminated_antiquot - | Unterminated_string_in_comment - | Comment_start - | Comment_not_end - | Literal_overflow of string - - exception E of t - - open Format - - let print ppf = - function - | Illegal_character c -> - fprintf ppf "Illegal character (%s)" (Char.escaped c) - | Illegal_escape s -> - fprintf ppf - "Illegal backslash escape in string or character (%s)" - s - | Unterminated_comment -> - fprintf ppf "Comment not terminated" - | Unterminated_string -> - fprintf ppf "String literal not terminated" - | Unterminated_string_in_comment -> - fprintf ppf - "This comment contains an unterminated string literal" - | Unterminated_quotation -> - fprintf ppf "Quotation not terminated" - | Unterminated_antiquot -> - fprintf ppf "Antiquotation not terminated" - | Literal_overflow ty -> - fprintf ppf - "Integer literal exceeds the range of representable integers of type %s" - ty - | Comment_start -> - fprintf ppf "this is the start of a comment" - | Comment_not_end -> - fprintf ppf "this is not the end of a comment" - - let to_string x = - let b = Buffer.create 50 in - let () = bprintf b "%a" print x in Buffer.contents b - - end - - let _ = let module M = ErrorHandler.Register(Error) in () - - open Error - - type context = - { loc : Loc.t; in_comment : bool; quotations : bool; - antiquots : bool; lexbuf : lexbuf; buffer : Buffer.t - } - - let default_context lb = - { - loc = Loc.ghost; - in_comment = false; - quotations = true; - antiquots = false; - lexbuf = lb; - buffer = Buffer.create 256; - } - - let store c = Buffer.add_string c.buffer (Lexing.lexeme c.lexbuf) - - let istore_char c i = - Buffer.add_char c.buffer (Lexing.lexeme_char c.lexbuf i) - - let buff_contents c = - let contents = Buffer.contents c.buffer - in (Buffer.reset c.buffer; contents) - - let loc c = Loc.merge c.loc (Loc.of_lexbuf c.lexbuf) - - let quotations c = c.quotations - - let antiquots c = c.antiquots - - let is_in_comment c = c.in_comment - - let in_comment c = { (c) with in_comment = true; } - - let set_start_p c = c.lexbuf.lex_start_p <- Loc.start_pos c.loc - - let move_start_p shift c = - let p = c.lexbuf.lex_start_p - in - c.lexbuf.lex_start_p <- - { (p) with pos_cnum = p.pos_cnum + shift; } - - let update_loc c = { (c) with loc = Loc.of_lexbuf c.lexbuf; } - - let with_curr_loc f c = f (update_loc c) c.lexbuf - - let parse_nested f c = - (with_curr_loc f c; set_start_p c; buff_contents c) - - let shift n c = { (c) with loc = Loc.move `both n c.loc; } - - let store_parse f c = (store c; f c c.lexbuf) - - let parse f c = f c c.lexbuf - - let mk_quotation quotation c name loc shift = - let s = parse_nested quotation (update_loc c) in - let contents = String.sub s 0 ((String.length s) - 2) - in - QUOTATION - { - q_name = name; - q_loc = loc; - q_shift = shift; - q_contents = contents; - } - - let update_loc c file line absolute chars = - let lexbuf = c.lexbuf in - let pos = lexbuf.lex_curr_p in - let new_file = - match file with | None -> pos.pos_fname | Some s -> s - in - lexbuf.lex_curr_p <- - { - (pos) - with - pos_fname = new_file; - pos_lnum = if absolute then line else pos.pos_lnum + line; - pos_bol = pos.pos_cnum - chars; - } - - let cvt_int_literal s = - (int_of_string ("-" ^ s)) - - let cvt_int32_literal s = Int32.neg (Int32.of_string ("-" ^ s)) - - let cvt_int64_literal s = Int64.neg (Int64.of_string ("-" ^ s)) - - let cvt_nativeint_literal s = - Nativeint.neg (Nativeint.of_string ("-" ^ s)) - - let err error loc = - raise (Loc.Exc_located (loc, (Error.E error))) - - let warn error loc = - Format.eprintf "Warning: %a: %a@." Loc.print loc Error.print - error - - let __ocaml_lex_tables = - { - Lexing.lex_base = - "\000\000\223\255\224\255\224\000\226\255\253\000\035\001\072\001\ - \109\001\146\001\091\000\183\001\068\000\190\001\218\001\227\255\ - \122\000\002\002\071\002\110\002\176\000\244\255\129\002\162\002\ - \235\002\187\003\154\004\246\004\124\000\001\000\255\255\198\005\ - \253\255\150\006\252\255\245\255\246\255\247\255\253\000\224\000\ - \086\000\091\000\054\003\006\004\029\002\237\001\182\004\109\000\ - \118\007\091\000\253\000\093\000\243\255\242\255\241\255\106\005\ - \077\003\108\000\087\003\017\006\151\007\218\007\001\008\068\008\ - \107\008\107\000\239\255\126\008\075\001\210\008\249\008\060\009\ - \232\255\231\255\230\255\099\009\166\009\205\009\016\010\055\010\ - \249\001\228\255\229\255\238\255\090\010\127\010\164\010\201\010\ - \238\010\019\011\056\011\091\011\128\011\165\011\202\011\239\011\ - \020\012\057\012\094\012\011\007\136\005\004\000\233\255\008\000\ - \054\001\245\002\009\000\005\000\233\255\131\012\138\012\175\012\ - \212\012\249\012\000\013\037\013\068\013\096\013\133\013\138\013\ - \205\013\242\013\023\014\085\014\241\255\006\000\242\255\243\255\ - \148\002\251\255\047\015\123\000\109\000\125\000\255\255\254\255\ - \253\255\111\015\046\016\254\016\206\017\174\018\129\000\017\001\ - \130\000\141\000\249\255\248\255\247\255\237\006\109\003\143\000\ - \246\255\035\004\145\000\245\255\160\014\149\000\244\255\086\004\ - \247\255\248\255\007\000\249\255\201\018\255\255\250\255\121\016\ - \154\004\253\255\091\001\057\001\171\004\252\255\073\017\251\255\ - \240\018\051\019\018\020\048\020\255\255\015\021\238\021\015\022\ - \079\022\255\255\031\023\254\255\164\001\251\255\010\000\252\255\ - \253\255\128\000\079\001\255\255\095\023\030\024\238\024\190\025\ - \254\255\190\026\253\255\254\255\153\001\143\027\110\028\255\255\ - \167\001\062\029\206\001\251\255\080\001\013\000\253\255\254\255\ - \255\255\252\255\126\029\061\030\013\031\221\031"; - Lexing.lex_backtrk = - "\255\255\255\255\255\255\030\000\255\255\028\000\030\000\030\000\ - \030\000\030\000\028\000\028\000\028\000\028\000\028\000\255\255\ - \028\000\030\000\030\000\028\000\028\000\255\255\006\000\006\000\ - \005\000\004\000\030\000\030\000\001\000\000\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\007\000\ - \255\255\255\255\255\255\006\000\006\000\006\000\007\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\014\000\ - \014\000\014\000\255\255\255\255\255\255\255\255\255\255\028\000\ - \028\000\015\000\255\255\028\000\255\255\255\255\028\000\255\255\ - \255\255\255\255\255\255\028\000\028\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\030\000\021\000\020\000\ - \018\000\030\000\018\000\018\000\018\000\018\000\028\000\018\000\ - \255\255\019\000\030\000\255\255\255\255\022\000\255\255\255\255\ - \255\255\255\255\255\255\022\000\255\255\255\255\255\255\255\255\ - \028\000\255\255\028\000\255\255\028\000\028\000\028\000\028\000\ - \030\000\030\000\030\000\255\255\255\255\013\000\255\255\255\255\ - \014\000\255\255\003\000\014\000\014\000\014\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\005\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\006\000\255\255\008\000\255\255\255\255\005\000\ - \005\000\255\255\001\000\001\000\255\255\255\255\255\255\255\255\ - \000\000\001\000\001\000\255\255\255\255\002\000\002\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\003\000\255\255\ - \255\255\004\000\004\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\002\000\002\000\002\000\255\255\ - \255\255\255\255\255\255\255\255\004\000\002\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255"; - Lexing.lex_default = - "\001\000\000\000\000\000\255\255\000\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\000\000\ - \255\255\255\255\255\255\255\255\049\000\000\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\000\000\255\255\ - \000\000\255\255\000\000\000\000\000\000\000\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \054\000\255\255\255\255\255\255\000\000\000\000\000\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\000\000\255\255\255\255\255\255\255\255\255\255\ - \000\000\000\000\000\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\000\000\000\000\000\000\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\103\000\255\255\255\255\000\000\103\000\ - \104\000\103\000\106\000\255\255\000\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\124\000\000\000\255\255\000\000\000\000\ - \142\000\000\000\255\255\255\255\255\255\255\255\000\000\000\000\ - \000\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\000\000\000\000\000\000\255\255\255\255\255\255\ - \000\000\255\255\255\255\000\000\255\255\255\255\000\000\160\000\ - \000\000\000\000\255\255\000\000\166\000\000\000\000\000\255\255\ - \255\255\000\000\255\255\255\255\255\255\000\000\255\255\000\000\ - \255\255\255\255\255\255\255\255\000\000\255\255\255\255\255\255\ - \255\255\000\000\255\255\000\000\189\000\000\000\255\255\000\000\ - \000\000\255\255\255\255\000\000\255\255\255\255\255\255\255\255\ - \000\000\205\000\000\000\000\000\255\255\255\255\255\255\000\000\ - \255\255\255\255\211\000\000\000\255\255\255\255\000\000\000\000\ - \000\000\000\000\255\255\255\255\255\255\255\255"; - Lexing.lex_trans = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\028\000\030\000\030\000\028\000\029\000\102\000\108\000\ - \126\000\163\000\102\000\108\000\191\000\101\000\107\000\214\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \028\000\003\000\021\000\016\000\004\000\009\000\009\000\020\000\ - \019\000\005\000\018\000\003\000\015\000\003\000\014\000\009\000\ - \023\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ - \022\000\022\000\013\000\012\000\017\000\006\000\007\000\026\000\ - \009\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\011\000\003\000\005\000\009\000\025\000\ - \015\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\010\000\008\000\005\000\027\000\015\000\ - \117\000\117\000\053\000\100\000\052\000\028\000\045\000\045\000\ - \028\000\115\000\117\000\044\000\044\000\044\000\044\000\044\000\ - \044\000\044\000\044\000\053\000\066\000\118\000\135\000\116\000\ - \115\000\115\000\100\000\117\000\028\000\046\000\046\000\046\000\ - \046\000\046\000\046\000\046\000\046\000\046\000\046\000\134\000\ - \148\000\147\000\099\000\099\000\099\000\099\000\099\000\099\000\ - \099\000\099\000\099\000\099\000\146\000\138\000\152\000\136\000\ - \155\000\117\000\051\000\137\000\158\000\050\000\200\000\000\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\118\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\000\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \002\000\003\000\000\000\000\000\003\000\003\000\003\000\051\000\ - \255\255\255\255\003\000\003\000\048\000\003\000\003\000\003\000\ - \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ - \039\000\039\000\003\000\144\000\003\000\003\000\003\000\003\000\ - \003\000\000\000\096\000\096\000\052\000\038\000\084\000\000\000\ - \047\000\000\000\047\000\084\000\096\000\046\000\046\000\046\000\ - \046\000\046\000\046\000\046\000\046\000\046\000\046\000\084\000\ - \147\000\084\000\084\000\084\000\003\000\096\000\003\000\039\000\ - \102\000\000\000\171\000\101\000\003\000\038\000\000\000\003\000\ - \009\000\009\000\000\000\000\000\084\000\003\000\003\000\000\000\ - \003\000\006\000\009\000\000\000\068\000\000\000\000\000\068\000\ - \106\000\171\000\084\000\096\000\003\000\085\000\003\000\006\000\ - \006\000\006\000\003\000\009\000\171\000\171\000\000\000\000\000\ - \000\000\003\000\000\000\068\000\003\000\121\000\121\000\000\000\ - \000\000\084\000\003\000\003\000\074\000\003\000\007\000\121\000\ - \000\000\084\000\084\000\171\000\000\000\000\000\000\000\003\000\ - \084\000\009\000\120\000\000\000\007\000\007\000\007\000\003\000\ - \121\000\197\000\219\000\195\000\217\000\000\000\003\000\196\000\ - \218\000\003\000\009\000\009\000\000\000\000\000\005\000\003\000\ - \003\000\000\000\003\000\006\000\009\000\000\000\000\000\085\000\ - \084\000\003\000\000\000\000\000\003\000\005\000\121\000\085\000\ - \000\000\006\000\006\000\006\000\003\000\009\000\191\000\000\000\ - \255\255\190\000\000\000\003\000\000\000\000\000\003\000\009\000\ - \009\000\000\000\208\000\094\000\003\000\003\000\000\000\003\000\ - \009\000\009\000\000\000\000\000\120\000\005\000\003\000\208\000\ - \208\000\003\000\005\000\009\000\098\000\000\000\009\000\009\000\ - \009\000\003\000\009\000\203\000\000\000\208\000\000\000\000\000\ - \214\000\000\000\000\000\213\000\117\000\117\000\000\000\000\000\ - \194\000\203\000\193\000\111\000\111\000\115\000\117\000\005\000\ - \000\000\085\000\005\000\003\000\109\000\111\000\003\000\094\000\ - \009\000\116\000\216\000\116\000\115\000\115\000\000\000\117\000\ - \114\000\000\000\109\000\112\000\112\000\000\000\111\000\111\000\ - \111\000\000\000\080\000\084\000\000\000\080\000\000\000\000\000\ - \112\000\111\000\212\000\000\000\000\000\000\000\098\000\094\000\ - \003\000\000\000\000\000\000\000\110\000\117\000\109\000\109\000\ - \109\000\080\000\111\000\005\000\111\000\045\000\045\000\000\000\ - \000\000\000\000\081\000\003\000\000\000\000\000\003\000\009\000\ - \009\000\000\000\000\000\084\000\003\000\003\000\000\000\003\000\ - \006\000\009\000\000\000\116\000\000\000\000\000\255\255\084\000\ - \111\000\036\000\110\000\005\000\086\000\000\000\088\000\006\000\ - \006\000\003\000\087\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\045\000\044\000\044\000\044\000\ - \044\000\044\000\044\000\044\000\044\000\000\000\110\000\084\000\ - \000\000\037\000\000\000\035\000\000\000\000\000\003\000\084\000\ - \009\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \003\000\036\000\000\000\003\000\003\000\003\000\000\000\000\000\ - \083\000\003\000\003\000\000\000\003\000\003\000\003\000\060\000\ - \000\000\000\000\060\000\000\000\044\000\000\000\085\000\084\000\ - \003\000\003\000\000\000\003\000\003\000\003\000\003\000\003\000\ - \000\000\037\000\000\000\035\000\000\000\000\000\060\000\061\000\ - \000\000\000\000\061\000\064\000\064\000\000\000\000\000\000\000\ - \065\000\061\000\000\000\061\000\062\000\064\000\144\000\000\000\ - \000\000\143\000\000\000\003\000\192\000\003\000\000\000\000\000\ - \063\000\000\000\062\000\062\000\062\000\061\000\064\000\039\000\ - \000\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ - \022\000\022\000\022\000\145\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\003\000\000\000\003\000\038\000\000\000\ - \000\000\000\000\061\000\000\000\064\000\036\000\215\000\000\000\ - \039\000\000\000\022\000\022\000\022\000\022\000\022\000\022\000\ - \022\000\022\000\022\000\022\000\000\000\000\000\000\000\000\000\ - \022\000\000\000\000\000\000\000\040\000\000\000\038\000\038\000\ - \000\000\000\000\063\000\000\000\061\000\037\000\036\000\035\000\ - \141\000\041\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\042\000\000\000\000\000\000\000\105\000\102\000\ - \000\000\022\000\101\000\000\000\040\000\000\000\000\000\038\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\037\000\000\000\ - \035\000\041\000\024\000\000\000\000\000\105\000\000\000\104\000\ - \000\000\000\000\042\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\000\000\000\000\ - \000\000\000\000\024\000\000\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\043\000\043\000\ - \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\043\000\ - \043\000\043\000\043\000\043\000\043\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\049\000\ - \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ - \049\000\000\000\000\000\000\000\255\255\000\000\000\000\043\000\ - \043\000\043\000\043\000\043\000\043\000\153\000\153\000\153\000\ - \153\000\153\000\153\000\153\000\153\000\153\000\153\000\000\000\ - \000\000\000\000\000\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\000\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\025\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\255\255\000\000\000\000\ - \000\000\000\000\000\000\000\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\000\000\000\000\ - \000\000\000\000\025\000\000\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\043\000\043\000\ - \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\043\000\ - \043\000\043\000\043\000\043\000\043\000\000\000\000\000\000\000\ - \000\000\000\000\036\000\154\000\154\000\154\000\154\000\154\000\ - \154\000\154\000\154\000\154\000\154\000\000\000\000\000\000\000\ - \163\000\000\000\000\000\162\000\000\000\043\000\000\000\043\000\ - \043\000\043\000\043\000\043\000\043\000\000\000\000\000\000\000\ - \000\000\000\000\037\000\000\000\035\000\000\000\000\000\000\000\ - \165\000\000\000\000\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\000\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\164\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\003\000\000\000\000\000\003\000\003\000\ - \003\000\000\000\000\000\000\000\003\000\003\000\000\000\003\000\ - \003\000\003\000\172\000\172\000\172\000\172\000\172\000\172\000\ - \172\000\172\000\172\000\172\000\003\000\000\000\003\000\003\000\ - \003\000\003\000\003\000\173\000\173\000\173\000\173\000\173\000\ - \173\000\173\000\173\000\173\000\173\000\000\000\046\000\046\000\ - \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\003\000\000\000\ - \003\000\033\000\000\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\046\000\003\000\003\000\ - \003\000\000\000\003\000\003\000\003\000\000\000\000\000\000\000\ - \003\000\003\000\000\000\003\000\003\000\003\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \003\000\000\000\003\000\003\000\003\000\003\000\003\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\003\000\000\000\003\000\031\000\161\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\000\000\003\000\000\000\003\000\000\000\000\000\000\000\ - \000\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\100\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\059\000\059\000\059\000\059\000\059\000\059\000\ - \059\000\059\000\059\000\059\000\000\000\000\000\000\000\000\000\ - \100\000\000\000\000\000\059\000\059\000\059\000\059\000\059\000\ - \059\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \099\000\099\000\099\000\099\000\099\000\099\000\099\000\099\000\ - \099\000\099\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\059\000\059\000\059\000\059\000\059\000\ - \059\000\000\000\000\000\000\000\000\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \032\000\000\000\000\000\000\000\000\000\000\000\000\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\000\000\000\000\000\000\000\000\031\000\000\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ - \049\000\049\000\049\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\049\000\049\000\049\000\049\000\049\000\049\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\049\000\049\000\049\000\049\000\049\000\049\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\000\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\033\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \034\000\000\000\000\000\000\000\000\000\000\000\000\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\000\000\000\000\000\000\000\000\033\000\000\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\000\000\000\000\000\000\105\000\102\000\000\000\000\000\ - \101\000\000\000\000\000\000\000\000\000\156\000\156\000\156\000\ - \156\000\156\000\156\000\156\000\156\000\156\000\156\000\000\000\ - \000\000\000\000\000\000\105\000\000\000\104\000\156\000\156\000\ - \156\000\156\000\156\000\156\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\099\000\099\000\099\000\099\000\099\000\ - \099\000\099\000\099\000\099\000\099\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\156\000\156\000\ - \156\000\156\000\156\000\156\000\000\000\000\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\000\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\000\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\057\000\000\000\ - \057\000\000\000\000\000\000\000\000\000\057\000\000\000\000\000\ - \060\000\000\000\000\000\060\000\000\000\000\000\056\000\056\000\ - \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\060\000\ - \078\000\000\000\000\000\078\000\078\000\078\000\000\000\000\000\ - \000\000\079\000\078\000\000\000\078\000\078\000\078\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\078\000\057\000\078\000\078\000\078\000\078\000\078\000\ - \057\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\068\000\057\000\000\000\068\000\000\000\ - \057\000\000\000\057\000\000\000\000\000\000\000\055\000\000\000\ - \000\000\000\000\000\000\078\000\000\000\078\000\000\000\000\000\ - \000\000\000\000\068\000\069\000\000\000\000\000\069\000\069\000\ - \069\000\000\000\000\000\072\000\071\000\069\000\000\000\069\000\ - \069\000\069\000\068\000\255\255\000\000\068\000\000\000\000\000\ - \000\000\000\000\000\000\078\000\069\000\078\000\069\000\069\000\ - \069\000\069\000\069\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\068\000\069\000\000\000\000\000\069\000\070\000\070\000\ - \000\000\000\000\072\000\071\000\069\000\000\000\069\000\077\000\ - \070\000\000\000\000\000\000\000\000\000\000\000\069\000\000\000\ - \069\000\000\000\000\000\077\000\000\000\077\000\077\000\077\000\ - \069\000\070\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\068\000\000\000\000\000\ - \068\000\000\000\000\000\000\000\000\000\000\000\069\000\000\000\ - \069\000\000\000\000\000\000\000\000\000\069\000\000\000\070\000\ - \000\000\000\000\000\000\000\000\068\000\069\000\000\000\000\000\ - \069\000\076\000\076\000\000\000\000\000\072\000\071\000\069\000\ - \000\000\069\000\075\000\076\000\068\000\000\000\255\255\068\000\ - \000\000\000\000\000\000\000\000\000\000\077\000\075\000\069\000\ - \075\000\075\000\075\000\069\000\076\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\068\000\069\000\000\000\000\000\069\000\ - \070\000\070\000\000\000\067\000\072\000\071\000\069\000\000\000\ - \069\000\070\000\070\000\000\000\000\000\000\000\000\000\000\000\ - \069\000\000\000\076\000\067\000\067\000\070\000\067\000\070\000\ - \070\000\070\000\069\000\070\000\067\000\067\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \067\000\000\000\067\000\067\000\067\000\000\000\067\000\000\000\ - \075\000\000\000\069\000\000\000\000\000\000\000\067\000\069\000\ - \000\000\070\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\067\000\000\000\068\000\067\000\000\000\068\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\067\000\070\000\ - \000\000\069\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\068\000\069\000\000\000\000\000\069\000\069\000\ - \069\000\067\000\067\000\073\000\071\000\069\000\000\000\069\000\ - \069\000\069\000\068\000\000\000\000\000\068\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\069\000\000\000\069\000\069\000\ - \069\000\069\000\069\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\068\000\069\000\000\000\000\000\069\000\070\000\070\000\ - \000\000\067\000\073\000\071\000\069\000\000\000\069\000\070\000\ - \070\000\000\000\000\000\000\000\000\000\000\000\069\000\000\000\ - \069\000\000\000\000\000\070\000\000\000\070\000\070\000\070\000\ - \069\000\070\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\068\000\000\000\000\000\ - \068\000\000\000\000\000\000\000\000\000\000\000\069\000\000\000\ - \069\000\000\000\000\000\000\000\067\000\069\000\000\000\070\000\ - \000\000\000\000\000\000\000\000\068\000\069\000\000\000\000\000\ - \069\000\069\000\069\000\000\000\000\000\000\000\071\000\069\000\ - \000\000\069\000\069\000\069\000\068\000\000\000\000\000\068\000\ - \000\000\000\000\000\000\000\000\067\000\070\000\069\000\069\000\ - \069\000\069\000\069\000\069\000\069\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\068\000\069\000\000\000\000\000\069\000\ - \076\000\076\000\000\000\000\000\073\000\071\000\069\000\000\000\ - \069\000\075\000\076\000\000\000\000\000\000\000\000\000\000\000\ - \069\000\000\000\069\000\000\000\000\000\075\000\000\000\075\000\ - \075\000\075\000\069\000\076\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\068\000\ - \000\000\000\000\068\000\000\000\000\000\000\000\000\000\000\000\ - \069\000\000\000\069\000\000\000\000\000\000\000\000\000\069\000\ - \000\000\076\000\000\000\000\000\000\000\000\000\068\000\069\000\ - \000\000\000\000\069\000\076\000\076\000\000\000\067\000\073\000\ - \071\000\069\000\000\000\069\000\076\000\076\000\068\000\000\000\ - \000\000\068\000\000\000\000\000\000\000\000\000\000\000\075\000\ - \076\000\069\000\076\000\076\000\076\000\069\000\076\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\068\000\069\000\000\000\ - \000\000\069\000\070\000\070\000\000\000\000\000\073\000\071\000\ - \069\000\000\000\069\000\077\000\070\000\000\000\000\000\000\000\ - \000\000\067\000\069\000\000\000\076\000\000\000\000\000\077\000\ - \000\000\077\000\077\000\077\000\069\000\070\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\080\000\000\000\000\000\080\000\000\000\000\000\000\000\ - \000\000\067\000\076\000\000\000\069\000\000\000\000\000\000\000\ - \000\000\069\000\000\000\070\000\000\000\000\000\000\000\000\000\ - \080\000\078\000\000\000\000\000\078\000\078\000\078\000\000\000\ - \000\000\082\000\079\000\078\000\000\000\078\000\078\000\078\000\ - \080\000\000\000\000\000\080\000\000\000\000\000\000\000\000\000\ - \000\000\077\000\078\000\069\000\078\000\078\000\078\000\078\000\ - \078\000\000\000\000\000\000\000\000\000\000\000\000\000\080\000\ - \078\000\000\000\000\000\078\000\078\000\078\000\000\000\000\000\ - \000\000\079\000\078\000\000\000\078\000\078\000\078\000\000\000\ - \000\000\000\000\000\000\000\000\078\000\000\000\078\000\000\000\ - \000\000\078\000\000\000\078\000\078\000\078\000\078\000\078\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\096\000\ - \096\000\000\000\000\000\084\000\000\000\000\000\000\000\000\000\ - \084\000\096\000\000\000\000\000\078\000\000\000\078\000\000\000\ - \000\000\000\000\000\000\078\000\084\000\078\000\084\000\084\000\ - \084\000\000\000\096\000\000\000\000\000\000\000\000\000\000\000\ - \003\000\000\000\000\000\003\000\009\000\009\000\000\000\000\000\ - \005\000\003\000\003\000\000\000\003\000\006\000\009\000\000\000\ - \000\000\000\000\000\000\078\000\000\000\078\000\000\000\084\000\ - \096\000\085\000\000\000\006\000\006\000\006\000\003\000\009\000\ - \000\000\000\000\000\000\000\000\000\000\003\000\000\000\000\000\ - \003\000\009\000\009\000\000\000\000\000\005\000\003\000\003\000\ - \000\000\003\000\006\000\009\000\000\000\000\000\084\000\084\000\ - \000\000\000\000\000\000\003\000\084\000\009\000\085\000\000\000\ - \006\000\006\000\006\000\003\000\009\000\000\000\000\000\000\000\ - \000\000\000\000\003\000\000\000\000\000\003\000\009\000\009\000\ - \000\000\000\000\094\000\003\000\003\000\000\000\003\000\009\000\ - \009\000\000\000\000\000\085\000\005\000\003\000\000\000\000\000\ - \003\000\084\000\009\000\098\000\000\000\009\000\009\000\009\000\ - \003\000\009\000\000\000\000\000\000\000\000\000\000\000\090\000\ - \000\000\000\000\003\000\093\000\093\000\000\000\000\000\084\000\ - \090\000\090\000\000\000\090\000\091\000\093\000\000\000\000\000\ - \085\000\005\000\003\000\000\000\000\000\003\000\094\000\009\000\ - \092\000\000\000\006\000\091\000\089\000\090\000\093\000\000\000\ - \000\000\000\000\000\000\000\000\003\000\000\000\000\000\003\000\ - \009\000\009\000\000\000\000\000\084\000\003\000\003\000\000\000\ - \003\000\006\000\009\000\000\000\000\000\098\000\094\000\003\000\ - \000\000\000\000\090\000\084\000\093\000\085\000\000\000\006\000\ - \006\000\097\000\003\000\009\000\000\000\000\000\000\000\000\000\ - \000\000\090\000\000\000\000\000\003\000\090\000\090\000\000\000\ - \000\000\000\000\090\000\090\000\000\000\090\000\090\000\090\000\ - \000\000\000\000\092\000\084\000\090\000\000\000\000\000\003\000\ - \084\000\009\000\090\000\000\000\003\000\090\000\003\000\090\000\ - \090\000\000\000\000\000\000\000\090\000\000\000\000\000\003\000\ - \093\000\093\000\000\000\000\000\084\000\090\000\090\000\000\000\ - \090\000\091\000\093\000\000\000\000\000\000\000\000\000\085\000\ - \084\000\003\000\000\000\000\000\090\000\092\000\090\000\006\000\ - \091\000\006\000\090\000\093\000\000\000\000\000\000\000\000\000\ - \000\000\090\000\000\000\000\000\003\000\093\000\093\000\000\000\ - \000\000\005\000\090\000\090\000\000\000\090\000\091\000\093\000\ - \000\000\000\000\000\000\000\000\090\000\000\000\090\000\090\000\ - \084\000\093\000\092\000\000\000\006\000\091\000\006\000\090\000\ - \093\000\000\000\000\000\000\000\000\000\000\000\090\000\000\000\ - \000\000\003\000\093\000\093\000\000\000\000\000\094\000\090\000\ - \090\000\000\000\090\000\093\000\093\000\000\000\000\000\092\000\ - \084\000\090\000\000\000\000\000\090\000\084\000\093\000\095\000\ - \000\000\009\000\093\000\009\000\090\000\093\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\096\000\ - \096\000\000\000\000\000\094\000\000\000\000\000\000\000\000\000\ - \096\000\096\000\000\000\000\000\092\000\005\000\090\000\000\000\ - \000\000\090\000\094\000\093\000\096\000\000\000\096\000\096\000\ - \096\000\000\000\096\000\000\000\000\000\000\000\000\000\000\000\ - \090\000\000\000\000\000\003\000\093\000\093\000\000\000\000\000\ - \094\000\090\000\090\000\000\000\090\000\093\000\093\000\000\000\ - \000\000\095\000\094\000\090\000\000\000\000\000\000\000\094\000\ - \096\000\095\000\000\000\009\000\093\000\009\000\090\000\093\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\096\000\096\000\000\000\000\000\094\000\000\000\000\000\ - \000\000\000\000\096\000\096\000\000\000\000\000\096\000\094\000\ - \000\000\000\000\000\000\090\000\094\000\093\000\096\000\000\000\ - \096\000\096\000\096\000\000\000\096\000\000\000\000\000\000\000\ - \000\000\000\000\003\000\000\000\000\000\003\000\009\000\009\000\ - \000\000\000\000\084\000\003\000\003\000\000\000\003\000\006\000\ - \009\000\000\000\000\000\095\000\094\000\090\000\000\000\000\000\ - \000\000\094\000\096\000\085\000\000\000\006\000\006\000\006\000\ - \003\000\009\000\000\000\000\000\000\000\000\000\000\000\003\000\ - \000\000\000\000\003\000\009\000\009\000\000\000\000\000\094\000\ - \003\000\003\000\000\000\003\000\009\000\009\000\000\000\000\000\ - \096\000\094\000\000\000\000\000\000\000\003\000\084\000\009\000\ - \098\000\000\000\009\000\009\000\009\000\003\000\009\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \111\000\111\000\000\000\000\000\084\000\000\000\000\000\111\000\ - \111\000\109\000\111\000\005\000\000\000\085\000\084\000\003\000\ - \109\000\111\000\003\000\094\000\009\000\110\000\000\000\109\000\ - \109\000\109\000\000\000\111\000\110\000\000\000\109\000\109\000\ - \109\000\000\000\111\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\111\000\111\000\000\000\000\000\ - \094\000\000\000\098\000\094\000\003\000\111\000\111\000\000\000\ - \084\000\111\000\000\000\000\000\000\000\000\000\000\000\084\000\ - \111\000\113\000\000\000\111\000\111\000\111\000\000\000\111\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\111\000\111\000\000\000\000\000\084\000\000\000\110\000\ - \084\000\000\000\109\000\111\000\000\000\000\000\110\000\005\000\ - \000\000\000\000\000\000\000\000\094\000\111\000\110\000\000\000\ - \109\000\109\000\109\000\000\000\111\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\111\000\111\000\ - \000\000\000\000\094\000\000\000\000\000\111\000\111\000\111\000\ - \111\000\005\000\000\000\113\000\094\000\000\000\109\000\111\000\ - \000\000\084\000\111\000\113\000\000\000\111\000\111\000\111\000\ - \000\000\111\000\110\000\000\000\109\000\109\000\109\000\000\000\ - \111\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\117\000\117\000\000\000\000\000\000\000\000\000\ - \110\000\084\000\000\000\115\000\117\000\000\000\094\000\111\000\ - \000\000\000\000\000\000\000\000\000\000\084\000\111\000\115\000\ - \000\000\116\000\115\000\115\000\000\000\117\000\000\000\000\000\ - \000\000\117\000\117\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\115\000\117\000\000\000\113\000\094\000\000\000\ - \000\000\000\000\000\000\000\000\110\000\005\000\115\000\000\000\ - \116\000\115\000\115\000\117\000\117\000\117\000\117\000\000\000\ - \067\000\000\000\000\000\000\000\000\000\000\000\117\000\117\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\117\000\000\000\117\000\117\000\117\000\000\000\ - \117\000\115\000\117\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\119\000\119\000\000\000\000\000\000\000\119\000\ - \119\000\000\000\067\000\118\000\119\000\000\000\000\000\000\000\ - \119\000\119\000\000\000\067\000\000\000\000\000\117\000\118\000\ - \115\000\118\000\118\000\118\000\119\000\119\000\119\000\119\000\ - \119\000\000\000\119\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\067\000\117\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\119\000\000\000\067\000\000\000\000\000\ - \119\000\000\000\000\000\000\000\000\000\000\000\003\000\000\000\ - \000\000\003\000\121\000\121\000\000\000\000\000\005\000\003\000\ - \003\000\000\000\003\000\007\000\121\000\000\000\000\000\000\000\ - \000\000\118\000\000\000\000\000\000\000\067\000\119\000\120\000\ - \000\000\007\000\007\000\007\000\003\000\121\000\000\000\000\000\ - \000\000\000\000\000\000\003\000\000\000\000\000\003\000\121\000\ - \121\000\000\000\000\000\094\000\003\000\003\000\000\000\003\000\ - \121\000\121\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\003\000\005\000\121\000\122\000\000\000\121\000\121\000\ - \121\000\003\000\121\000\000\000\000\000\000\000\000\000\000\000\ - \003\000\000\000\000\000\003\000\121\000\121\000\000\000\000\000\ - \094\000\003\000\003\000\000\000\003\000\121\000\121\000\000\000\ - \000\000\120\000\005\000\003\000\000\000\000\000\003\000\094\000\ - \121\000\122\000\000\000\121\000\121\000\121\000\003\000\121\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\126\000\ - \000\000\000\000\125\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\122\000\094\000\ - \003\000\000\000\000\000\003\000\094\000\121\000\000\000\129\000\ - \000\000\000\000\000\000\000\000\128\000\133\000\000\000\132\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\131\000\000\000\122\000\094\000\003\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \000\000\000\000\000\000\000\000\130\000\000\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \157\000\157\000\157\000\157\000\157\000\157\000\157\000\157\000\ - \157\000\157\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\157\000\157\000\157\000\157\000\157\000\157\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\157\000\157\000\157\000\157\000\157\000\157\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\000\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\000\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\127\000\130\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\000\000\000\000\000\000\000\000\130\000\000\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\000\000\000\000\000\000\000\000\140\000\000\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\000\000\000\000\000\000\000\000\000\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\000\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\000\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\000\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\000\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\000\000\000\000\000\000\000\000\139\000\000\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \174\000\174\000\174\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\000\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \000\000\000\000\136\000\000\000\000\000\000\000\137\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\000\000\000\000\000\000\000\000\139\000\000\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\175\000\175\000\175\000\175\000\175\000\175\000\175\000\ - \175\000\175\000\175\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\175\000\175\000\175\000\175\000\175\000\175\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\175\000\175\000\175\000\175\000\175\000\175\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\000\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\140\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \000\000\000\000\136\000\000\000\000\000\000\000\000\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\000\000\000\000\000\000\000\000\140\000\000\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\000\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\000\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\151\000\000\000\ - \151\000\000\000\000\000\171\000\000\000\151\000\170\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\150\000\150\000\ - \150\000\150\000\150\000\150\000\150\000\150\000\150\000\150\000\ - \000\000\169\000\000\000\169\000\000\000\000\000\000\000\000\000\ - \169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\151\000\000\000\000\000\000\000\000\000\000\000\ - \151\000\176\000\000\000\000\000\176\000\176\000\176\000\000\000\ - \000\000\000\000\176\000\176\000\151\000\176\000\176\000\176\000\ - \151\000\000\000\151\000\000\000\000\000\169\000\149\000\000\000\ - \000\000\000\000\176\000\169\000\176\000\176\000\176\000\176\000\ - \176\000\000\000\000\000\000\000\000\000\000\000\000\000\169\000\ - \000\000\000\000\000\000\169\000\000\000\169\000\000\000\000\000\ - \000\000\167\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\176\000\000\000\176\000\000\000\ - \000\000\000\000\000\000\000\000\178\000\000\000\000\000\178\000\ - \178\000\178\000\000\000\000\000\000\000\178\000\178\000\000\000\ - \178\000\178\000\178\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\176\000\178\000\176\000\178\000\ - \178\000\178\000\178\000\178\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\000\000\178\000\ - \000\000\178\000\179\000\000\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\000\000\178\000\ - \000\000\178\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\255\255\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\000\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\000\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\178\000\000\000\000\000\178\000\178\000\ - \178\000\000\000\000\000\000\000\178\000\178\000\000\000\178\000\ - \178\000\178\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\178\000\000\000\178\000\178\000\ - \178\000\178\000\178\000\000\000\000\000\000\000\000\000\179\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\000\000\000\000\180\000\000\000\178\000\000\000\ - \178\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\000\000\000\000\000\000\178\000\179\000\ - \178\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\000\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\000\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \182\000\000\000\000\000\182\000\182\000\182\000\000\000\000\000\ - \000\000\182\000\182\000\000\000\182\000\182\000\182\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\182\000\000\000\182\000\182\000\182\000\182\000\182\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\000\000\182\000\000\000\182\000\183\000\000\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\000\000\182\000\000\000\182\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\000\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\000\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\182\000\ - \000\000\000\000\182\000\182\000\182\000\000\000\000\000\000\000\ - \182\000\182\000\000\000\182\000\182\000\182\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \182\000\000\000\182\000\182\000\182\000\182\000\182\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\183\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\000\000\182\000\185\000\182\000\000\000\000\000\184\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\182\000\000\000\182\000\000\000\183\000\000\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\000\000\000\000\000\000\000\000\186\000\000\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\000\000\000\000\000\000\000\000\000\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\000\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\000\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\000\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\000\000\000\000\187\000\000\000\000\000\000\000\000\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\000\000\000\000\000\000\000\000\186\000\000\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\000\000\000\000\000\000\000\000\199\000\000\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\000\000\000\000\000\000\000\000\000\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\000\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\000\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\000\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\000\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\000\000\000\000\000\000\000\000\198\000\000\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\000\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \000\000\000\000\195\000\000\000\000\000\000\000\196\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\000\000\000\000\000\000\000\000\198\000\000\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\000\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\199\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \000\000\000\000\195\000\000\000\000\000\000\000\000\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\000\000\000\000\000\000\000\000\199\000\000\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\000\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\000\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\204\000\ - \202\000\202\000\207\000\202\000\202\000\000\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\204\000\202\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \203\000\202\000\202\000\202\000\202\000\202\000\202\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\202\000\202\000\202\000\202\000\000\000\206\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\202\000\202\000\ - \202\000\202\000\202\000\202\000\202\000\202\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\202\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\202\000\209\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\255\255\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\203\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\000\000\000\000\000\000\000\000\209\000\000\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\000\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\000\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\208\000\ - \000\000\000\000\000\000\000\000\000\000\209\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\208\000\000\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \203\000\000\000\000\000\000\000\000\000\000\000\000\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\000\000\000\000\000\000\000\000\209\000\000\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\000\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \203\000\000\000\000\000\000\000\000\000\000\000\000\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\000\000\000\000\000\000\000\000\209\000\000\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\000\000\000\000\000\000\000\000\000\000\000\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\000\000\000\000\000\000\000\000\221\000\000\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\000\000\000\000\000\000\000\000\000\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\000\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\000\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\000\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\000\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \000\000\000\000\000\000\000\000\220\000\000\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\000\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\000\000\ - \000\000\217\000\000\000\000\000\000\000\218\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \000\000\000\000\000\000\000\000\220\000\000\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\000\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\221\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\000\000\ - \000\000\217\000\000\000\000\000\000\000\000\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \000\000\000\000\000\000\000\000\221\000\000\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\000\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\000\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\000\000"; - Lexing.lex_check = - "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\000\000\000\000\029\000\000\000\000\000\101\000\107\000\ - \125\000\162\000\103\000\106\000\190\000\103\000\106\000\213\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\000\ - \010\000\010\000\049\000\016\000\051\000\028\000\040\000\040\000\ - \028\000\010\000\010\000\041\000\041\000\041\000\041\000\041\000\ - \041\000\041\000\041\000\057\000\065\000\010\000\132\000\010\000\ - \010\000\010\000\016\000\010\000\028\000\047\000\047\000\047\000\ - \047\000\047\000\047\000\047\000\047\000\047\000\047\000\133\000\ - \142\000\144\000\016\000\016\000\016\000\016\000\016\000\016\000\ - \016\000\016\000\016\000\016\000\145\000\131\000\151\000\131\000\ - \154\000\010\000\020\000\131\000\157\000\020\000\193\000\255\255\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\010\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\255\255\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\003\000\255\255\255\255\003\000\003\000\003\000\050\000\ - \103\000\106\000\003\000\003\000\020\000\003\000\003\000\003\000\ - \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ - \039\000\039\000\003\000\143\000\003\000\003\000\003\000\003\000\ - \003\000\255\255\005\000\005\000\050\000\039\000\005\000\255\255\ - \038\000\255\255\038\000\005\000\005\000\038\000\038\000\038\000\ - \038\000\038\000\038\000\038\000\038\000\038\000\038\000\005\000\ - \143\000\005\000\005\000\005\000\003\000\005\000\003\000\039\000\ - \104\000\255\255\171\000\104\000\006\000\039\000\255\255\006\000\ - \006\000\006\000\255\255\255\255\006\000\006\000\006\000\255\255\ - \006\000\006\000\006\000\255\255\068\000\255\255\255\255\068\000\ - \104\000\171\000\005\000\005\000\003\000\006\000\003\000\006\000\ - \006\000\006\000\006\000\006\000\170\000\170\000\255\255\255\255\ - \255\255\007\000\255\255\068\000\007\000\007\000\007\000\255\255\ - \255\255\007\000\007\000\007\000\068\000\007\000\007\000\007\000\ - \255\255\005\000\005\000\170\000\255\255\255\255\255\255\006\000\ - \006\000\006\000\007\000\255\255\007\000\007\000\007\000\007\000\ - \007\000\194\000\212\000\194\000\212\000\255\255\008\000\194\000\ - \212\000\008\000\008\000\008\000\255\255\255\255\008\000\008\000\ - \008\000\255\255\008\000\008\000\008\000\255\255\255\255\006\000\ - \006\000\006\000\255\255\255\255\007\000\007\000\007\000\008\000\ - \255\255\008\000\008\000\008\000\008\000\008\000\188\000\255\255\ - \020\000\188\000\255\255\009\000\255\255\255\255\009\000\009\000\ - \009\000\255\255\204\000\009\000\009\000\009\000\255\255\009\000\ - \009\000\009\000\255\255\255\255\007\000\007\000\007\000\204\000\ - \208\000\008\000\008\000\008\000\009\000\255\255\009\000\009\000\ - \009\000\009\000\009\000\204\000\255\255\208\000\255\255\255\255\ - \210\000\255\255\255\255\210\000\011\000\011\000\255\255\255\255\ - \188\000\208\000\188\000\013\000\013\000\011\000\011\000\013\000\ - \255\255\008\000\008\000\008\000\013\000\013\000\009\000\009\000\ - \009\000\011\000\210\000\011\000\011\000\011\000\255\255\011\000\ - \013\000\255\255\013\000\013\000\013\000\255\255\013\000\014\000\ - \014\000\255\255\080\000\014\000\255\255\080\000\255\255\255\255\ - \014\000\014\000\210\000\255\255\255\255\255\255\009\000\009\000\ - \009\000\255\255\255\255\255\255\014\000\011\000\014\000\014\000\ - \014\000\080\000\014\000\013\000\013\000\045\000\045\000\255\255\ - \255\255\255\255\080\000\017\000\255\255\255\255\017\000\017\000\ - \017\000\255\255\255\255\017\000\017\000\017\000\255\255\017\000\ - \017\000\017\000\255\255\011\000\255\255\255\255\104\000\014\000\ - \014\000\045\000\013\000\013\000\017\000\255\255\017\000\017\000\ - \017\000\017\000\017\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\045\000\044\000\044\000\044\000\ - \044\000\044\000\044\000\044\000\044\000\255\255\014\000\014\000\ - \255\255\045\000\255\255\045\000\255\255\255\255\017\000\017\000\ - \017\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \018\000\044\000\255\255\018\000\018\000\018\000\255\255\255\255\ - \018\000\018\000\018\000\255\255\018\000\018\000\018\000\019\000\ - \255\255\255\255\019\000\255\255\044\000\255\255\017\000\017\000\ - \017\000\018\000\255\255\018\000\018\000\018\000\018\000\018\000\ - \255\255\044\000\255\255\044\000\255\255\255\255\019\000\019\000\ - \255\255\255\255\019\000\019\000\019\000\255\255\255\255\255\255\ - \019\000\019\000\255\255\019\000\019\000\019\000\128\000\255\255\ - \255\255\128\000\255\255\018\000\188\000\018\000\255\255\255\255\ - \019\000\255\255\019\000\019\000\019\000\019\000\019\000\022\000\ - \255\255\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ - \022\000\022\000\022\000\128\000\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\018\000\255\255\018\000\022\000\255\255\ - \255\255\255\255\019\000\255\255\019\000\022\000\210\000\255\255\ - \023\000\255\255\023\000\023\000\023\000\023\000\023\000\023\000\ - \023\000\023\000\023\000\023\000\255\255\255\255\255\255\255\255\ - \022\000\255\255\255\255\255\255\023\000\255\255\022\000\023\000\ - \255\255\255\255\019\000\255\255\019\000\022\000\023\000\022\000\ - \128\000\023\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\023\000\255\255\255\255\255\255\105\000\105\000\ - \255\255\023\000\105\000\255\255\023\000\255\255\255\255\023\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\023\000\255\255\ - \023\000\023\000\024\000\255\255\255\255\105\000\255\255\105\000\ - \255\255\255\255\023\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\255\255\255\255\ - \255\255\255\255\024\000\255\255\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\042\000\042\000\ - \042\000\042\000\042\000\042\000\042\000\042\000\042\000\042\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\042\000\ - \042\000\042\000\042\000\042\000\042\000\056\000\056\000\056\000\ - \056\000\056\000\056\000\056\000\056\000\056\000\056\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\255\255\255\255\255\255\128\000\255\255\255\255\042\000\ - \042\000\042\000\042\000\042\000\042\000\150\000\150\000\150\000\ - \150\000\150\000\150\000\150\000\150\000\150\000\150\000\255\255\ - \255\255\255\255\255\255\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\255\255\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\025\000\024\000\024\000\024\000\024\000\024\000\ - \024\000\024\000\024\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\105\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\255\255\255\255\ - \255\255\255\255\025\000\255\255\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\043\000\043\000\ - \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\043\000\ - \043\000\043\000\043\000\043\000\043\000\255\255\255\255\255\255\ - \255\255\255\255\043\000\153\000\153\000\153\000\153\000\153\000\ - \153\000\153\000\153\000\153\000\153\000\255\255\255\255\255\255\ - \159\000\255\255\255\255\159\000\255\255\043\000\255\255\043\000\ - \043\000\043\000\043\000\043\000\043\000\255\255\255\255\255\255\ - \255\255\255\255\043\000\255\255\043\000\255\255\255\255\255\255\ - \159\000\255\255\255\255\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\255\255\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\159\000\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\025\000\026\000\255\255\255\255\026\000\026\000\ - \026\000\255\255\255\255\255\255\026\000\026\000\255\255\026\000\ - \026\000\026\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\026\000\255\255\026\000\026\000\ - \026\000\026\000\026\000\172\000\172\000\172\000\172\000\172\000\ - \172\000\172\000\172\000\172\000\172\000\255\255\046\000\046\000\ - \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\026\000\255\255\ - \026\000\026\000\255\255\026\000\026\000\026\000\026\000\026\000\ - \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ - \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ - \026\000\026\000\026\000\026\000\026\000\046\000\026\000\027\000\ - \026\000\255\255\027\000\027\000\027\000\255\255\255\255\255\255\ - \027\000\027\000\255\255\027\000\027\000\027\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \027\000\255\255\027\000\027\000\027\000\027\000\027\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\027\000\255\255\027\000\027\000\159\000\027\000\ - \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ - \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ - \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ - \027\000\255\255\027\000\255\255\027\000\255\255\255\255\255\255\ - \255\255\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ - \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ - \026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\ - \026\000\100\000\026\000\026\000\026\000\026\000\026\000\026\000\ - \026\000\026\000\055\000\055\000\055\000\055\000\055\000\055\000\ - \055\000\055\000\055\000\055\000\255\255\255\255\255\255\255\255\ - \100\000\255\255\255\255\055\000\055\000\055\000\055\000\055\000\ - \055\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \100\000\100\000\100\000\100\000\100\000\100\000\100\000\100\000\ - \100\000\100\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\055\000\055\000\055\000\055\000\055\000\ - \055\000\255\255\255\255\255\255\255\255\027\000\027\000\027\000\ - \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ - \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ - \027\000\027\000\027\000\027\000\027\000\031\000\027\000\027\000\ - \027\000\027\000\027\000\027\000\027\000\027\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\255\255\255\255\255\255\255\255\255\255\255\255\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\255\255\255\255\255\255\255\255\031\000\255\255\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\059\000\059\000\059\000\059\000\059\000\059\000\059\000\ - \059\000\059\000\059\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\059\000\059\000\059\000\059\000\059\000\059\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\059\000\059\000\059\000\059\000\059\000\059\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\255\255\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\033\000\031\000\031\000\ - \031\000\031\000\031\000\031\000\031\000\031\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\255\255\255\255\255\255\255\255\255\255\255\255\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\255\255\255\255\255\255\255\255\033\000\255\255\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\255\255\255\255\255\255\099\000\099\000\255\255\255\255\ - \099\000\255\255\255\255\255\255\255\255\149\000\149\000\149\000\ - \149\000\149\000\149\000\149\000\149\000\149\000\149\000\255\255\ - \255\255\255\255\255\255\099\000\255\255\099\000\149\000\149\000\ - \149\000\149\000\149\000\149\000\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\099\000\099\000\099\000\099\000\099\000\ - \099\000\099\000\099\000\099\000\099\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\149\000\149\000\ - \149\000\149\000\149\000\149\000\255\255\255\255\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\255\255\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\255\255\033\000\033\000\ - \033\000\033\000\033\000\033\000\033\000\033\000\048\000\255\255\ - \048\000\255\255\255\255\255\255\255\255\048\000\255\255\255\255\ - \060\000\255\255\255\255\060\000\255\255\255\255\048\000\048\000\ - \048\000\048\000\048\000\048\000\048\000\048\000\048\000\048\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\060\000\ - \060\000\255\255\255\255\060\000\060\000\060\000\255\255\255\255\ - \255\255\060\000\060\000\255\255\060\000\060\000\060\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\060\000\048\000\060\000\060\000\060\000\060\000\060\000\ - \048\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\061\000\048\000\255\255\061\000\255\255\ - \048\000\255\255\048\000\255\255\255\255\255\255\048\000\255\255\ - \255\255\255\255\255\255\060\000\255\255\060\000\255\255\255\255\ - \255\255\255\255\061\000\061\000\255\255\255\255\061\000\061\000\ - \061\000\255\255\255\255\061\000\061\000\061\000\255\255\061\000\ - \061\000\061\000\062\000\099\000\255\255\062\000\255\255\255\255\ - \255\255\255\255\255\255\060\000\061\000\060\000\061\000\061\000\ - \061\000\061\000\061\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\062\000\062\000\255\255\255\255\062\000\062\000\062\000\ - \255\255\255\255\062\000\062\000\062\000\255\255\062\000\062\000\ - \062\000\255\255\255\255\255\255\255\255\255\255\061\000\255\255\ - \061\000\255\255\255\255\062\000\255\255\062\000\062\000\062\000\ - \062\000\062\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\063\000\255\255\255\255\ - \063\000\255\255\255\255\255\255\255\255\255\255\061\000\255\255\ - \061\000\255\255\255\255\255\255\255\255\062\000\255\255\062\000\ - \255\255\255\255\255\255\255\255\063\000\063\000\255\255\255\255\ - \063\000\063\000\063\000\255\255\255\255\063\000\063\000\063\000\ - \255\255\063\000\063\000\063\000\064\000\255\255\048\000\064\000\ - \255\255\255\255\255\255\255\255\255\255\062\000\063\000\062\000\ - \063\000\063\000\063\000\063\000\063\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\064\000\064\000\255\255\255\255\064\000\ - \064\000\064\000\255\255\064\000\064\000\064\000\064\000\255\255\ - \064\000\064\000\064\000\255\255\255\255\255\255\255\255\255\255\ - \063\000\255\255\063\000\067\000\067\000\064\000\067\000\064\000\ - \064\000\064\000\064\000\064\000\067\000\067\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \067\000\255\255\067\000\067\000\067\000\255\255\067\000\255\255\ - \063\000\255\255\063\000\255\255\255\255\255\255\064\000\064\000\ - \255\255\064\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\067\000\255\255\069\000\067\000\255\255\069\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\064\000\064\000\ - \255\255\064\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\069\000\069\000\255\255\255\255\069\000\069\000\ - \069\000\067\000\067\000\069\000\069\000\069\000\255\255\069\000\ - \069\000\069\000\070\000\255\255\255\255\070\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\069\000\255\255\069\000\069\000\ - \069\000\069\000\069\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\070\000\070\000\255\255\255\255\070\000\070\000\070\000\ - \255\255\070\000\070\000\070\000\070\000\255\255\070\000\070\000\ - \070\000\255\255\255\255\255\255\255\255\255\255\069\000\255\255\ - \069\000\255\255\255\255\070\000\255\255\070\000\070\000\070\000\ - \070\000\070\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\071\000\255\255\255\255\ - \071\000\255\255\255\255\255\255\255\255\255\255\069\000\255\255\ - \069\000\255\255\255\255\255\255\070\000\070\000\255\255\070\000\ - \255\255\255\255\255\255\255\255\071\000\071\000\255\255\255\255\ - \071\000\071\000\071\000\255\255\255\255\255\255\071\000\071\000\ - \255\255\071\000\071\000\071\000\075\000\255\255\255\255\075\000\ - \255\255\255\255\255\255\255\255\070\000\070\000\071\000\070\000\ - \071\000\071\000\071\000\071\000\071\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\075\000\075\000\255\255\255\255\075\000\ - \075\000\075\000\255\255\255\255\075\000\075\000\075\000\255\255\ - \075\000\075\000\075\000\255\255\255\255\255\255\255\255\255\255\ - \071\000\255\255\071\000\255\255\255\255\075\000\255\255\075\000\ - \075\000\075\000\075\000\075\000\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\076\000\ - \255\255\255\255\076\000\255\255\255\255\255\255\255\255\255\255\ - \071\000\255\255\071\000\255\255\255\255\255\255\255\255\075\000\ - \255\255\075\000\255\255\255\255\255\255\255\255\076\000\076\000\ - \255\255\255\255\076\000\076\000\076\000\255\255\076\000\076\000\ - \076\000\076\000\255\255\076\000\076\000\076\000\077\000\255\255\ - \255\255\077\000\255\255\255\255\255\255\255\255\255\255\075\000\ - \076\000\075\000\076\000\076\000\076\000\076\000\076\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\077\000\077\000\255\255\ - \255\255\077\000\077\000\077\000\255\255\255\255\077\000\077\000\ - \077\000\255\255\077\000\077\000\077\000\255\255\255\255\255\255\ - \255\255\076\000\076\000\255\255\076\000\255\255\255\255\077\000\ - \255\255\077\000\077\000\077\000\077\000\077\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\078\000\255\255\255\255\078\000\255\255\255\255\255\255\ - \255\255\076\000\076\000\255\255\076\000\255\255\255\255\255\255\ - \255\255\077\000\255\255\077\000\255\255\255\255\255\255\255\255\ - \078\000\078\000\255\255\255\255\078\000\078\000\078\000\255\255\ - \255\255\078\000\078\000\078\000\255\255\078\000\078\000\078\000\ - \079\000\255\255\255\255\079\000\255\255\255\255\255\255\255\255\ - \255\255\077\000\078\000\077\000\078\000\078\000\078\000\078\000\ - \078\000\255\255\255\255\255\255\255\255\255\255\255\255\079\000\ - \079\000\255\255\255\255\079\000\079\000\079\000\255\255\255\255\ - \255\255\079\000\079\000\255\255\079\000\079\000\079\000\255\255\ - \255\255\255\255\255\255\255\255\078\000\255\255\078\000\255\255\ - \255\255\079\000\255\255\079\000\079\000\079\000\079\000\079\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\084\000\ - \084\000\255\255\255\255\084\000\255\255\255\255\255\255\255\255\ - \084\000\084\000\255\255\255\255\078\000\255\255\078\000\255\255\ - \255\255\255\255\255\255\079\000\084\000\079\000\084\000\084\000\ - \084\000\255\255\084\000\255\255\255\255\255\255\255\255\255\255\ - \085\000\255\255\255\255\085\000\085\000\085\000\255\255\255\255\ - \085\000\085\000\085\000\255\255\085\000\085\000\085\000\255\255\ - \255\255\255\255\255\255\079\000\255\255\079\000\255\255\084\000\ - \084\000\085\000\255\255\085\000\085\000\085\000\085\000\085\000\ - \255\255\255\255\255\255\255\255\255\255\086\000\255\255\255\255\ - \086\000\086\000\086\000\255\255\255\255\086\000\086\000\086\000\ - \255\255\086\000\086\000\086\000\255\255\255\255\084\000\084\000\ - \255\255\255\255\255\255\085\000\085\000\085\000\086\000\255\255\ - \086\000\086\000\086\000\086\000\086\000\255\255\255\255\255\255\ - \255\255\255\255\087\000\255\255\255\255\087\000\087\000\087\000\ - \255\255\255\255\087\000\087\000\087\000\255\255\087\000\087\000\ - \087\000\255\255\255\255\085\000\085\000\085\000\255\255\255\255\ - \086\000\086\000\086\000\087\000\255\255\087\000\087\000\087\000\ - \087\000\087\000\255\255\255\255\255\255\255\255\255\255\088\000\ - \255\255\255\255\088\000\088\000\088\000\255\255\255\255\088\000\ - \088\000\088\000\255\255\088\000\088\000\088\000\255\255\255\255\ - \086\000\086\000\086\000\255\255\255\255\087\000\087\000\087\000\ - \088\000\255\255\088\000\088\000\088\000\088\000\088\000\255\255\ - \255\255\255\255\255\255\255\255\089\000\255\255\255\255\089\000\ - \089\000\089\000\255\255\255\255\089\000\089\000\089\000\255\255\ - \089\000\089\000\089\000\255\255\255\255\087\000\087\000\087\000\ - \255\255\255\255\088\000\088\000\088\000\089\000\255\255\089\000\ - \089\000\089\000\089\000\089\000\255\255\255\255\255\255\255\255\ - \255\255\090\000\255\255\255\255\090\000\090\000\090\000\255\255\ - \255\255\255\255\090\000\090\000\255\255\090\000\090\000\090\000\ - \255\255\255\255\088\000\088\000\088\000\255\255\255\255\089\000\ - \089\000\089\000\090\000\255\255\090\000\090\000\090\000\090\000\ - \090\000\255\255\255\255\255\255\091\000\255\255\255\255\091\000\ - \091\000\091\000\255\255\255\255\091\000\091\000\091\000\255\255\ - \091\000\091\000\091\000\255\255\255\255\255\255\255\255\089\000\ - \089\000\089\000\255\255\255\255\090\000\091\000\090\000\091\000\ - \091\000\091\000\091\000\091\000\255\255\255\255\255\255\255\255\ - \255\255\092\000\255\255\255\255\092\000\092\000\092\000\255\255\ - \255\255\092\000\092\000\092\000\255\255\092\000\092\000\092\000\ - \255\255\255\255\255\255\255\255\090\000\255\255\090\000\091\000\ - \091\000\091\000\092\000\255\255\092\000\092\000\092\000\092\000\ - \092\000\255\255\255\255\255\255\255\255\255\255\093\000\255\255\ - \255\255\093\000\093\000\093\000\255\255\255\255\093\000\093\000\ - \093\000\255\255\093\000\093\000\093\000\255\255\255\255\091\000\ - \091\000\091\000\255\255\255\255\092\000\092\000\092\000\093\000\ - \255\255\093\000\093\000\093\000\093\000\093\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\094\000\ - \094\000\255\255\255\255\094\000\255\255\255\255\255\255\255\255\ - \094\000\094\000\255\255\255\255\092\000\092\000\092\000\255\255\ - \255\255\093\000\093\000\093\000\094\000\255\255\094\000\094\000\ - \094\000\255\255\094\000\255\255\255\255\255\255\255\255\255\255\ - \095\000\255\255\255\255\095\000\095\000\095\000\255\255\255\255\ - \095\000\095\000\095\000\255\255\095\000\095\000\095\000\255\255\ - \255\255\093\000\093\000\093\000\255\255\255\255\255\255\094\000\ - \094\000\095\000\255\255\095\000\095\000\095\000\095\000\095\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\096\000\096\000\255\255\255\255\096\000\255\255\255\255\ - \255\255\255\255\096\000\096\000\255\255\255\255\094\000\094\000\ - \255\255\255\255\255\255\095\000\095\000\095\000\096\000\255\255\ - \096\000\096\000\096\000\255\255\096\000\255\255\255\255\255\255\ - \255\255\255\255\097\000\255\255\255\255\097\000\097\000\097\000\ - \255\255\255\255\097\000\097\000\097\000\255\255\097\000\097\000\ - \097\000\255\255\255\255\095\000\095\000\095\000\255\255\255\255\ - \255\255\096\000\096\000\097\000\255\255\097\000\097\000\097\000\ - \097\000\097\000\255\255\255\255\255\255\255\255\255\255\098\000\ - \255\255\255\255\098\000\098\000\098\000\255\255\255\255\098\000\ - \098\000\098\000\255\255\098\000\098\000\098\000\255\255\255\255\ - \096\000\096\000\255\255\255\255\255\255\097\000\097\000\097\000\ - \098\000\255\255\098\000\098\000\098\000\098\000\098\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \109\000\109\000\255\255\255\255\109\000\255\255\255\255\110\000\ - \110\000\109\000\109\000\110\000\255\255\097\000\097\000\097\000\ - \110\000\110\000\098\000\098\000\098\000\109\000\255\255\109\000\ - \109\000\109\000\255\255\109\000\110\000\255\255\110\000\110\000\ - \110\000\255\255\110\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\111\000\111\000\255\255\255\255\ - \111\000\255\255\098\000\098\000\098\000\111\000\111\000\255\255\ - \109\000\109\000\255\255\255\255\255\255\255\255\255\255\110\000\ - \110\000\111\000\255\255\111\000\111\000\111\000\255\255\111\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\112\000\112\000\255\255\255\255\112\000\255\255\109\000\ - \109\000\255\255\112\000\112\000\255\255\255\255\110\000\110\000\ - \255\255\255\255\255\255\255\255\111\000\111\000\112\000\255\255\ - \112\000\112\000\112\000\255\255\112\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\113\000\113\000\ - \255\255\255\255\113\000\255\255\255\255\114\000\114\000\113\000\ - \113\000\114\000\255\255\111\000\111\000\255\255\114\000\114\000\ - \255\255\112\000\112\000\113\000\255\255\113\000\113\000\113\000\ - \255\255\113\000\114\000\255\255\114\000\114\000\114\000\255\255\ - \114\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\115\000\115\000\255\255\255\255\255\255\255\255\ - \112\000\112\000\255\255\115\000\115\000\255\255\113\000\113\000\ - \255\255\255\255\255\255\255\255\255\255\114\000\114\000\115\000\ - \255\255\115\000\115\000\115\000\255\255\115\000\255\255\255\255\ - \255\255\116\000\116\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\116\000\116\000\255\255\113\000\113\000\255\255\ - \255\255\255\255\255\255\255\255\114\000\114\000\116\000\255\255\ - \116\000\116\000\116\000\115\000\116\000\117\000\117\000\255\255\ - \117\000\255\255\255\255\255\255\255\255\255\255\117\000\117\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\117\000\255\255\117\000\117\000\117\000\255\255\ - \117\000\115\000\116\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\118\000\118\000\255\255\255\255\255\255\119\000\ - \119\000\255\255\119\000\118\000\118\000\255\255\255\255\255\255\ - \119\000\119\000\255\255\117\000\255\255\255\255\117\000\118\000\ - \116\000\118\000\118\000\118\000\119\000\118\000\119\000\119\000\ - \119\000\255\255\119\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\117\000\117\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\118\000\255\255\119\000\255\255\255\255\ - \119\000\255\255\255\255\255\255\255\255\255\255\120\000\255\255\ - \255\255\120\000\120\000\120\000\255\255\255\255\120\000\120\000\ - \120\000\255\255\120\000\120\000\120\000\255\255\255\255\255\255\ - \255\255\118\000\255\255\255\255\255\255\119\000\119\000\120\000\ - \255\255\120\000\120\000\120\000\120\000\120\000\255\255\255\255\ - \255\255\255\255\255\255\121\000\255\255\255\255\121\000\121\000\ - \121\000\255\255\255\255\121\000\121\000\121\000\255\255\121\000\ - \121\000\121\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\120\000\120\000\120\000\121\000\255\255\121\000\121\000\ - \121\000\121\000\121\000\255\255\255\255\255\255\255\255\255\255\ - \122\000\255\255\255\255\122\000\122\000\122\000\255\255\255\255\ - \122\000\122\000\122\000\255\255\122\000\122\000\122\000\255\255\ - \255\255\120\000\120\000\120\000\255\255\255\255\121\000\121\000\ - \121\000\122\000\255\255\122\000\122\000\122\000\122\000\122\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\123\000\ - \255\255\255\255\123\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\121\000\121\000\ - \121\000\255\255\255\255\122\000\122\000\122\000\255\255\123\000\ - \255\255\255\255\255\255\255\255\123\000\123\000\255\255\123\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\123\000\255\255\122\000\122\000\122\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \255\255\255\255\255\255\255\255\123\000\255\255\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \156\000\156\000\156\000\156\000\156\000\156\000\156\000\156\000\ - \156\000\156\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\156\000\156\000\156\000\156\000\156\000\156\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\156\000\156\000\156\000\156\000\156\000\156\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\255\255\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\255\255\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\130\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\255\255\255\255\255\255\255\255\130\000\255\255\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\255\255\255\255\255\255\255\255\137\000\255\255\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\255\255\255\255\255\255\255\255\255\255\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\255\255\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\255\255\130\000\ - \130\000\130\000\130\000\130\000\130\000\130\000\130\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\255\255\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\255\255\137\000\ - \137\000\137\000\137\000\137\000\137\000\137\000\137\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\255\255\255\255\255\255\255\255\138\000\255\255\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\167\000\167\000\167\000\167\000\167\000\167\000\167\000\ - \167\000\167\000\167\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\167\000\167\000\167\000\167\000\167\000\167\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\167\000\167\000\167\000\167\000\167\000\167\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\255\255\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\139\000\138\000\138\000\ - \138\000\138\000\138\000\138\000\138\000\138\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \255\255\255\255\139\000\255\255\255\255\255\255\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\255\255\255\255\255\255\255\255\139\000\255\255\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \174\000\174\000\174\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\174\000\174\000\174\000\174\000\174\000\174\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\174\000\174\000\174\000\174\000\174\000\174\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\255\255\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\140\000\139\000\139\000\ - \139\000\139\000\139\000\139\000\139\000\139\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \255\255\255\255\140\000\255\255\255\255\255\255\255\255\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\255\255\255\255\255\255\255\255\140\000\255\255\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\255\255\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\255\255\140\000\140\000\ - \140\000\140\000\140\000\140\000\140\000\140\000\141\000\255\255\ - \141\000\255\255\255\255\164\000\255\255\141\000\164\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\141\000\141\000\ - \141\000\141\000\141\000\141\000\141\000\141\000\141\000\141\000\ - \255\255\164\000\255\255\164\000\255\255\255\255\255\255\255\255\ - \164\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\141\000\255\255\255\255\255\255\255\255\255\255\ - \141\000\176\000\255\255\255\255\176\000\176\000\176\000\255\255\ - \255\255\255\255\176\000\176\000\141\000\176\000\176\000\176\000\ - \141\000\255\255\141\000\255\255\255\255\164\000\141\000\255\255\ - \255\255\255\255\176\000\164\000\176\000\176\000\176\000\176\000\ - \176\000\255\255\255\255\255\255\255\255\255\255\255\255\164\000\ - \255\255\255\255\255\255\164\000\255\255\164\000\255\255\255\255\ - \255\255\164\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\176\000\255\255\176\000\255\255\ - \255\255\255\255\255\255\255\255\177\000\255\255\255\255\177\000\ - \177\000\177\000\255\255\255\255\255\255\177\000\177\000\255\255\ - \177\000\177\000\177\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\176\000\177\000\176\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\255\255\177\000\ - \255\255\177\000\177\000\255\255\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\255\255\177\000\ - \255\255\177\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\164\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\255\255\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\255\255\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\178\000\255\255\255\255\178\000\178\000\ - \178\000\255\255\255\255\255\255\178\000\178\000\255\255\178\000\ - \178\000\178\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\178\000\255\255\178\000\178\000\ - \178\000\178\000\178\000\255\255\255\255\255\255\255\255\179\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\255\255\255\255\179\000\255\255\178\000\255\255\ - \178\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\255\255\255\255\255\255\178\000\179\000\ - \178\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\255\255\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\255\255\ - \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ - \181\000\255\255\255\255\181\000\181\000\181\000\255\255\255\255\ - \255\255\181\000\181\000\255\255\181\000\181\000\181\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\181\000\255\255\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\255\255\181\000\255\255\181\000\181\000\255\255\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\255\255\181\000\255\255\181\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\255\255\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\255\255\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\182\000\ - \255\255\255\255\182\000\182\000\182\000\255\255\255\255\255\255\ - \182\000\182\000\255\255\182\000\182\000\182\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \182\000\255\255\182\000\182\000\182\000\182\000\182\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\183\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\255\255\182\000\183\000\182\000\255\255\255\255\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\182\000\255\255\182\000\255\255\183\000\255\255\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\255\255\255\255\255\255\255\255\184\000\255\255\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\255\255\255\255\255\255\255\255\255\255\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\255\255\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\255\255\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\255\255\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\186\000\184\000\ - \184\000\184\000\184\000\184\000\184\000\184\000\184\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\255\255\255\255\186\000\255\255\255\255\255\255\255\255\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\255\255\255\255\255\255\255\255\186\000\255\255\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\255\255\255\255\255\255\255\255\196\000\255\255\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\255\255\255\255\255\255\255\255\255\255\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\255\255\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\255\255\186\000\ - \186\000\186\000\186\000\186\000\186\000\186\000\186\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\255\255\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\255\255\196\000\ - \196\000\196\000\196\000\196\000\196\000\196\000\196\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\255\255\255\255\255\255\255\255\197\000\255\255\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\255\255\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\198\000\197\000\197\000\ - \197\000\197\000\197\000\197\000\197\000\197\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \255\255\255\255\198\000\255\255\255\255\255\255\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\255\255\255\255\255\255\255\255\198\000\255\255\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\255\255\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\199\000\198\000\198\000\ - \198\000\198\000\198\000\198\000\198\000\198\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \255\255\255\255\199\000\255\255\255\255\255\255\255\255\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\255\255\255\255\255\255\255\255\199\000\255\255\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\255\255\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\255\255\199\000\199\000\ - \199\000\199\000\199\000\199\000\199\000\199\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\255\255\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\201\000\201\000\201\000\201\000\255\255\201\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ - \201\000\201\000\201\000\201\000\201\000\201\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\201\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\201\000\205\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\201\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\255\255\255\255\255\255\255\255\205\000\255\255\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\255\255\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\255\255\205\000\ - \205\000\205\000\205\000\205\000\205\000\205\000\205\000\206\000\ - \255\255\255\255\255\255\255\255\255\255\206\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\206\000\255\255\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\255\255\255\255\255\255\255\255\255\255\255\255\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\255\255\255\255\255\255\255\255\206\000\255\255\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\255\255\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\209\000\206\000\206\000\ - \206\000\206\000\206\000\206\000\206\000\206\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\255\255\255\255\255\255\255\255\255\255\255\255\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\255\255\255\255\255\255\255\255\209\000\255\255\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\255\255\255\255\255\255\255\255\255\255\255\255\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\255\255\255\255\255\255\255\255\218\000\255\255\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\255\255\255\255\255\255\255\255\255\255\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\255\255\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\255\255\209\000\209\000\ - \209\000\209\000\209\000\209\000\209\000\209\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\255\255\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\255\255\218\000\218\000\ - \218\000\218\000\218\000\218\000\218\000\218\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \255\255\255\255\255\255\255\255\219\000\255\255\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\255\255\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\220\000\219\000\219\000\219\000\ - \219\000\219\000\219\000\219\000\219\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\255\255\ - \255\255\220\000\255\255\255\255\255\255\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \255\255\255\255\255\255\255\255\220\000\255\255\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\255\255\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\221\000\220\000\220\000\220\000\ - \220\000\220\000\220\000\220\000\220\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\255\255\ - \255\255\221\000\255\255\255\255\255\255\255\255\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \255\255\255\255\255\255\255\255\221\000\255\255\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\255\255\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\255\255\221\000\221\000\221\000\ - \221\000\221\000\221\000\221\000\221\000\255\255"; - Lexing.lex_base_code = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\027\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\066\000\101\000\136\000\171\000\ - \206\000\000\000\000\000\000\000\000\000\241\000\020\001\055\001\ - \000\000\000\000\018\000\090\001\125\001\160\001\195\001\230\001\ - \000\000\021\000\026\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\247\001\040\002\000\000\034\000\000\000\ - \000\000\003\000\000\000\000\000\049\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\ - \000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\036\002\000\000\244\002\ - \000\000\000\000\000\000\061\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000"; - Lexing.lex_backtrk_code = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\034\000\000\000\000\000\ - \000\000\000\000\000\000\049\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\061\000\061\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000"; - Lexing.lex_default_code = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \041\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000"; - Lexing.lex_trans_code = - "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\001\000\000\000\058\000\058\000\000\000\058\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \001\000\000\000\000\000\001\000\007\000\044\000\000\000\007\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ - \004\000\004\000\000\000\007\000\012\000\000\000\000\000\012\000\ - \012\000\012\000\000\000\000\000\000\000\000\000\012\000\000\000\ - \012\000\012\000\012\000\007\000\000\000\000\000\007\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\012\000\000\000\012\000\ - \012\000\012\000\012\000\012\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\007\000\015\000\000\000\000\000\015\000\015\000\ - \015\000\000\000\000\000\000\000\015\000\015\000\000\000\015\000\ - \015\000\015\000\000\000\000\000\000\000\000\000\000\000\012\000\ - \000\000\012\000\000\000\000\000\015\000\000\000\015\000\015\000\ - \015\000\015\000\015\000\000\000\000\000\000\000\012\000\000\000\ - \000\000\012\000\012\000\012\000\000\000\000\000\000\000\012\000\ - \012\000\000\000\012\000\012\000\012\000\000\000\000\000\012\000\ - \000\000\012\000\000\000\000\000\000\000\000\000\015\000\012\000\ - \015\000\012\000\012\000\012\000\012\000\012\000\000\000\000\000\ - \000\000\012\000\000\000\000\000\012\000\012\000\012\000\000\000\ - \000\000\000\000\012\000\012\000\000\000\012\000\012\000\012\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\015\000\000\000\ - \015\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ - \012\000\000\000\000\000\000\000\012\000\000\000\000\000\012\000\ - \012\000\012\000\000\000\000\000\000\000\012\000\012\000\000\000\ - \012\000\012\000\012\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\012\000\000\000\012\000\012\000\012\000\012\000\012\000\ - \012\000\012\000\012\000\012\000\000\000\000\000\000\000\012\000\ - \000\000\000\000\012\000\012\000\012\000\000\000\000\000\000\000\ - \012\000\012\000\000\000\012\000\012\000\012\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\012\000\000\000\012\000\012\000\ - \012\000\012\000\012\000\012\000\012\000\012\000\012\000\000\000\ - \000\000\000\000\012\000\000\000\000\000\012\000\012\000\012\000\ - \000\000\000\000\000\000\012\000\012\000\000\000\012\000\012\000\ - \012\000\000\000\000\000\000\000\000\000\000\000\000\000\012\000\ - \000\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ - \012\000\012\000\000\000\000\000\000\000\012\000\000\000\000\000\ - \012\000\012\000\012\000\000\000\000\000\000\000\012\000\012\000\ - \000\000\012\000\012\000\012\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\012\000\000\000\012\000\012\000\012\000\012\000\ - \012\000\012\000\012\000\012\000\012\000\000\000\000\000\000\000\ - \012\000\000\000\000\000\012\000\012\000\012\000\000\000\000\000\ - \000\000\012\000\012\000\000\000\012\000\012\000\012\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\012\000\000\000\012\000\ - \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ - \000\000\000\000\000\000\012\000\000\000\000\000\012\000\012\000\ - \012\000\000\000\000\000\000\000\012\000\012\000\000\000\012\000\ - \012\000\012\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \012\000\000\000\012\000\012\000\012\000\012\000\012\000\012\000\ - \012\000\012\000\012\000\000\000\000\000\000\000\012\000\000\000\ - \000\000\012\000\012\000\012\000\000\000\000\000\000\000\012\000\ - \012\000\000\000\012\000\012\000\012\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\012\000\000\000\012\000\012\000\012\000\ - \012\000\012\000\012\000\012\000\012\000\012\000\000\000\000\000\ - \000\000\012\000\000\000\000\000\012\000\012\000\012\000\000\000\ - \000\000\000\000\012\000\012\000\000\000\012\000\012\000\012\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\012\000\000\000\ - \012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\ - \012\000\000\000\000\000\000\000\015\000\000\000\000\000\015\000\ - \015\000\015\000\000\000\000\000\000\000\015\000\015\000\000\000\ - \015\000\015\000\015\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\012\000\000\000\012\000\012\000\015\000\012\000\015\000\ - \015\000\015\000\015\000\015\000\000\000\000\000\000\000\015\000\ - \000\000\000\000\015\000\015\000\015\000\000\000\000\000\000\000\ - \015\000\015\000\000\000\015\000\015\000\015\000\000\000\000\000\ - \000\000\029\000\000\000\000\000\012\000\000\000\012\000\015\000\ - \015\000\015\000\015\000\015\000\015\000\015\000\015\000\004\000\ - \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ - \004\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\015\000\ - \000\000\015\000\015\000\000\000\015\000\000\000\000\000\000\000\ - \001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ - \004\000\004\000\015\000\000\000\015\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\000\000\ - \000\000\000\000\000\000\058\000\000\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\000\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\000\000\ - \000\000\000\000\000\000\058\000\000\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\000\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\000\000\058\000\058\000\058\000\058\000\ - \058\000\058\000\058\000\058\000\000\000"; - Lexing.lex_check_code = - "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\016\000\104\000\164\000\170\000\104\000\164\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \016\000\255\255\104\000\000\000\019\000\105\000\255\255\019\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \016\000\016\000\016\000\016\000\016\000\016\000\016\000\016\000\ - \016\000\016\000\255\255\019\000\019\000\255\255\255\255\019\000\ - \019\000\019\000\255\255\255\255\255\255\255\255\019\000\255\255\ - \019\000\019\000\019\000\060\000\255\255\255\255\060\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\019\000\255\255\019\000\ - \019\000\019\000\019\000\019\000\255\255\255\255\255\255\255\255\ - \255\255\255\255\060\000\060\000\255\255\255\255\060\000\060\000\ - \060\000\255\255\255\255\255\255\060\000\060\000\255\255\060\000\ - \060\000\060\000\255\255\255\255\255\255\255\255\255\255\019\000\ - \255\255\019\000\255\255\255\255\060\000\255\255\060\000\060\000\ - \060\000\060\000\060\000\255\255\255\255\255\255\061\000\255\255\ - \255\255\061\000\061\000\061\000\255\255\255\255\255\255\061\000\ - \061\000\255\255\061\000\061\000\061\000\255\255\255\255\019\000\ - \255\255\019\000\255\255\255\255\255\255\255\255\060\000\061\000\ - \060\000\061\000\061\000\061\000\061\000\061\000\255\255\255\255\ - \255\255\062\000\255\255\255\255\062\000\062\000\062\000\255\255\ - \255\255\255\255\062\000\062\000\255\255\062\000\062\000\062\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\060\000\255\255\ - \060\000\061\000\062\000\061\000\062\000\062\000\062\000\062\000\ - \062\000\255\255\255\255\255\255\063\000\255\255\255\255\063\000\ - \063\000\063\000\255\255\255\255\255\255\063\000\063\000\255\255\ - \063\000\063\000\063\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\061\000\255\255\061\000\062\000\063\000\062\000\063\000\ - \063\000\063\000\063\000\063\000\255\255\255\255\255\255\064\000\ - \255\255\255\255\064\000\064\000\064\000\255\255\255\255\255\255\ - \064\000\064\000\255\255\064\000\064\000\064\000\255\255\255\255\ - \104\000\255\255\255\255\255\255\062\000\255\255\062\000\063\000\ - \064\000\063\000\064\000\064\000\064\000\064\000\064\000\255\255\ - \255\255\255\255\069\000\255\255\255\255\069\000\069\000\069\000\ - \255\255\255\255\255\255\069\000\069\000\255\255\069\000\069\000\ - \069\000\255\255\255\255\255\255\255\255\255\255\255\255\063\000\ - \255\255\063\000\064\000\069\000\064\000\069\000\069\000\069\000\ - \069\000\069\000\255\255\255\255\255\255\070\000\255\255\255\255\ - \070\000\070\000\070\000\255\255\255\255\255\255\070\000\070\000\ - \255\255\070\000\070\000\070\000\255\255\255\255\255\255\255\255\ - \255\255\255\255\064\000\255\255\064\000\069\000\070\000\069\000\ - \070\000\070\000\070\000\070\000\070\000\255\255\255\255\255\255\ - \071\000\255\255\255\255\071\000\071\000\071\000\255\255\255\255\ - \255\255\071\000\071\000\255\255\071\000\071\000\071\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\069\000\255\255\069\000\ - \070\000\071\000\070\000\071\000\071\000\071\000\071\000\071\000\ - \255\255\255\255\255\255\075\000\255\255\255\255\075\000\075\000\ - \075\000\255\255\255\255\255\255\075\000\075\000\255\255\075\000\ - \075\000\075\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \070\000\255\255\070\000\071\000\075\000\071\000\075\000\075\000\ - \075\000\075\000\075\000\255\255\255\255\255\255\076\000\255\255\ - \255\255\076\000\076\000\076\000\255\255\255\255\255\255\076\000\ - \076\000\255\255\076\000\076\000\076\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\071\000\255\255\071\000\075\000\076\000\ - \075\000\076\000\076\000\076\000\076\000\076\000\255\255\255\255\ - \255\255\077\000\255\255\255\255\077\000\077\000\077\000\255\255\ - \255\255\255\255\077\000\077\000\255\255\077\000\077\000\077\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\075\000\255\255\ - \075\000\076\000\077\000\076\000\077\000\077\000\077\000\077\000\ - \077\000\255\255\255\255\255\255\078\000\255\255\255\255\078\000\ - \078\000\078\000\255\255\255\255\255\255\078\000\078\000\255\255\ - \078\000\078\000\078\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\076\000\255\255\076\000\077\000\078\000\077\000\078\000\ - \078\000\078\000\078\000\078\000\255\255\255\255\255\255\079\000\ - \255\255\255\255\079\000\079\000\079\000\255\255\255\255\255\255\ - \079\000\079\000\255\255\079\000\079\000\079\000\255\255\255\255\ - \255\255\099\000\255\255\255\255\077\000\255\255\077\000\078\000\ - \079\000\078\000\079\000\079\000\079\000\079\000\079\000\099\000\ - \099\000\099\000\099\000\099\000\099\000\099\000\099\000\099\000\ - \099\000\100\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\078\000\ - \255\255\078\000\079\000\255\255\079\000\255\255\255\255\255\255\ - \100\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \100\000\100\000\100\000\100\000\100\000\100\000\100\000\100\000\ - \100\000\100\000\079\000\255\255\079\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\255\255\ - \255\255\255\255\255\255\181\000\255\255\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\255\255\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\183\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\255\255\ - \255\255\255\255\255\255\183\000\255\255\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\255\255\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\255\255\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\255\255"; - Lexing.lex_code = - "\255\004\255\255\009\255\255\006\255\005\255\255\007\255\255\008\ - \255\255\000\007\255\000\006\001\008\255\000\005\255\011\255\010\ - \255\255\003\255\000\004\001\009\255\011\255\255\010\255\011\255\ - \255\000\004\001\009\003\010\002\011\255\001\255\255\000\001\255\ - "; - } - - let rec token c lexbuf = - (lexbuf.Lexing.lex_mem <- Array.create 12 (-1); - __ocaml_lex_token_rec c lexbuf 0) - and __ocaml_lex_token_rec c lexbuf __ocaml_lex_state = - match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state - lexbuf - with - | 0 -> (update_loc c None 1 false 0; NEWLINE) - | 1 -> - let x = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in BLANKS x - | 2 -> - let x = - Lexing.sub_lexeme lexbuf - (lexbuf.Lexing.lex_start_pos + 1) - (lexbuf.Lexing.lex_curr_pos + (-1)) - in LABEL x - | 3 -> - let x = - Lexing.sub_lexeme lexbuf - (lexbuf.Lexing.lex_start_pos + 1) - (lexbuf.Lexing.lex_curr_pos + (-1)) - in OPTLABEL x - | 4 -> - let x = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in LIDENT x - | 5 -> - let x = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in UIDENT x - | 6 -> - let i = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in - (try INT ((cvt_int_literal i), i) - with - | Failure _ -> - err (Literal_overflow "int") (Loc.of_lexbuf lexbuf)) - | 7 -> - let f = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in - (try FLOAT ((float_of_string f), f) - with - | Failure _ -> - err (Literal_overflow "float") - (Loc.of_lexbuf lexbuf)) - | 8 -> - let i = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - (lexbuf.Lexing.lex_curr_pos + (-1)) - in - (try INT32 ((cvt_int32_literal i), i) - with - | Failure _ -> - err (Literal_overflow "int32") - (Loc.of_lexbuf lexbuf)) - | 9 -> - let i = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - (lexbuf.Lexing.lex_curr_pos + (-1)) - in - (try INT64 ((cvt_int64_literal i), i) - with - | Failure _ -> - err (Literal_overflow "int64") - (Loc.of_lexbuf lexbuf)) - | 10 -> - let i = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - (lexbuf.Lexing.lex_curr_pos + (-1)) - in - (try NATIVEINT ((cvt_nativeint_literal i), i) - with - | Failure _ -> - err (Literal_overflow "nativeint") - (Loc.of_lexbuf lexbuf)) - | 11 -> - (with_curr_loc string c; - let s = buff_contents c - in STRING ((TokenEval.string s), s)) - | 12 -> - let x = - Lexing.sub_lexeme lexbuf - (lexbuf.Lexing.lex_start_pos + 1) - (lexbuf.Lexing.lex_curr_pos + (-1)) - in - (update_loc c None 1 false 1; - CHAR ((TokenEval.char x), x)) - | 13 -> - let x = - Lexing.sub_lexeme lexbuf - (lexbuf.Lexing.lex_start_pos + 1) - (lexbuf.Lexing.lex_curr_pos + (-1)) - in CHAR ((TokenEval.char x), x) - | 14 -> - let c = - Lexing.sub_lexeme_char lexbuf - (lexbuf.Lexing.lex_start_pos + 2) - in - err (Illegal_escape (String.make 1 c)) - (Loc.of_lexbuf lexbuf) - | 15 -> - (store c; COMMENT (parse_nested comment (in_comment c))) - | 16 -> - (warn Comment_start (Loc.of_lexbuf lexbuf); - parse comment (in_comment c); - COMMENT (buff_contents c)) - | 17 -> - (warn Comment_not_end (Loc.of_lexbuf lexbuf); - move_start_p (-1) c; - SYMBOL "*") - | 18 -> - let beginning = - Lexing.sub_lexeme lexbuf - (lexbuf.Lexing.lex_start_pos + 2) - lexbuf.Lexing.lex_curr_pos - in - if quotations c - then - (move_start_p (- (String.length beginning)); - mk_quotation quotation c "" "" 2) - else parse (symbolchar_star ("<<" ^ beginning)) c - | 19 -> - if quotations c - then - QUOTATION - { - q_name = ""; - q_loc = ""; - q_shift = 2; - q_contents = ""; - } - else parse (symbolchar_star "<<>>") c - | 20 -> - if quotations c - then with_curr_loc maybe_quotation_at c - else parse (symbolchar_star "<@") c - | 21 -> - if quotations c - then with_curr_loc maybe_quotation_colon c - else parse (symbolchar_star "<:") c - | 22 -> - let num = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) - lexbuf.Lexing.lex_mem.(1) - and name = - Lexing.sub_lexeme_opt lexbuf lexbuf.Lexing.lex_mem.(3) - lexbuf.Lexing.lex_mem.(2) in - let inum = int_of_string num - in - (update_loc c name inum true 0; - LINE_DIRECTIVE (inum, name)) - | 23 -> - let op = - Lexing.sub_lexeme_char lexbuf - (lexbuf.Lexing.lex_start_pos + 1) - in ESCAPED_IDENT (String.make 1 op) - | 24 -> - let op = - Lexing.sub_lexeme lexbuf - (lexbuf.Lexing.lex_start_pos + 1) - (lexbuf.Lexing.lex_curr_pos + (-1)) - in ESCAPED_IDENT op - | 25 -> - let op = - Lexing.sub_lexeme lexbuf - (lexbuf.Lexing.lex_start_pos + 1) - lexbuf.Lexing.lex_mem.(0) - in ESCAPED_IDENT op - | 26 -> - let op = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) - (lexbuf.Lexing.lex_curr_pos + (-1)) - in ESCAPED_IDENT op - | 27 -> - let op = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) - lexbuf.Lexing.lex_mem.(1) - in ESCAPED_IDENT op - | 28 -> - let x = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in SYMBOL x - | 29 -> - if antiquots c - then with_curr_loc dollar (shift 1 c) - else parse (symbolchar_star "$") c - | 30 -> - let x = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in SYMBOL x - | 31 -> - let pos = lexbuf.lex_curr_p - in - (lexbuf.lex_curr_p <- - { - (pos) - with - pos_bol = pos.pos_bol + 1; - pos_cnum = pos.pos_cnum + 1; - }; - EOI) - | 32 -> - let c = - Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos - in err (Illegal_character c) (Loc.of_lexbuf lexbuf) - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_token_rec c lexbuf __ocaml_lex_state) - and comment c lexbuf = __ocaml_lex_comment_rec c lexbuf 123 - and __ocaml_lex_comment_rec c lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf - with - | 0 -> (store c; with_curr_loc comment c; parse comment c) - | 1 -> store c - | 2 -> - (store c; - if quotations c then with_curr_loc quotation c else (); - parse comment c) - | 3 -> store_parse comment c - | 4 -> - (store c; - (try with_curr_loc string c - with - | Loc.Exc_located (_, (Error.E Unterminated_string)) -> - err Unterminated_string_in_comment (loc c)); - Buffer.add_char c.buffer '"'; - parse comment c) - | 5 -> store_parse comment c - | 6 -> store_parse comment c - | 7 -> (update_loc c None 1 false 1; store_parse comment c) - | 8 -> store_parse comment c - | 9 -> store_parse comment c - | 10 -> store_parse comment c - | 11 -> store_parse comment c - | 12 -> err Unterminated_comment (loc c) - | 13 -> (update_loc c None 1 false 0; store_parse comment c) - | 14 -> store_parse comment c - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_comment_rec c lexbuf __ocaml_lex_state) - and string c lexbuf = - (lexbuf.Lexing.lex_mem <- Array.create 2 (-1); - __ocaml_lex_string_rec c lexbuf 159) - and __ocaml_lex_string_rec c lexbuf __ocaml_lex_state = - match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state - lexbuf - with - | 0 -> set_start_p c - | 1 -> - let space = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) - lexbuf.Lexing.lex_curr_pos - in - (update_loc c None 1 false (String.length space); - store_parse string c) - | 2 -> store_parse string c - | 3 -> store_parse string c - | 4 -> store_parse string c - | 5 -> - let x = - Lexing.sub_lexeme_char lexbuf - (lexbuf.Lexing.lex_start_pos + 1) - in - if is_in_comment c - then store_parse string c - else - (warn (Illegal_escape (String.make 1 x)) - (Loc.of_lexbuf lexbuf); - store_parse string c) - | 6 -> (update_loc c None 1 false 0; store_parse string c) - | 7 -> err Unterminated_string (loc c) - | 8 -> store_parse string c - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_string_rec c lexbuf __ocaml_lex_state) - and symbolchar_star beginning c lexbuf = - __ocaml_lex_symbolchar_star_rec beginning c lexbuf 176 - and - __ocaml_lex_symbolchar_star_rec beginning c lexbuf - __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf - with - | 0 -> - let tok = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in - (move_start_p (- (String.length beginning)) c; - SYMBOL (beginning ^ tok)) - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_symbolchar_star_rec beginning c lexbuf - __ocaml_lex_state) - and maybe_quotation_at c lexbuf = - __ocaml_lex_maybe_quotation_at_rec c lexbuf 177 - and - __ocaml_lex_maybe_quotation_at_rec c lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf - with - | 0 -> - let loc = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - (lexbuf.Lexing.lex_curr_pos + (-1)) - in - mk_quotation quotation c "" loc (1 + (String.length loc)) - | 1 -> - let tok = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in SYMBOL ("<@" ^ tok) - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_maybe_quotation_at_rec c lexbuf - __ocaml_lex_state) - and maybe_quotation_colon c lexbuf = - (lexbuf.Lexing.lex_mem <- Array.create 2 (-1); - __ocaml_lex_maybe_quotation_colon_rec c lexbuf 181) - and - __ocaml_lex_maybe_quotation_colon_rec c lexbuf - __ocaml_lex_state = - match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state - lexbuf - with - | 0 -> - let name = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - (lexbuf.Lexing.lex_curr_pos + (-1)) - in - mk_quotation quotation c name "" - (1 + (String.length name)) - | 1 -> - let name = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_mem.(0) - and loc = - Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_mem.(0) + 1) - (lexbuf.Lexing.lex_curr_pos + (-1)) - in - mk_quotation quotation c name loc - ((2 + (String.length loc)) + (String.length name)) - | 2 -> - let tok = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - lexbuf.Lexing.lex_curr_pos - in SYMBOL ("<:" ^ tok) - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_maybe_quotation_colon_rec c lexbuf - __ocaml_lex_state) - and quotation c lexbuf = __ocaml_lex_quotation_rec c lexbuf 188 - and __ocaml_lex_quotation_rec c lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf - with - | 0 -> (store c; with_curr_loc quotation c; parse quotation c) - | 1 -> store c - | 2 -> err Unterminated_quotation (loc c) - | 3 -> (update_loc c None 1 false 0; store_parse quotation c) - | 4 -> store_parse quotation c - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_quotation_rec c lexbuf __ocaml_lex_state) - and dollar c lexbuf = __ocaml_lex_dollar_rec c lexbuf 201 - and __ocaml_lex_dollar_rec c lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf - with - | 0 -> (set_start_p c; ANTIQUOT ("", "")) - | 1 -> - let name = - Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos - (lexbuf.Lexing.lex_curr_pos + (-1)) - in - with_curr_loc (antiquot name) - (shift (1 + (String.length name)) c) - | 2 -> store_parse (antiquot "") c - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_dollar_rec c lexbuf __ocaml_lex_state) - and antiquot name c lexbuf = - __ocaml_lex_antiquot_rec name c lexbuf 210 - and __ocaml_lex_antiquot_rec name c lexbuf __ocaml_lex_state = - match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf - with - | 0 -> (set_start_p c; ANTIQUOT (name, (buff_contents c))) - | 1 -> err Unterminated_antiquot (loc c) - | 2 -> - (update_loc c None 1 false 0; - store_parse (antiquot name) c) - | 3 -> - (store c; - with_curr_loc quotation c; - parse (antiquot name) c) - | 4 -> store_parse (antiquot name) c - | __ocaml_lex_state -> - (lexbuf.Lexing.refill_buff lexbuf; - __ocaml_lex_antiquot_rec name c lexbuf __ocaml_lex_state) - - let lexing_store s buff max = - let rec self n s = - if n >= max - then n - else - (match Stream.peek s with - | Some x -> (Stream.junk s; buff.[n] <- x; succ n) - | _ -> n) - in self 0 s - - let from_context c = - let next _ = - let tok = with_curr_loc token c in - let loc = Loc.of_lexbuf c.lexbuf in Some (tok, loc) - in Stream.from next - - let from_lexbuf ?(quotations = true) lb = - let c = - { - (default_context lb) - with - loc = Loc.of_lexbuf lb; - antiquots = !Camlp4_config.antiquotations; - quotations = quotations; - } - in from_context c - - let setup_loc lb loc = - let start_pos = Loc.start_pos loc - in - (lb.lex_abs_pos <- start_pos.pos_cnum; - lb.lex_curr_p <- start_pos) - - let from_string ?quotations loc str = - let lb = Lexing.from_string str - in (setup_loc lb loc; from_lexbuf ?quotations lb) - - let from_stream ?quotations loc strm = - let lb = Lexing.from_function (lexing_store strm) - in (setup_loc lb loc; from_lexbuf ?quotations lb) - - let mk () loc strm = - from_stream ~quotations: !Camlp4_config.quotations loc strm - - end - - end - - module Camlp4Ast = - struct - module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = - struct - module Loc = Loc - - module Ast = - struct - include Sig.MakeCamlp4Ast(Loc) - - let safe_string_escaped s = - if - ((String.length s) > 2) && - ((s.[0] = '\\') && (s.[1] = '$')) - then s - else String.escaped s - - end - - include Ast - - external loc_of_ctyp : ctyp -> Loc.t = "%field0" - - external loc_of_patt : patt -> Loc.t = "%field0" - - external loc_of_expr : expr -> Loc.t = "%field0" - - external loc_of_module_type : module_type -> Loc.t = "%field0" - - external loc_of_module_expr : module_expr -> Loc.t = "%field0" - - external loc_of_sig_item : sig_item -> Loc.t = "%field0" - - external loc_of_str_item : str_item -> Loc.t = "%field0" - - external loc_of_class_type : class_type -> Loc.t = "%field0" - - external loc_of_class_sig_item : class_sig_item -> Loc.t = - "%field0" - - external loc_of_class_expr : class_expr -> Loc.t = "%field0" - - external loc_of_class_str_item : class_str_item -> Loc.t = - "%field0" - - external loc_of_with_constr : with_constr -> Loc.t = "%field0" - - external loc_of_binding : binding -> Loc.t = "%field0" - - external loc_of_rec_binding : rec_binding -> Loc.t = "%field0" - - external loc_of_module_binding : module_binding -> Loc.t = - "%field0" - - external loc_of_match_case : match_case -> Loc.t = "%field0" - - external loc_of_ident : ident -> Loc.t = "%field0" - - let ghost = Loc.ghost - - let rec is_module_longident = - function - | Ast.IdAcc (_, _, i) -> is_module_longident i - | Ast.IdApp (_, i1, i2) -> - (is_module_longident i1) && (is_module_longident i2) - | Ast.IdUid (_, _) -> true - | _ -> false - - let ident_of_expr = - let error () = - invalid_arg - "ident_of_expr: this expression is not an identifier" in - let rec self = - function - | Ast.ExApp (_loc, e1, e2) -> - Ast.IdApp (_loc, (self e1), (self e2)) - | Ast.ExAcc (_loc, e1, e2) -> - Ast.IdAcc (_loc, (self e1), (self e2)) - | Ast.ExId (_, (Ast.IdLid (_, _))) -> error () - | Ast.ExId (_, i) -> - if is_module_longident i then i else error () - | _ -> error () - in - function - | Ast.ExId (_, i) -> i - | Ast.ExApp (_, _, _) -> error () - | t -> self t - - let ident_of_ctyp = - let error () = - invalid_arg "ident_of_ctyp: this type is not an identifier" in - let rec self = - function - | Ast.TyApp (_loc, t1, t2) -> - Ast.IdApp (_loc, (self t1), (self t2)) - | Ast.TyId (_, (Ast.IdLid (_, _))) -> error () - | Ast.TyId (_, i) -> - if is_module_longident i then i else error () - | _ -> error () - in function | Ast.TyId (_, i) -> i | t -> self t - - let ident_of_patt = - let error () = - invalid_arg - "ident_of_patt: this pattern is not an identifier" in - let rec self = - function - | Ast.PaApp (_loc, p1, p2) -> - Ast.IdApp (_loc, (self p1), (self p2)) - | Ast.PaId (_, (Ast.IdLid (_, _))) -> error () - | Ast.PaId (_, i) -> - if is_module_longident i then i else error () - | _ -> error () - in function | Ast.PaId (_, i) -> i | p -> self p - - let rec is_irrefut_patt = - function - | Ast.PaId (_, (Ast.IdLid (_, _))) -> true - | Ast.PaId (_, (Ast.IdUid (_, "()"))) -> true - | Ast.PaAny _ -> true - | Ast.PaNil _ -> true - | Ast.PaAli (_, x, y) -> - (is_irrefut_patt x) && (is_irrefut_patt y) - | Ast.PaRec (_, p) -> is_irrefut_patt p - | Ast.PaEq (_, _, p) -> is_irrefut_patt p - | Ast.PaSem (_, p1, p2) -> - (is_irrefut_patt p1) && (is_irrefut_patt p2) - | Ast.PaCom (_, p1, p2) -> - (is_irrefut_patt p1) && (is_irrefut_patt p2) - | Ast.PaOrp (_, p1, p2) -> - (is_irrefut_patt p1) && (is_irrefut_patt p2) - | Ast.PaApp (_, p1, p2) -> - (is_irrefut_patt p1) && (is_irrefut_patt p2) - | Ast.PaTyc (_, p, _) -> is_irrefut_patt p - | Ast.PaTup (_, pl) -> is_irrefut_patt pl - | Ast.PaOlb (_, _, (Ast.PaNil _)) -> true - | Ast.PaOlb (_, _, p) -> is_irrefut_patt p - | Ast.PaOlbi (_, _, p, _) -> is_irrefut_patt p - | Ast.PaLab (_, _, (Ast.PaNil _)) -> true - | Ast.PaLab (_, _, p) -> is_irrefut_patt p - | Ast.PaLaz (_, p) -> is_irrefut_patt p - | Ast.PaId (_, _) -> false - | Ast.PaMod (_, _) -> true - | Ast.PaVrn (_, _) | Ast.PaStr (_, _) | Ast.PaRng (_, _, _) | - Ast.PaFlo (_, _) | Ast.PaNativeInt (_, _) | - Ast.PaInt64 (_, _) | Ast.PaInt32 (_, _) | Ast.PaInt (_, _) - | Ast.PaChr (_, _) | Ast.PaTyp (_, _) | Ast.PaArr (_, _) | - Ast.PaAnt (_, _) -> false - - let rec is_constructor = - function - | Ast.IdAcc (_, _, i) -> is_constructor i - | Ast.IdUid (_, _) -> true - | Ast.IdLid (_, _) | Ast.IdApp (_, _, _) -> false - | Ast.IdAnt (_, _) -> assert false - - let is_patt_constructor = - function - | Ast.PaId (_, i) -> is_constructor i - | Ast.PaVrn (_, _) -> true - | _ -> false - - let rec is_expr_constructor = - function - | Ast.ExId (_, i) -> is_constructor i - | Ast.ExAcc (_, e1, e2) -> - (is_expr_constructor e1) && (is_expr_constructor e2) - | Ast.ExVrn (_, _) -> true - | _ -> false - - let rec tyOr_of_list = - function - | [] -> Ast.TyNil ghost - | [ t ] -> t - | t :: ts -> - let _loc = loc_of_ctyp t - in Ast.TyOr (_loc, t, (tyOr_of_list ts)) - - let rec tyAnd_of_list = - function - | [] -> Ast.TyNil ghost - | [ t ] -> t - | t :: ts -> - let _loc = loc_of_ctyp t - in Ast.TyAnd (_loc, t, (tyAnd_of_list ts)) - - let rec tySem_of_list = - function - | [] -> Ast.TyNil ghost - | [ t ] -> t - | t :: ts -> - let _loc = loc_of_ctyp t - in Ast.TySem (_loc, t, (tySem_of_list ts)) - - let rec tyCom_of_list = - function - | [] -> Ast.TyNil ghost - | [ t ] -> t - | t :: ts -> - let _loc = loc_of_ctyp t - in Ast.TyCom (_loc, t, (tyCom_of_list ts)) - - let rec tyAmp_of_list = - function - | [] -> Ast.TyNil ghost - | [ t ] -> t - | t :: ts -> - let _loc = loc_of_ctyp t - in Ast.TyAmp (_loc, t, (tyAmp_of_list ts)) - - let rec tySta_of_list = - function - | [] -> Ast.TyNil ghost - | [ t ] -> t - | t :: ts -> - let _loc = loc_of_ctyp t - in Ast.TySta (_loc, t, (tySta_of_list ts)) - - let rec stSem_of_list = - function - | [] -> Ast.StNil ghost - | [ t ] -> t - | t :: ts -> - let _loc = loc_of_str_item t - in Ast.StSem (_loc, t, (stSem_of_list ts)) - - let rec sgSem_of_list = - function - | [] -> Ast.SgNil ghost - | [ t ] -> t - | t :: ts -> - let _loc = loc_of_sig_item t - in Ast.SgSem (_loc, t, (sgSem_of_list ts)) - - let rec biAnd_of_list = - function - | [] -> Ast.BiNil ghost - | [ b ] -> b - | b :: bs -> - let _loc = loc_of_binding b - in Ast.BiAnd (_loc, b, (biAnd_of_list bs)) - - let rec rbSem_of_list = - function - | [] -> Ast.RbNil ghost - | [ b ] -> b - | b :: bs -> - let _loc = loc_of_rec_binding b - in Ast.RbSem (_loc, b, (rbSem_of_list bs)) - - let rec wcAnd_of_list = - function - | [] -> Ast.WcNil ghost - | [ w ] -> w - | w :: ws -> - let _loc = loc_of_with_constr w - in Ast.WcAnd (_loc, w, (wcAnd_of_list ws)) - - let rec idAcc_of_list = - function - | [] -> assert false - | [ i ] -> i - | i :: is -> - let _loc = loc_of_ident i - in Ast.IdAcc (_loc, i, (idAcc_of_list is)) - - let rec idApp_of_list = - function - | [] -> assert false - | [ i ] -> i - | i :: is -> - let _loc = loc_of_ident i - in Ast.IdApp (_loc, i, (idApp_of_list is)) - - let rec mcOr_of_list = - function - | [] -> Ast.McNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_match_case x - in Ast.McOr (_loc, x, (mcOr_of_list xs)) - - let rec mbAnd_of_list = - function - | [] -> Ast.MbNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_module_binding x - in Ast.MbAnd (_loc, x, (mbAnd_of_list xs)) - - let rec meApp_of_list = - function - | [] -> assert false - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_module_expr x - in Ast.MeApp (_loc, x, (meApp_of_list xs)) - - let rec ceAnd_of_list = - function - | [] -> Ast.CeNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_class_expr x - in Ast.CeAnd (_loc, x, (ceAnd_of_list xs)) - - let rec ctAnd_of_list = - function - | [] -> Ast.CtNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_class_type x - in Ast.CtAnd (_loc, x, (ctAnd_of_list xs)) - - let rec cgSem_of_list = - function - | [] -> Ast.CgNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_class_sig_item x - in Ast.CgSem (_loc, x, (cgSem_of_list xs)) - - let rec crSem_of_list = - function - | [] -> Ast.CrNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_class_str_item x - in Ast.CrSem (_loc, x, (crSem_of_list xs)) - - let rec paSem_of_list = - function - | [] -> Ast.PaNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_patt x - in Ast.PaSem (_loc, x, (paSem_of_list xs)) - - let rec paCom_of_list = - function - | [] -> Ast.PaNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_patt x - in Ast.PaCom (_loc, x, (paCom_of_list xs)) - - let rec exSem_of_list = - function - | [] -> Ast.ExNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_expr x - in Ast.ExSem (_loc, x, (exSem_of_list xs)) - - let rec exCom_of_list = - function - | [] -> Ast.ExNil ghost - | [ x ] -> x - | x :: xs -> - let _loc = loc_of_expr x - in Ast.ExCom (_loc, x, (exCom_of_list xs)) - - let ty_of_stl = - function - | (_loc, s, []) -> Ast.TyId (_loc, (Ast.IdUid (_loc, s))) - | (_loc, s, tl) -> - Ast.TyOf (_loc, (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), - (tyAnd_of_list tl)) - - let ty_of_sbt = - function - | (_loc, s, true, t) -> - Ast.TyCol (_loc, (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))), - (Ast.TyMut (_loc, t))) - | (_loc, s, false, t) -> - Ast.TyCol (_loc, (Ast.TyId (_loc, (Ast.IdLid (_loc, s)))), - t) - - let bi_of_pe (p, e) = - let _loc = loc_of_patt p in Ast.BiEq (_loc, p, e) - - let sum_type_of_list l = tyOr_of_list (List.map ty_of_stl l) - - let record_type_of_list l = tySem_of_list (List.map ty_of_sbt l) - - let binding_of_pel l = biAnd_of_list (List.map bi_of_pe l) - - let rec pel_of_binding = - function - | Ast.BiAnd (_, b1, b2) -> - (pel_of_binding b1) @ (pel_of_binding b2) - | Ast.BiEq (_, p, e) -> [ (p, e) ] - | _ -> assert false - - let rec list_of_binding x acc = - match x with - | Ast.BiAnd (_, b1, b2) -> - list_of_binding b1 (list_of_binding b2 acc) - | t -> t :: acc - - let rec list_of_rec_binding x acc = - match x with - | Ast.RbSem (_, b1, b2) -> - list_of_rec_binding b1 (list_of_rec_binding b2 acc) - | t -> t :: acc - - let rec list_of_with_constr x acc = - match x with - | Ast.WcAnd (_, w1, w2) -> - list_of_with_constr w1 (list_of_with_constr w2 acc) - | t -> t :: acc - - let rec list_of_ctyp x acc = - match x with - | Ast.TyNil _ -> acc - | Ast.TyAmp (_, x, y) | Ast.TyCom (_, x, y) | - Ast.TySta (_, x, y) | Ast.TySem (_, x, y) | - Ast.TyAnd (_, x, y) | Ast.TyOr (_, x, y) -> - list_of_ctyp x (list_of_ctyp y acc) - | x -> x :: acc - - let rec list_of_patt x acc = - match x with - | Ast.PaNil _ -> acc - | Ast.PaCom (_, x, y) | Ast.PaSem (_, x, y) -> - list_of_patt x (list_of_patt y acc) - | x -> x :: acc - - let rec list_of_expr x acc = - match x with - | Ast.ExNil _ -> acc - | Ast.ExCom (_, x, y) | Ast.ExSem (_, x, y) -> - list_of_expr x (list_of_expr y acc) - | x -> x :: acc - - let rec list_of_str_item x acc = - match x with - | Ast.StNil _ -> acc - | Ast.StSem (_, x, y) -> - list_of_str_item x (list_of_str_item y acc) - | x -> x :: acc - - let rec list_of_sig_item x acc = - match x with - | Ast.SgNil _ -> acc - | Ast.SgSem (_, x, y) -> - list_of_sig_item x (list_of_sig_item y acc) - | x -> x :: acc - - let rec list_of_class_sig_item x acc = - match x with - | Ast.CgNil _ -> acc - | Ast.CgSem (_, x, y) -> - list_of_class_sig_item x (list_of_class_sig_item y acc) - | x -> x :: acc - - let rec list_of_class_str_item x acc = - match x with - | Ast.CrNil _ -> acc - | Ast.CrSem (_, x, y) -> - list_of_class_str_item x (list_of_class_str_item y acc) - | x -> x :: acc - - let rec list_of_class_type x acc = - match x with - | Ast.CtAnd (_, x, y) -> - list_of_class_type x (list_of_class_type y acc) - | x -> x :: acc - - let rec list_of_class_expr x acc = - match x with - | Ast.CeAnd (_, x, y) -> - list_of_class_expr x (list_of_class_expr y acc) - | x -> x :: acc - - let rec list_of_module_expr x acc = - match x with - | Ast.MeApp (_, x, y) -> - list_of_module_expr x (list_of_module_expr y acc) - | x -> x :: acc - - let rec list_of_match_case x acc = - match x with - | Ast.McNil _ -> acc - | Ast.McOr (_, x, y) -> - list_of_match_case x (list_of_match_case y acc) - | x -> x :: acc - - let rec list_of_ident x acc = - match x with - | Ast.IdAcc (_, x, y) | Ast.IdApp (_, x, y) -> - list_of_ident x (list_of_ident y acc) - | x -> x :: acc - - let rec list_of_module_binding x acc = - match x with - | Ast.MbAnd (_, x, y) -> - list_of_module_binding x (list_of_module_binding y acc) - | x -> x :: acc - - module Meta = - struct - module type META_LOC = - sig - val meta_loc_patt : Loc.t -> Loc.t -> Ast.patt - - val meta_loc_expr : Loc.t -> Loc.t -> Ast.expr - - end - - module MetaLoc = - struct - let meta_loc_patt _loc location = - let (a, b, c, d, e, f, g, h) = Loc.to_tuple location - in - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), - (Ast.IdLid (_loc, "of_tuple")))))), - (Ast.PaTup (_loc, - (Ast.PaCom (_loc, - (Ast.PaStr (_loc, - (Ast.safe_string_escaped a))), - (Ast.PaCom (_loc, - (Ast.PaCom (_loc, - (Ast.PaCom (_loc, - (Ast.PaCom (_loc, - (Ast.PaCom (_loc, - (Ast.PaCom (_loc, - (Ast.PaInt (_loc, - (string_of_int b))), - (Ast.PaInt (_loc, - (string_of_int c))))), - (Ast.PaInt (_loc, - (string_of_int d))))), - (Ast.PaInt (_loc, - (string_of_int e))))), - (Ast.PaInt (_loc, (string_of_int f))))), - (Ast.PaInt (_loc, (string_of_int g))))), - (if h - then - Ast.PaId (_loc, - (Ast.IdUid (_loc, "True"))) - else - Ast.PaId (_loc, - (Ast.IdUid (_loc, "False"))))))))))) - - let meta_loc_expr _loc location = - let (a, b, c, d, e, f, g, h) = Loc.to_tuple location - in - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), - (Ast.IdLid (_loc, "of_tuple")))))), - (Ast.ExTup (_loc, - (Ast.ExCom (_loc, - (Ast.ExStr (_loc, - (Ast.safe_string_escaped a))), - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExInt (_loc, - (string_of_int b))), - (Ast.ExInt (_loc, - (string_of_int c))))), - (Ast.ExInt (_loc, - (string_of_int d))))), - (Ast.ExInt (_loc, - (string_of_int e))))), - (Ast.ExInt (_loc, (string_of_int f))))), - (Ast.ExInt (_loc, (string_of_int g))))), - (if h - then - Ast.ExId (_loc, - (Ast.IdUid (_loc, "True"))) - else - Ast.ExId (_loc, - (Ast.IdUid (_loc, "False"))))))))))) - - end - - module MetaGhostLoc = - struct - let meta_loc_patt _loc _ = - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), - (Ast.IdLid (_loc, "ghost"))))) - - let meta_loc_expr _loc _ = - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), - (Ast.IdLid (_loc, "ghost"))))) - - end - - module MetaLocVar = - struct - let meta_loc_patt _loc _ = - Ast.PaId (_loc, (Ast.IdLid (_loc, !Loc.name))) - - let meta_loc_expr _loc _ = - Ast.ExId (_loc, (Ast.IdLid (_loc, !Loc.name))) - - end - - module Make (MetaLoc : META_LOC) = - struct - open MetaLoc - - let meta_loc = meta_loc_expr - - module Expr = - struct - let meta_string _loc s = - Ast.ExStr (_loc, (safe_string_escaped s)) - - let meta_int _loc s = Ast.ExInt (_loc, s) - - let meta_float _loc s = Ast.ExFlo (_loc, s) - - let meta_char _loc s = - Ast.ExChr (_loc, (String.escaped s)) - - let meta_bool _loc = - function - | false -> - Ast.ExId (_loc, (Ast.IdUid (_loc, "False"))) - | true -> - Ast.ExId (_loc, (Ast.IdUid (_loc, "True"))) - - let rec meta_list mf_a _loc = - function - | [] -> Ast.ExId (_loc, (Ast.IdUid (_loc, "[]"))) - | x :: xs -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdUid (_loc, "::")))), - (mf_a _loc x))), - (meta_list mf_a _loc xs)) - - let rec meta_binding _loc = - function - | Ast.BiAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.BiEq (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BiEq")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_expr _loc x2)) - | Ast.BiAnd (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BiAnd")))))), - (meta_loc _loc x0))), - (meta_binding _loc x1))), - (meta_binding _loc x2)) - | Ast.BiNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BiNil")))))), - (meta_loc _loc x0)) - and meta_class_expr _loc = - function - | Ast.CeAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.CeEq (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeEq")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1))), - (meta_class_expr _loc x2)) - | Ast.CeAnd (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeAnd")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1))), - (meta_class_expr _loc x2)) - | Ast.CeTyc (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeTyc")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1))), - (meta_class_type _loc x2)) - | Ast.CeStr (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeStr")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_class_str_item _loc x2)) - | Ast.CeLet (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeLet")))))), - (meta_loc _loc x0))), - (meta_rec_flag _loc x1))), - (meta_binding _loc x2))), - (meta_class_expr _loc x3)) - | Ast.CeFun (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeFun")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_class_expr _loc x2)) - | Ast.CeCon (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeCon")))))), - (meta_loc _loc x0))), - (meta_virtual_flag _loc x1))), - (meta_ident _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CeApp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeApp")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.CeNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeNil")))))), - (meta_loc _loc x0)) - and meta_class_sig_item _loc = - function - | Ast.CgAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.CgVir (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgVir")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_private_flag _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CgVal (x0, x1, x2, x3, x4) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgVal")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_mutable_flag _loc x2))), - (meta_virtual_flag _loc x3))), - (meta_ctyp _loc x4)) - | Ast.CgMth (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgMth")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_private_flag _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CgInh (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgInh")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1)) - | Ast.CgSem (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgSem")))))), - (meta_loc _loc x0))), - (meta_class_sig_item _loc x1))), - (meta_class_sig_item _loc x2)) - | Ast.CgCtr (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgCtr")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.CgNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgNil")))))), - (meta_loc _loc x0)) - and meta_class_str_item _loc = - function - | Ast.CrAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.CrVvr (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrVvr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_mutable_flag _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CrVir (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrVir")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_private_flag _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CrVal (x0, x1, x2, x3, x4) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrVal")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_override_flag _loc x2))), - (meta_mutable_flag _loc x3))), - (meta_expr _loc x4)) - | Ast.CrMth (x0, x1, x2, x3, x4, x5) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, - "CrMth")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_override_flag _loc x2))), - (meta_private_flag _loc x3))), - (meta_expr _loc x4))), - (meta_ctyp _loc x5)) - | Ast.CrIni (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrIni")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.CrInh (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrInh")))))), - (meta_loc _loc x0))), - (meta_override_flag _loc x1))), - (meta_class_expr _loc x2))), - (meta_string _loc x3)) - | Ast.CrCtr (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrCtr")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.CrSem (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrSem")))))), - (meta_loc _loc x0))), - (meta_class_str_item _loc x1))), - (meta_class_str_item _loc x2)) - | Ast.CrNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrNil")))))), - (meta_loc _loc x0)) - and meta_class_type _loc = - function - | Ast.CtAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.CtEq (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtEq")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1))), - (meta_class_type _loc x2)) - | Ast.CtCol (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtCol")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1))), - (meta_class_type _loc x2)) - | Ast.CtAnd (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtAnd")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1))), - (meta_class_type _loc x2)) - | Ast.CtSig (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtSig")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_class_sig_item _loc x2)) - | Ast.CtFun (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtFun")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_class_type _loc x2)) - | Ast.CtCon (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtCon")))))), - (meta_loc _loc x0))), - (meta_virtual_flag _loc x1))), - (meta_ident _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CtNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtNil")))))), - (meta_loc _loc x0)) - and meta_ctyp _loc = - function - | Ast.TyAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.TyPkg (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyPkg")))))), - (meta_loc _loc x0))), - (meta_module_type _loc x1)) - | Ast.TyOfAmp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyOfAmp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyAmp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAmp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyVrnInfSup (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrnInfSup")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyVrnInf (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrnInf")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyVrnSup (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrnSup")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyVrnEq (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrnEq")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TySta (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TySta")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyTup (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyTup")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyMut (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyMut")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyPrv (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyPrv")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyOr (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyOr")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyAnd (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAnd")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyOf (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyOf")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TySum (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TySum")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyCom (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyCom")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TySem (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TySem")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyCol (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyCol")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyRec (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyRec")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyVrn (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrn")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.TyAnM x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAnM")))))), - (meta_loc _loc x0)) - | Ast.TyAnP x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAnP")))))), - (meta_loc _loc x0)) - | Ast.TyQuM (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyQuM")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.TyQuP (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyQuP")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.TyQuo (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyQuo")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.TyTypePol (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyTypePol")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyPol (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyPol")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyOlb (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyOlb")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyObj (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyObj")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_row_var_flag _loc x2)) - | Ast.TyDcl (x0, x1, x2, x3, x4) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyDcl")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_list meta_ctyp _loc x2))), - (meta_ctyp _loc x3))), - (meta_list - (fun _loc (x1, x2) -> - Ast.ExTup (_loc, - (Ast.ExCom (_loc, - (meta_ctyp _loc x1), - (meta_ctyp _loc x2))))) - _loc x4)) - | Ast.TyMan (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyMan")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyId (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.TyLab (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyLab")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyCls (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyCls")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.TyArr (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyArr")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyApp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyApp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyAny x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAny")))))), - (meta_loc _loc x0)) - | Ast.TyAli (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAli")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyNil")))))), - (meta_loc _loc x0)) - and meta_direction_flag _loc = - function - | Ast.DiAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.DiDownto -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "DiDownto"))))) - | Ast.DiTo -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "DiTo"))))) - and meta_expr _loc = - function - | Ast.ExPkg (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExPkg")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1)) - | Ast.ExFUN (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExFUN")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.ExOpI (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExOpI")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_expr _loc x2)) - | Ast.ExWhi (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExWhi")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExVrn (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExVrn")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExTyc (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExTyc")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_ctyp _loc x2)) - | Ast.ExCom (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExCom")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExTup (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExTup")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExTry (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExTry")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_match_case _loc x2)) - | Ast.ExStr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExStr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExSte (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExSte")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExSnd (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExSnd")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_string _loc x2)) - | Ast.ExSeq (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExSeq")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExRec (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExRec")))))), - (meta_loc _loc x0))), - (meta_rec_binding _loc x1))), - (meta_expr _loc x2)) - | Ast.ExOvr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExOvr")))))), - (meta_loc _loc x0))), - (meta_rec_binding _loc x1)) - | Ast.ExOlb (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExOlb")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.ExObj (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExObj")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_class_str_item _loc x2)) - | Ast.ExNew (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExNew")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.ExMat (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExMat")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_match_case _loc x2)) - | Ast.ExLmd (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExLmd")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_expr _loc x2))), - (meta_expr _loc x3)) - | Ast.ExLet (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExLet")))))), - (meta_loc _loc x0))), - (meta_rec_flag _loc x1))), - (meta_binding _loc x2))), - (meta_expr _loc x3)) - | Ast.ExLaz (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExLaz")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExLab (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExLab")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.ExNativeInt (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExNativeInt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExInt64 (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExInt64")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExInt32 (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExInt32")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExInt (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExInt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExIfe (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExIfe")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2))), - (meta_expr _loc x3)) - | Ast.ExFun (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExFun")))))), - (meta_loc _loc x0))), - (meta_match_case _loc x1)) - | Ast.ExFor (x0, x1, x2, x3, x4, x5) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, - "ExFor")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2))), - (meta_expr _loc x3))), - (meta_direction_flag _loc x4))), - (meta_expr _loc x5)) - | Ast.ExFlo (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExFlo")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExCoe (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExCoe")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_ctyp _loc x2))), - (meta_ctyp _loc x3)) - | Ast.ExChr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExChr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExAss (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAss")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExAsr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAsr")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExAsf x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAsf")))))), - (meta_loc _loc x0)) - | Ast.ExSem (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExSem")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExArr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExArr")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExAre (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAre")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExApp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExApp")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.ExAcc (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAcc")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExId (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.ExNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExNil")))))), - (meta_loc _loc x0)) - and meta_ident _loc = - function - | Ast.IdAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.IdUid (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdUid")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.IdLid (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdLid")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.IdApp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdApp")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_ident _loc x2)) - | Ast.IdAcc (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdAcc")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_ident _loc x2)) - and meta_match_case _loc = - function - | Ast.McAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.McArr (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "McArr")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_expr _loc x2))), - (meta_expr _loc x3)) - | Ast.McOr (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "McOr")))))), - (meta_loc _loc x0))), - (meta_match_case _loc x1))), - (meta_match_case _loc x2)) - | Ast.McNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "McNil")))))), - (meta_loc _loc x0)) - and meta_meta_bool _loc = - function - | Ast.BAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.BFalse -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BFalse"))))) - | Ast.BTrue -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BTrue"))))) - and meta_meta_list mf_a _loc = - function - | Ast.LAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.LCons (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "LCons")))))), - (mf_a _loc x0))), - (meta_meta_list mf_a _loc x1)) - | Ast.LNil -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "LNil"))))) - and meta_meta_option mf_a _loc = - function - | Ast.OAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.OSome x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "OSome")))))), - (mf_a _loc x0)) - | Ast.ONone -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ONone"))))) - and meta_module_binding _loc = - function - | Ast.MbAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.MbCol (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbCol")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2)) - | Ast.MbColEq (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbColEq")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2))), - (meta_module_expr _loc x3)) - | Ast.MbAnd (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbAnd")))))), - (meta_loc _loc x0))), - (meta_module_binding _loc x1))), - (meta_module_binding _loc x2)) - | Ast.MbNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbNil")))))), - (meta_loc _loc x0)) - and meta_module_expr _loc = - function - | Ast.MeAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.MePkg (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MePkg")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.MeTyc (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeTyc")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1))), - (meta_module_type _loc x2)) - | Ast.MeStr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeStr")))))), - (meta_loc _loc x0))), - (meta_str_item _loc x1)) - | Ast.MeFun (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeFun")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2))), - (meta_module_expr _loc x3)) - | Ast.MeApp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeApp")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1))), - (meta_module_expr _loc x2)) - | Ast.MeId (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.MeNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeNil")))))), - (meta_loc _loc x0)) - and meta_module_type _loc = - function - | Ast.MtAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.MtOf (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtOf")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1)) - | Ast.MtWit (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtWit")))))), - (meta_loc _loc x0))), - (meta_module_type _loc x1))), - (meta_with_constr _loc x2)) - | Ast.MtSig (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtSig")))))), - (meta_loc _loc x0))), - (meta_sig_item _loc x1)) - | Ast.MtQuo (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtQuo")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.MtFun (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtFun")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2))), - (meta_module_type _loc x3)) - | Ast.MtId (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.MtNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtNil")))))), - (meta_loc _loc x0)) - and meta_mutable_flag _loc = - function - | Ast.MuAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.MuNil -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MuNil"))))) - | Ast.MuMutable -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MuMutable"))))) - and meta_override_flag _loc = - function - | Ast.OvAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.OvNil -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "OvNil"))))) - | Ast.OvOverride -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "OvOverride"))))) - and meta_patt _loc = - function - | Ast.PaMod (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaMod")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaLaz (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaLaz")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1)) - | Ast.PaVrn (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaVrn")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaTyp (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaTyp")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.PaTyc (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaTyc")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_ctyp _loc x2)) - | Ast.PaTup (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaTup")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1)) - | Ast.PaStr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaStr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaEq (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaEq")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_patt _loc x2)) - | Ast.PaRec (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaRec")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1)) - | Ast.PaRng (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaRng")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaOrp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaOrp")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaOlbi (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaOlbi")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_patt _loc x2))), - (meta_expr _loc x3)) - | Ast.PaOlb (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaOlb")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_patt _loc x2)) - | Ast.PaLab (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaLab")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_patt _loc x2)) - | Ast.PaFlo (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaFlo")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaNativeInt (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaNativeInt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaInt64 (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaInt64")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaInt32 (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaInt32")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaInt (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaInt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaChr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaChr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaSem (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaSem")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaCom (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaCom")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaArr (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaArr")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1)) - | Ast.PaApp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaApp")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaAny x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaAny")))))), - (meta_loc _loc x0)) - | Ast.PaAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.PaAli (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaAli")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaId (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.PaNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaNil")))))), - (meta_loc _loc x0)) - and meta_private_flag _loc = - function - | Ast.PrAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.PrNil -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PrNil"))))) - | Ast.PrPrivate -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PrPrivate"))))) - and meta_rec_binding _loc = - function - | Ast.RbAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.RbEq (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RbEq")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_expr _loc x2)) - | Ast.RbSem (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RbSem")))))), - (meta_loc _loc x0))), - (meta_rec_binding _loc x1))), - (meta_rec_binding _loc x2)) - | Ast.RbNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RbNil")))))), - (meta_loc _loc x0)) - and meta_rec_flag _loc = - function - | Ast.ReAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.ReNil -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ReNil"))))) - | Ast.ReRecursive -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ReRecursive"))))) - and meta_row_var_flag _loc = - function - | Ast.RvAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.RvNil -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RvNil"))))) - | Ast.RvRowVar -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RvRowVar"))))) - and meta_sig_item _loc = - function - | Ast.SgAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.SgVal (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgVal")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2)) - | Ast.SgTyp (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgTyp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.SgOpn (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgOpn")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.SgMty (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgMty")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2)) - | Ast.SgRecMod (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgRecMod")))))), - (meta_loc _loc x0))), - (meta_module_binding _loc x1)) - | Ast.SgMod (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgMod")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2)) - | Ast.SgInc (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgInc")))))), - (meta_loc _loc x0))), - (meta_module_type _loc x1)) - | Ast.SgExt (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgExt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2))), - (meta_meta_list meta_string _loc x3)) - | Ast.SgExc (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgExc")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.SgDir (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgDir")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.SgSem (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgSem")))))), - (meta_loc _loc x0))), - (meta_sig_item _loc x1))), - (meta_sig_item _loc x2)) - | Ast.SgClt (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgClt")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1)) - | Ast.SgCls (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgCls")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1)) - | Ast.SgNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgNil")))))), - (meta_loc _loc x0)) - and meta_str_item _loc = - function - | Ast.StAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.StVal (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StVal")))))), - (meta_loc _loc x0))), - (meta_rec_flag _loc x1))), - (meta_binding _loc x2)) - | Ast.StTyp (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StTyp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.StOpn (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StOpn")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.StMty (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StMty")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2)) - | Ast.StRecMod (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StRecMod")))))), - (meta_loc _loc x0))), - (meta_module_binding _loc x1)) - | Ast.StMod (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StMod")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_expr _loc x2)) - | Ast.StInc (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StInc")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1)) - | Ast.StExt (x0, x1, x2, x3) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StExt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2))), - (meta_meta_list meta_string _loc x3)) - | Ast.StExp (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StExp")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.StExc (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StExc")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_meta_option meta_ident _loc x2)) - | Ast.StDir (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StDir")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.StSem (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StSem")))))), - (meta_loc _loc x0))), - (meta_str_item _loc x1))), - (meta_str_item _loc x2)) - | Ast.StClt (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StClt")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1)) - | Ast.StCls (x0, x1) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StCls")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1)) - | Ast.StNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StNil")))))), - (meta_loc _loc x0)) - and meta_virtual_flag _loc = - function - | Ast.ViAnt x0 -> Ast.ExAnt (_loc, x0) - | Ast.ViNil -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ViNil"))))) - | Ast.ViVirtual -> - Ast.ExId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ViVirtual"))))) - and meta_with_constr _loc = - function - | Ast.WcAnt (x0, x1) -> Ast.ExAnt (x0, x1) - | Ast.WcAnd (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcAnd")))))), - (meta_loc _loc x0))), - (meta_with_constr _loc x1))), - (meta_with_constr _loc x2)) - | Ast.WcMoS (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcMoS")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_ident _loc x2)) - | Ast.WcTyS (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcTyS")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.WcMod (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcMod")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_ident _loc x2)) - | Ast.WcTyp (x0, x1, x2) -> - Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcTyp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.WcNil x0 -> - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcNil")))))), - (meta_loc _loc x0)) - - end - - let meta_loc = meta_loc_patt - - module Patt = - struct - let meta_string _loc s = - Ast.PaStr (_loc, (safe_string_escaped s)) - - let meta_int _loc s = Ast.PaInt (_loc, s) - - let meta_float _loc s = Ast.PaFlo (_loc, s) - - let meta_char _loc s = - Ast.PaChr (_loc, (String.escaped s)) - - let meta_bool _loc = - function - | false -> - Ast.PaId (_loc, (Ast.IdUid (_loc, "False"))) - | true -> - Ast.PaId (_loc, (Ast.IdUid (_loc, "True"))) - - let rec meta_list mf_a _loc = - function - | [] -> Ast.PaId (_loc, (Ast.IdUid (_loc, "[]"))) - | x :: xs -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, (Ast.IdUid (_loc, "::")))), - (mf_a _loc x))), - (meta_list mf_a _loc xs)) - - let rec meta_binding _loc = - function - | Ast.BiAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.BiEq (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BiEq")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_expr _loc x2)) - | Ast.BiAnd (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BiAnd")))))), - (meta_loc _loc x0))), - (meta_binding _loc x1))), - (meta_binding _loc x2)) - | Ast.BiNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BiNil")))))), - (meta_loc _loc x0)) - and meta_class_expr _loc = - function - | Ast.CeAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.CeEq (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeEq")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1))), - (meta_class_expr _loc x2)) - | Ast.CeAnd (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeAnd")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1))), - (meta_class_expr _loc x2)) - | Ast.CeTyc (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeTyc")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1))), - (meta_class_type _loc x2)) - | Ast.CeStr (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeStr")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_class_str_item _loc x2)) - | Ast.CeLet (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeLet")))))), - (meta_loc _loc x0))), - (meta_rec_flag _loc x1))), - (meta_binding _loc x2))), - (meta_class_expr _loc x3)) - | Ast.CeFun (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeFun")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_class_expr _loc x2)) - | Ast.CeCon (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeCon")))))), - (meta_loc _loc x0))), - (meta_virtual_flag _loc x1))), - (meta_ident _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CeApp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeApp")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.CeNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CeNil")))))), - (meta_loc _loc x0)) - and meta_class_sig_item _loc = - function - | Ast.CgAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.CgVir (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgVir")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_private_flag _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CgVal (x0, x1, x2, x3, x4) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgVal")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_mutable_flag _loc x2))), - (meta_virtual_flag _loc x3))), - (meta_ctyp _loc x4)) - | Ast.CgMth (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgMth")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_private_flag _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CgInh (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgInh")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1)) - | Ast.CgSem (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgSem")))))), - (meta_loc _loc x0))), - (meta_class_sig_item _loc x1))), - (meta_class_sig_item _loc x2)) - | Ast.CgCtr (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgCtr")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.CgNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CgNil")))))), - (meta_loc _loc x0)) - and meta_class_str_item _loc = - function - | Ast.CrAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.CrVvr (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrVvr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_mutable_flag _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CrVir (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrVir")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_private_flag _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CrVal (x0, x1, x2, x3, x4) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrVal")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_override_flag _loc x2))), - (meta_mutable_flag _loc x3))), - (meta_expr _loc x4)) - | Ast.CrMth (x0, x1, x2, x3, x4, x5) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, - "CrMth")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_override_flag _loc x2))), - (meta_private_flag _loc x3))), - (meta_expr _loc x4))), - (meta_ctyp _loc x5)) - | Ast.CrIni (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrIni")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.CrInh (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrInh")))))), - (meta_loc _loc x0))), - (meta_override_flag _loc x1))), - (meta_class_expr _loc x2))), - (meta_string _loc x3)) - | Ast.CrCtr (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrCtr")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.CrSem (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrSem")))))), - (meta_loc _loc x0))), - (meta_class_str_item _loc x1))), - (meta_class_str_item _loc x2)) - | Ast.CrNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CrNil")))))), - (meta_loc _loc x0)) - and meta_class_type _loc = - function - | Ast.CtAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.CtEq (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtEq")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1))), - (meta_class_type _loc x2)) - | Ast.CtCol (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtCol")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1))), - (meta_class_type _loc x2)) - | Ast.CtAnd (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtAnd")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1))), - (meta_class_type _loc x2)) - | Ast.CtSig (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtSig")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_class_sig_item _loc x2)) - | Ast.CtFun (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtFun")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_class_type _loc x2)) - | Ast.CtCon (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtCon")))))), - (meta_loc _loc x0))), - (meta_virtual_flag _loc x1))), - (meta_ident _loc x2))), - (meta_ctyp _loc x3)) - | Ast.CtNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "CtNil")))))), - (meta_loc _loc x0)) - and meta_ctyp _loc = - function - | Ast.TyAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.TyPkg (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyPkg")))))), - (meta_loc _loc x0))), - (meta_module_type _loc x1)) - | Ast.TyOfAmp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyOfAmp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyAmp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAmp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyVrnInfSup (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrnInfSup")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyVrnInf (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrnInf")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyVrnSup (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrnSup")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyVrnEq (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrnEq")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TySta (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TySta")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyTup (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyTup")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyMut (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyMut")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyPrv (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyPrv")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyOr (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyOr")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyAnd (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAnd")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyOf (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyOf")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TySum (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TySum")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyCom (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyCom")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TySem (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TySem")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyCol (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyCol")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyRec (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyRec")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.TyVrn (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyVrn")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.TyAnM x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAnM")))))), - (meta_loc _loc x0)) - | Ast.TyAnP x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAnP")))))), - (meta_loc _loc x0)) - | Ast.TyQuM (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyQuM")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.TyQuP (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyQuP")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.TyQuo (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyQuo")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.TyTypePol (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyTypePol")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyPol (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyPol")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyOlb (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyOlb")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyObj (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyObj")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_row_var_flag _loc x2)) - | Ast.TyDcl (x0, x1, x2, x3, x4) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyDcl")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_list meta_ctyp _loc x2))), - (meta_ctyp _loc x3))), - (meta_list - (fun _loc (x1, x2) -> - Ast.PaTup (_loc, - (Ast.PaCom (_loc, - (meta_ctyp _loc x1), - (meta_ctyp _loc x2))))) - _loc x4)) - | Ast.TyMan (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyMan")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyId (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.TyLab (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyLab")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyCls (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyCls")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.TyArr (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyArr")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyApp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyApp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyAny x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAny")))))), - (meta_loc _loc x0)) - | Ast.TyAli (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyAli")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.TyNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "TyNil")))))), - (meta_loc _loc x0)) - and meta_direction_flag _loc = - function - | Ast.DiAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.DiDownto -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "DiDownto"))))) - | Ast.DiTo -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "DiTo"))))) - and meta_expr _loc = - function - | Ast.ExPkg (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExPkg")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1)) - | Ast.ExFUN (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExFUN")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.ExOpI (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExOpI")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_expr _loc x2)) - | Ast.ExWhi (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExWhi")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExVrn (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExVrn")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExTyc (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExTyc")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_ctyp _loc x2)) - | Ast.ExCom (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExCom")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExTup (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExTup")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExTry (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExTry")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_match_case _loc x2)) - | Ast.ExStr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExStr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExSte (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExSte")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExSnd (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExSnd")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_string _loc x2)) - | Ast.ExSeq (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExSeq")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExRec (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExRec")))))), - (meta_loc _loc x0))), - (meta_rec_binding _loc x1))), - (meta_expr _loc x2)) - | Ast.ExOvr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExOvr")))))), - (meta_loc _loc x0))), - (meta_rec_binding _loc x1)) - | Ast.ExOlb (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExOlb")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.ExObj (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExObj")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_class_str_item _loc x2)) - | Ast.ExNew (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExNew")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.ExMat (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExMat")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_match_case _loc x2)) - | Ast.ExLmd (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExLmd")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_expr _loc x2))), - (meta_expr _loc x3)) - | Ast.ExLet (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExLet")))))), - (meta_loc _loc x0))), - (meta_rec_flag _loc x1))), - (meta_binding _loc x2))), - (meta_expr _loc x3)) - | Ast.ExLaz (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExLaz")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExLab (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExLab")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.ExNativeInt (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExNativeInt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExInt64 (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExInt64")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExInt32 (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExInt32")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExInt (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExInt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExIfe (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExIfe")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2))), - (meta_expr _loc x3)) - | Ast.ExFun (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExFun")))))), - (meta_loc _loc x0))), - (meta_match_case _loc x1)) - | Ast.ExFor (x0, x1, x2, x3, x4, x5) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, - "ExFor")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2))), - (meta_expr _loc x3))), - (meta_direction_flag _loc x4))), - (meta_expr _loc x5)) - | Ast.ExFlo (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExFlo")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExCoe (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExCoe")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_ctyp _loc x2))), - (meta_ctyp _loc x3)) - | Ast.ExChr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExChr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.ExAss (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAss")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExAsr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAsr")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExAsf x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAsf")))))), - (meta_loc _loc x0)) - | Ast.ExSem (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExSem")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExArr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExArr")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.ExAre (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAre")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExApp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExApp")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.ExAcc (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExAcc")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1))), - (meta_expr _loc x2)) - | Ast.ExId (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.ExNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ExNil")))))), - (meta_loc _loc x0)) - and meta_ident _loc = - function - | Ast.IdAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.IdUid (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdUid")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.IdLid (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdLid")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.IdApp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdApp")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_ident _loc x2)) - | Ast.IdAcc (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "IdAcc")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_ident _loc x2)) - and meta_match_case _loc = - function - | Ast.McAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.McArr (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "McArr")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_expr _loc x2))), - (meta_expr _loc x3)) - | Ast.McOr (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "McOr")))))), - (meta_loc _loc x0))), - (meta_match_case _loc x1))), - (meta_match_case _loc x2)) - | Ast.McNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "McNil")))))), - (meta_loc _loc x0)) - and meta_meta_bool _loc = - function - | Ast.BAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.BFalse -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BFalse"))))) - | Ast.BTrue -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "BTrue"))))) - and meta_meta_list mf_a _loc = - function - | Ast.LAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.LCons (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "LCons")))))), - (mf_a _loc x0))), - (meta_meta_list mf_a _loc x1)) - | Ast.LNil -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "LNil"))))) - and meta_meta_option mf_a _loc = - function - | Ast.OAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.OSome x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "OSome")))))), - (mf_a _loc x0)) - | Ast.ONone -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ONone"))))) - and meta_module_binding _loc = - function - | Ast.MbAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.MbCol (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbCol")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2)) - | Ast.MbColEq (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbColEq")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2))), - (meta_module_expr _loc x3)) - | Ast.MbAnd (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbAnd")))))), - (meta_loc _loc x0))), - (meta_module_binding _loc x1))), - (meta_module_binding _loc x2)) - | Ast.MbNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MbNil")))))), - (meta_loc _loc x0)) - and meta_module_expr _loc = - function - | Ast.MeAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.MePkg (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MePkg")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.MeTyc (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeTyc")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1))), - (meta_module_type _loc x2)) - | Ast.MeStr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeStr")))))), - (meta_loc _loc x0))), - (meta_str_item _loc x1)) - | Ast.MeFun (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeFun")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2))), - (meta_module_expr _loc x3)) - | Ast.MeApp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeApp")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1))), - (meta_module_expr _loc x2)) - | Ast.MeId (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.MeNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MeNil")))))), - (meta_loc _loc x0)) - and meta_module_type _loc = - function - | Ast.MtAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.MtOf (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtOf")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1)) - | Ast.MtWit (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtWit")))))), - (meta_loc _loc x0))), - (meta_module_type _loc x1))), - (meta_with_constr _loc x2)) - | Ast.MtSig (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtSig")))))), - (meta_loc _loc x0))), - (meta_sig_item _loc x1)) - | Ast.MtQuo (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtQuo")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.MtFun (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtFun")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2))), - (meta_module_type _loc x3)) - | Ast.MtId (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.MtNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MtNil")))))), - (meta_loc _loc x0)) - and meta_mutable_flag _loc = - function - | Ast.MuAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.MuNil -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MuNil"))))) - | Ast.MuMutable -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "MuMutable"))))) - and meta_override_flag _loc = - function - | Ast.OvAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.OvNil -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "OvNil"))))) - | Ast.OvOverride -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "OvOverride"))))) - and meta_patt _loc = - function - | Ast.PaMod (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaMod")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaLaz (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaLaz")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1)) - | Ast.PaVrn (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaVrn")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaTyp (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaTyp")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.PaTyc (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaTyc")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_ctyp _loc x2)) - | Ast.PaTup (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaTup")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1)) - | Ast.PaStr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaStr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaEq (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaEq")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_patt _loc x2)) - | Ast.PaRec (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaRec")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1)) - | Ast.PaRng (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaRng")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaOrp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaOrp")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaOlbi (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaOlbi")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_patt _loc x2))), - (meta_expr _loc x3)) - | Ast.PaOlb (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaOlb")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_patt _loc x2)) - | Ast.PaLab (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaLab")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_patt _loc x2)) - | Ast.PaFlo (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaFlo")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaNativeInt (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaNativeInt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaInt64 (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaInt64")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaInt32 (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaInt32")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaInt (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaInt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaChr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaChr")))))), - (meta_loc _loc x0))), - (meta_string _loc x1)) - | Ast.PaSem (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaSem")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaCom (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaCom")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaArr (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaArr")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1)) - | Ast.PaApp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaApp")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaAny x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaAny")))))), - (meta_loc _loc x0)) - | Ast.PaAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.PaAli (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaAli")))))), - (meta_loc _loc x0))), - (meta_patt _loc x1))), - (meta_patt _loc x2)) - | Ast.PaId (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaId")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.PaNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PaNil")))))), - (meta_loc _loc x0)) - and meta_private_flag _loc = - function - | Ast.PrAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.PrNil -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PrNil"))))) - | Ast.PrPrivate -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "PrPrivate"))))) - and meta_rec_binding _loc = - function - | Ast.RbAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.RbEq (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RbEq")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_expr _loc x2)) - | Ast.RbSem (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RbSem")))))), - (meta_loc _loc x0))), - (meta_rec_binding _loc x1))), - (meta_rec_binding _loc x2)) - | Ast.RbNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RbNil")))))), - (meta_loc _loc x0)) - and meta_rec_flag _loc = - function - | Ast.ReAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.ReNil -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ReNil"))))) - | Ast.ReRecursive -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ReRecursive"))))) - and meta_row_var_flag _loc = - function - | Ast.RvAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.RvNil -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RvNil"))))) - | Ast.RvRowVar -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "RvRowVar"))))) - and meta_sig_item _loc = - function - | Ast.SgAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.SgVal (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgVal")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2)) - | Ast.SgTyp (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgTyp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.SgOpn (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgOpn")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.SgMty (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgMty")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2)) - | Ast.SgRecMod (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgRecMod")))))), - (meta_loc _loc x0))), - (meta_module_binding _loc x1)) - | Ast.SgMod (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgMod")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2)) - | Ast.SgInc (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgInc")))))), - (meta_loc _loc x0))), - (meta_module_type _loc x1)) - | Ast.SgExt (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgExt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2))), - (meta_meta_list meta_string _loc x3)) - | Ast.SgExc (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgExc")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.SgDir (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgDir")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.SgSem (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgSem")))))), - (meta_loc _loc x0))), - (meta_sig_item _loc x1))), - (meta_sig_item _loc x2)) - | Ast.SgClt (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgClt")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1)) - | Ast.SgCls (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgCls")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1)) - | Ast.SgNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "SgNil")))))), - (meta_loc _loc x0)) - and meta_str_item _loc = - function - | Ast.StAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.StVal (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StVal")))))), - (meta_loc _loc x0))), - (meta_rec_flag _loc x1))), - (meta_binding _loc x2)) - | Ast.StTyp (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StTyp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1)) - | Ast.StOpn (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StOpn")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1)) - | Ast.StMty (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StMty")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_type _loc x2)) - | Ast.StRecMod (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StRecMod")))))), - (meta_loc _loc x0))), - (meta_module_binding _loc x1)) - | Ast.StMod (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StMod")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_module_expr _loc x2)) - | Ast.StInc (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StInc")))))), - (meta_loc _loc x0))), - (meta_module_expr _loc x1)) - | Ast.StExt (x0, x1, x2, x3) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StExt")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_ctyp _loc x2))), - (meta_meta_list meta_string _loc x3)) - | Ast.StExp (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StExp")))))), - (meta_loc _loc x0))), - (meta_expr _loc x1)) - | Ast.StExc (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StExc")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_meta_option meta_ident _loc x2)) - | Ast.StDir (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StDir")))))), - (meta_loc _loc x0))), - (meta_string _loc x1))), - (meta_expr _loc x2)) - | Ast.StSem (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StSem")))))), - (meta_loc _loc x0))), - (meta_str_item _loc x1))), - (meta_str_item _loc x2)) - | Ast.StClt (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StClt")))))), - (meta_loc _loc x0))), - (meta_class_type _loc x1)) - | Ast.StCls (x0, x1) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StCls")))))), - (meta_loc _loc x0))), - (meta_class_expr _loc x1)) - | Ast.StNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "StNil")))))), - (meta_loc _loc x0)) - and meta_virtual_flag _loc = - function - | Ast.ViAnt x0 -> Ast.PaAnt (_loc, x0) - | Ast.ViNil -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ViNil"))))) - | Ast.ViVirtual -> - Ast.PaId (_loc, - (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "ViVirtual"))))) - and meta_with_constr _loc = - function - | Ast.WcAnt (x0, x1) -> Ast.PaAnt (x0, x1) - | Ast.WcAnd (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcAnd")))))), - (meta_loc _loc x0))), - (meta_with_constr _loc x1))), - (meta_with_constr _loc x2)) - | Ast.WcMoS (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcMoS")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_ident _loc x2)) - | Ast.WcTyS (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcTyS")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.WcMod (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcMod")))))), - (meta_loc _loc x0))), - (meta_ident _loc x1))), - (meta_ident _loc x2)) - | Ast.WcTyp (x0, x1, x2) -> - Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcTyp")))))), - (meta_loc _loc x0))), - (meta_ctyp _loc x1))), - (meta_ctyp _loc x2)) - | Ast.WcNil x0 -> - Ast.PaApp (_loc, - (Ast.PaId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Ast")), - (Ast.IdUid (_loc, "WcNil")))))), - (meta_loc _loc x0)) - - end - - end - - end - - class map = - object ((o : 'self_type)) - method string : string -> string = o#unknown - method list : - 'a 'a_out. - ('self_type -> 'a -> 'a_out) -> 'a list -> 'a_out list = - fun _f_a -> - function - | [] -> [] - | _x :: _x_i1 -> - let _x = _f_a o _x in - let _x_i1 = o#list _f_a _x_i1 in _x :: _x_i1 - method with_constr : with_constr -> with_constr = - function - | WcNil _x -> let _x = o#loc _x in WcNil _x - | WcTyp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in WcTyp (_x, _x_i1, _x_i2) - | WcMod (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#ident _x_i2 in WcMod (_x, _x_i1, _x_i2) - | WcTyS (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in WcTyS (_x, _x_i1, _x_i2) - | WcMoS (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#ident _x_i2 in WcMoS (_x, _x_i1, _x_i2) - | WcAnd (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#with_constr _x_i1 in - let _x_i2 = o#with_constr _x_i2 - in WcAnd (_x, _x_i1, _x_i2) - | WcAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in WcAnt (_x, _x_i1) - method virtual_flag : virtual_flag -> virtual_flag = - function - | ViVirtual -> ViVirtual - | ViNil -> ViNil - | ViAnt _x -> let _x = o#string _x in ViAnt _x - method str_item : str_item -> str_item = - function - | StNil _x -> let _x = o#loc _x in StNil _x - | StCls (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in StCls (_x, _x_i1) - | StClt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in StClt (_x, _x_i1) - | StSem (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#str_item _x_i1 in - let _x_i2 = o#str_item _x_i2 - in StSem (_x, _x_i1, _x_i2) - | StDir (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in StDir (_x, _x_i1, _x_i2) - | StExc (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#meta_option (fun o -> o#ident) _x_i2 - in StExc (_x, _x_i1, _x_i2) - | StExp (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in StExp (_x, _x_i1) - | StExt (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in - let _x_i3 = o#meta_list (fun o -> o#string) _x_i3 - in StExt (_x, _x_i1, _x_i2, _x_i3) - | StInc (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in StInc (_x, _x_i1) - | StMod (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_expr _x_i2 - in StMod (_x, _x_i1, _x_i2) - | StRecMod (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#module_binding _x_i1 - in StRecMod (_x, _x_i1) - | StMty (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 - in StMty (_x, _x_i1, _x_i2) - | StOpn (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in StOpn (_x, _x_i1) - | StTyp (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in StTyp (_x, _x_i1) - | StVal (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#rec_flag _x_i1 in - let _x_i2 = o#binding _x_i2 in StVal (_x, _x_i1, _x_i2) - | StAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in StAnt (_x, _x_i1) - method sig_item : sig_item -> sig_item = - function - | SgNil _x -> let _x = o#loc _x in SgNil _x - | SgCls (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in SgCls (_x, _x_i1) - | SgClt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in SgClt (_x, _x_i1) - | SgSem (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#sig_item _x_i1 in - let _x_i2 = o#sig_item _x_i2 - in SgSem (_x, _x_i1, _x_i2) - | SgDir (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in SgDir (_x, _x_i1, _x_i2) - | SgExc (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in SgExc (_x, _x_i1) - | SgExt (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in - let _x_i3 = o#meta_list (fun o -> o#string) _x_i3 - in SgExt (_x, _x_i1, _x_i2, _x_i3) - | SgInc (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#module_type _x_i1 in SgInc (_x, _x_i1) - | SgMod (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 - in SgMod (_x, _x_i1, _x_i2) - | SgRecMod (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#module_binding _x_i1 - in SgRecMod (_x, _x_i1) - | SgMty (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 - in SgMty (_x, _x_i1, _x_i2) - | SgOpn (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in SgOpn (_x, _x_i1) - | SgTyp (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in SgTyp (_x, _x_i1) - | SgVal (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in SgVal (_x, _x_i1, _x_i2) - | SgAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in SgAnt (_x, _x_i1) - method row_var_flag : row_var_flag -> row_var_flag = - function - | RvRowVar -> RvRowVar - | RvNil -> RvNil - | RvAnt _x -> let _x = o#string _x in RvAnt _x - method rec_flag : rec_flag -> rec_flag = - function - | ReRecursive -> ReRecursive - | ReNil -> ReNil - | ReAnt _x -> let _x = o#string _x in ReAnt _x - method rec_binding : rec_binding -> rec_binding = - function - | RbNil _x -> let _x = o#loc _x in RbNil _x - | RbSem (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#rec_binding _x_i1 in - let _x_i2 = o#rec_binding _x_i2 - in RbSem (_x, _x_i1, _x_i2) - | RbEq (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#expr _x_i2 in RbEq (_x, _x_i1, _x_i2) - | RbAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in RbAnt (_x, _x_i1) - method private_flag : private_flag -> private_flag = - function - | PrPrivate -> PrPrivate - | PrNil -> PrNil - | PrAnt _x -> let _x = o#string _x in PrAnt _x - method patt : patt -> patt = - function - | PaNil _x -> let _x = o#loc _x in PaNil _x - | PaId (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in PaId (_x, _x_i1) - | PaAli (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaAli (_x, _x_i1, _x_i2) - | PaAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaAnt (_x, _x_i1) - | PaAny _x -> let _x = o#loc _x in PaAny _x - | PaApp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaApp (_x, _x_i1, _x_i2) - | PaArr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in PaArr (_x, _x_i1) - | PaCom (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaCom (_x, _x_i1, _x_i2) - | PaSem (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaSem (_x, _x_i1, _x_i2) - | PaChr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaChr (_x, _x_i1) - | PaInt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaInt (_x, _x_i1) - | PaInt32 (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaInt32 (_x, _x_i1) - | PaInt64 (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaInt64 (_x, _x_i1) - | PaNativeInt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaNativeInt (_x, _x_i1) - | PaFlo (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaFlo (_x, _x_i1) - | PaLab (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#patt _x_i2 in PaLab (_x, _x_i1, _x_i2) - | PaOlb (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#patt _x_i2 in PaOlb (_x, _x_i1, _x_i2) - | PaOlbi (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#patt _x_i2 in - let _x_i3 = o#expr _x_i3 - in PaOlbi (_x, _x_i1, _x_i2, _x_i3) - | PaOrp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaOrp (_x, _x_i1, _x_i2) - | PaRng (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#patt _x_i2 in PaRng (_x, _x_i1, _x_i2) - | PaRec (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in PaRec (_x, _x_i1) - | PaEq (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#patt _x_i2 in PaEq (_x, _x_i1, _x_i2) - | PaStr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaStr (_x, _x_i1) - | PaTup (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in PaTup (_x, _x_i1) - | PaTyc (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#ctyp _x_i2 in PaTyc (_x, _x_i1, _x_i2) - | PaTyp (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in PaTyp (_x, _x_i1) - | PaVrn (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaVrn (_x, _x_i1) - | PaLaz (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in PaLaz (_x, _x_i1) - | PaMod (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaMod (_x, _x_i1) - method override_flag : override_flag -> override_flag = - function - | OvOverride -> OvOverride - | OvNil -> OvNil - | OvAnt _x -> let _x = o#string _x in OvAnt _x - method mutable_flag : mutable_flag -> mutable_flag = - function - | MuMutable -> MuMutable - | MuNil -> MuNil - | MuAnt _x -> let _x = o#string _x in MuAnt _x - method module_type : module_type -> module_type = - function - | MtNil _x -> let _x = o#loc _x in MtNil _x - | MtId (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in MtId (_x, _x_i1) - | MtFun (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in - let _x_i3 = o#module_type _x_i3 - in MtFun (_x, _x_i1, _x_i2, _x_i3) - | MtQuo (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in MtQuo (_x, _x_i1) - | MtSig (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#sig_item _x_i1 in MtSig (_x, _x_i1) - | MtWit (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#module_type _x_i1 in - let _x_i2 = o#with_constr _x_i2 - in MtWit (_x, _x_i1, _x_i2) - | MtOf (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in MtOf (_x, _x_i1) - | MtAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in MtAnt (_x, _x_i1) - method module_expr : module_expr -> module_expr = - function - | MeNil _x -> let _x = o#loc _x in MeNil _x - | MeId (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in MeId (_x, _x_i1) - | MeApp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in - let _x_i2 = o#module_expr _x_i2 - in MeApp (_x, _x_i1, _x_i2) - | MeFun (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in - let _x_i3 = o#module_expr _x_i3 - in MeFun (_x, _x_i1, _x_i2, _x_i3) - | MeStr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#str_item _x_i1 in MeStr (_x, _x_i1) - | MeTyc (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in - let _x_i2 = o#module_type _x_i2 - in MeTyc (_x, _x_i1, _x_i2) - | MePkg (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in MePkg (_x, _x_i1) - | MeAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in MeAnt (_x, _x_i1) - method module_binding : module_binding -> module_binding = - function - | MbNil _x -> let _x = o#loc _x in MbNil _x - | MbAnd (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#module_binding _x_i1 in - let _x_i2 = o#module_binding _x_i2 - in MbAnd (_x, _x_i1, _x_i2) - | MbColEq (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 in - let _x_i3 = o#module_expr _x_i3 - in MbColEq (_x, _x_i1, _x_i2, _x_i3) - | MbCol (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_type _x_i2 - in MbCol (_x, _x_i1, _x_i2) - | MbAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in MbAnt (_x, _x_i1) - method meta_option : - 'a 'a_out. - ('self_type -> 'a -> 'a_out) -> - 'a meta_option -> 'a_out meta_option = - fun _f_a -> - function - | ONone -> ONone - | OSome _x -> let _x = _f_a o _x in OSome _x - | OAnt _x -> let _x = o#string _x in OAnt _x - method meta_list : - 'a 'a_out. - ('self_type -> 'a -> 'a_out) -> - 'a meta_list -> 'a_out meta_list = - fun _f_a -> - function - | LNil -> LNil - | LCons (_x, _x_i1) -> - let _x = _f_a o _x in - let _x_i1 = o#meta_list _f_a _x_i1 - in LCons (_x, _x_i1) - | LAnt _x -> let _x = o#string _x in LAnt _x - method meta_bool : meta_bool -> meta_bool = - function - | BTrue -> BTrue - | BFalse -> BFalse - | BAnt _x -> let _x = o#string _x in BAnt _x - method match_case : match_case -> match_case = - function - | McNil _x -> let _x = o#loc _x in McNil _x - | McOr (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#match_case _x_i1 in - let _x_i2 = o#match_case _x_i2 - in McOr (_x, _x_i1, _x_i2) - | McArr (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#expr _x_i2 in - let _x_i3 = o#expr _x_i3 - in McArr (_x, _x_i1, _x_i2, _x_i3) - | McAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in McAnt (_x, _x_i1) - method loc : loc -> loc = o#unknown - method ident : ident -> ident = - function - | IdAcc (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#ident _x_i2 in IdAcc (_x, _x_i1, _x_i2) - | IdApp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#ident _x_i2 in IdApp (_x, _x_i1, _x_i2) - | IdLid (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in IdLid (_x, _x_i1) - | IdUid (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in IdUid (_x, _x_i1) - | IdAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in IdAnt (_x, _x_i1) - method expr : expr -> expr = - function - | ExNil _x -> let _x = o#loc _x in ExNil _x - | ExId (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in ExId (_x, _x_i1) - | ExAcc (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExAcc (_x, _x_i1, _x_i2) - | ExAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExAnt (_x, _x_i1) - | ExApp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExApp (_x, _x_i1, _x_i2) - | ExAre (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExAre (_x, _x_i1, _x_i2) - | ExArr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in ExArr (_x, _x_i1) - | ExSem (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExSem (_x, _x_i1, _x_i2) - | ExAsf _x -> let _x = o#loc _x in ExAsf _x - | ExAsr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in ExAsr (_x, _x_i1) - | ExAss (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExAss (_x, _x_i1, _x_i2) - | ExChr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExChr (_x, _x_i1) - | ExCoe (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#ctyp _x_i2 in - let _x_i3 = o#ctyp _x_i3 - in ExCoe (_x, _x_i1, _x_i2, _x_i3) - | ExFlo (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExFlo (_x, _x_i1) - | ExFor (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in - let _x_i3 = o#expr _x_i3 in - let _x_i4 = o#direction_flag _x_i4 in - let _x_i5 = o#expr _x_i5 - in ExFor (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) - | ExFun (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#match_case _x_i1 in ExFun (_x, _x_i1) - | ExIfe (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in - let _x_i3 = o#expr _x_i3 - in ExIfe (_x, _x_i1, _x_i2, _x_i3) - | ExInt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExInt (_x, _x_i1) - | ExInt32 (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExInt32 (_x, _x_i1) - | ExInt64 (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExInt64 (_x, _x_i1) - | ExNativeInt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExNativeInt (_x, _x_i1) - | ExLab (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in ExLab (_x, _x_i1, _x_i2) - | ExLaz (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in ExLaz (_x, _x_i1) - | ExLet (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#rec_flag _x_i1 in - let _x_i2 = o#binding _x_i2 in - let _x_i3 = o#expr _x_i3 - in ExLet (_x, _x_i1, _x_i2, _x_i3) - | ExLmd (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#module_expr _x_i2 in - let _x_i3 = o#expr _x_i3 - in ExLmd (_x, _x_i1, _x_i2, _x_i3) - | ExMat (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#match_case _x_i2 - in ExMat (_x, _x_i1, _x_i2) - | ExNew (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in ExNew (_x, _x_i1) - | ExObj (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#class_str_item _x_i2 - in ExObj (_x, _x_i1, _x_i2) - | ExOlb (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in ExOlb (_x, _x_i1, _x_i2) - | ExOvr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#rec_binding _x_i1 in ExOvr (_x, _x_i1) - | ExRec (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#rec_binding _x_i1 in - let _x_i2 = o#expr _x_i2 in ExRec (_x, _x_i1, _x_i2) - | ExSeq (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in ExSeq (_x, _x_i1) - | ExSnd (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#string _x_i2 in ExSnd (_x, _x_i1, _x_i2) - | ExSte (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExSte (_x, _x_i1, _x_i2) - | ExStr (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExStr (_x, _x_i1) - | ExTry (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#match_case _x_i2 - in ExTry (_x, _x_i1, _x_i2) - | ExTup (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in ExTup (_x, _x_i1) - | ExCom (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExCom (_x, _x_i1, _x_i2) - | ExTyc (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#ctyp _x_i2 in ExTyc (_x, _x_i1, _x_i2) - | ExVrn (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in ExVrn (_x, _x_i1) - | ExWhi (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in - let _x_i2 = o#expr _x_i2 in ExWhi (_x, _x_i1, _x_i2) - | ExOpI (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in - let _x_i2 = o#expr _x_i2 in ExOpI (_x, _x_i1, _x_i2) - | ExFUN (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#expr _x_i2 in ExFUN (_x, _x_i1, _x_i2) - | ExPkg (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#module_expr _x_i1 in ExPkg (_x, _x_i1) - method direction_flag : direction_flag -> direction_flag = - function - | DiTo -> DiTo - | DiDownto -> DiDownto - | DiAnt _x -> let _x = o#string _x in DiAnt _x - method ctyp : ctyp -> ctyp = - function - | TyNil _x -> let _x = o#loc _x in TyNil _x - | TyAli (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyAli (_x, _x_i1, _x_i2) - | TyAny _x -> let _x = o#loc _x in TyAny _x - | TyApp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyApp (_x, _x_i1, _x_i2) - | TyArr (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyArr (_x, _x_i1, _x_i2) - | TyCls (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in TyCls (_x, _x_i1) - | TyLab (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyLab (_x, _x_i1, _x_i2) - | TyId (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ident _x_i1 in TyId (_x, _x_i1) - | TyMan (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyMan (_x, _x_i1, _x_i2) - | TyDcl (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#list (fun o -> o#ctyp) _x_i2 in - let _x_i3 = o#ctyp _x_i3 in - let _x_i4 = - o#list - (fun o (_x, _x_i1) -> - let _x = o#ctyp _x in - let _x_i1 = o#ctyp _x_i1 in (_x, _x_i1)) - _x_i4 - in TyDcl (_x, _x_i1, _x_i2, _x_i3, _x_i4) - | TyObj (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#row_var_flag _x_i2 - in TyObj (_x, _x_i1, _x_i2) - | TyOlb (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyOlb (_x, _x_i1, _x_i2) - | TyPol (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyPol (_x, _x_i1, _x_i2) - | TyTypePol (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 - in TyTypePol (_x, _x_i1, _x_i2) - | TyQuo (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyQuo (_x, _x_i1) - | TyQuP (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyQuP (_x, _x_i1) - | TyQuM (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyQuM (_x, _x_i1) - | TyAnP _x -> let _x = o#loc _x in TyAnP _x - | TyAnM _x -> let _x = o#loc _x in TyAnM _x - | TyVrn (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyVrn (_x, _x_i1) - | TyRec (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyRec (_x, _x_i1) - | TyCol (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyCol (_x, _x_i1, _x_i2) - | TySem (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TySem (_x, _x_i1, _x_i2) - | TyCom (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyCom (_x, _x_i1, _x_i2) - | TySum (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TySum (_x, _x_i1) - | TyOf (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyOf (_x, _x_i1, _x_i2) - | TyAnd (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyAnd (_x, _x_i1, _x_i2) - | TyOr (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyOr (_x, _x_i1, _x_i2) - | TyPrv (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyPrv (_x, _x_i1) - | TyMut (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyMut (_x, _x_i1) - | TyTup (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyTup (_x, _x_i1) - | TySta (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TySta (_x, _x_i1, _x_i2) - | TyVrnEq (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyVrnEq (_x, _x_i1) - | TyVrnSup (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyVrnSup (_x, _x_i1) - | TyVrnInf (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in TyVrnInf (_x, _x_i1) - | TyVrnInfSup (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 - in TyVrnInfSup (_x, _x_i1, _x_i2) - | TyAmp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyAmp (_x, _x_i1, _x_i2) - | TyOfAmp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in TyOfAmp (_x, _x_i1, _x_i2) - | TyPkg (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#module_type _x_i1 in TyPkg (_x, _x_i1) - | TyAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in TyAnt (_x, _x_i1) - method class_type : class_type -> class_type = - function - | CtNil _x -> let _x = o#loc _x in CtNil _x - | CtCon (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#virtual_flag _x_i1 in - let _x_i2 = o#ident _x_i2 in - let _x_i3 = o#ctyp _x_i3 - in CtCon (_x, _x_i1, _x_i2, _x_i3) - | CtFun (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#class_type _x_i2 - in CtFun (_x, _x_i1, _x_i2) - | CtSig (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#class_sig_item _x_i2 - in CtSig (_x, _x_i1, _x_i2) - | CtAnd (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in - let _x_i2 = o#class_type _x_i2 - in CtAnd (_x, _x_i1, _x_i2) - | CtCol (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in - let _x_i2 = o#class_type _x_i2 - in CtCol (_x, _x_i1, _x_i2) - | CtEq (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in - let _x_i2 = o#class_type _x_i2 - in CtEq (_x, _x_i1, _x_i2) - | CtAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in CtAnt (_x, _x_i1) - method class_str_item : class_str_item -> class_str_item = - function - | CrNil _x -> let _x = o#loc _x in CrNil _x - | CrSem (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_str_item _x_i1 in - let _x_i2 = o#class_str_item _x_i2 - in CrSem (_x, _x_i1, _x_i2) - | CrCtr (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in CrCtr (_x, _x_i1, _x_i2) - | CrInh (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#override_flag _x_i1 in - let _x_i2 = o#class_expr _x_i2 in - let _x_i3 = o#string _x_i3 - in CrInh (_x, _x_i1, _x_i2, _x_i3) - | CrIni (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#expr _x_i1 in CrIni (_x, _x_i1) - | CrMth (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#override_flag _x_i2 in - let _x_i3 = o#private_flag _x_i3 in - let _x_i4 = o#expr _x_i4 in - let _x_i5 = o#ctyp _x_i5 - in CrMth (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) - | CrVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#override_flag _x_i2 in - let _x_i3 = o#mutable_flag _x_i3 in - let _x_i4 = o#expr _x_i4 - in CrVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) - | CrVir (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#private_flag _x_i2 in - let _x_i3 = o#ctyp _x_i3 - in CrVir (_x, _x_i1, _x_i2, _x_i3) - | CrVvr (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#mutable_flag _x_i2 in - let _x_i3 = o#ctyp _x_i3 - in CrVvr (_x, _x_i1, _x_i2, _x_i3) - | CrAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in CrAnt (_x, _x_i1) - method class_sig_item : class_sig_item -> class_sig_item = - function - | CgNil _x -> let _x = o#loc _x in CgNil _x - | CgCtr (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#ctyp _x_i1 in - let _x_i2 = o#ctyp _x_i2 in CgCtr (_x, _x_i1, _x_i2) - | CgSem (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_sig_item _x_i1 in - let _x_i2 = o#class_sig_item _x_i2 - in CgSem (_x, _x_i1, _x_i2) - | CgInh (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#class_type _x_i1 in CgInh (_x, _x_i1) - | CgMth (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#private_flag _x_i2 in - let _x_i3 = o#ctyp _x_i3 - in CgMth (_x, _x_i1, _x_i2, _x_i3) - | CgVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#mutable_flag _x_i2 in - let _x_i3 = o#virtual_flag _x_i3 in - let _x_i4 = o#ctyp _x_i4 - in CgVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) - | CgVir (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in - let _x_i2 = o#private_flag _x_i2 in - let _x_i3 = o#ctyp _x_i3 - in CgVir (_x, _x_i1, _x_i2, _x_i3) - | CgAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in CgAnt (_x, _x_i1) - method class_expr : class_expr -> class_expr = - function - | CeNil _x -> let _x = o#loc _x in CeNil _x - | CeApp (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in - let _x_i2 = o#expr _x_i2 in CeApp (_x, _x_i1, _x_i2) - | CeCon (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#virtual_flag _x_i1 in - let _x_i2 = o#ident _x_i2 in - let _x_i3 = o#ctyp _x_i3 - in CeCon (_x, _x_i1, _x_i2, _x_i3) - | CeFun (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#class_expr _x_i2 - in CeFun (_x, _x_i1, _x_i2) - | CeLet (_x, _x_i1, _x_i2, _x_i3) -> - let _x = o#loc _x in - let _x_i1 = o#rec_flag _x_i1 in - let _x_i2 = o#binding _x_i2 in - let _x_i3 = o#class_expr _x_i3 - in CeLet (_x, _x_i1, _x_i2, _x_i3) - | CeStr (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#class_str_item _x_i2 - in CeStr (_x, _x_i1, _x_i2) - | CeTyc (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in - let _x_i2 = o#class_type _x_i2 - in CeTyc (_x, _x_i1, _x_i2) - | CeAnd (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in - let _x_i2 = o#class_expr _x_i2 - in CeAnd (_x, _x_i1, _x_i2) - | CeEq (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#class_expr _x_i1 in - let _x_i2 = o#class_expr _x_i2 - in CeEq (_x, _x_i1, _x_i2) - | CeAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in CeAnt (_x, _x_i1) - method binding : binding -> binding = - function - | BiNil _x -> let _x = o#loc _x in BiNil _x - | BiAnd (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#binding _x_i1 in - let _x_i2 = o#binding _x_i2 in BiAnd (_x, _x_i1, _x_i2) - | BiEq (_x, _x_i1, _x_i2) -> - let _x = o#loc _x in - let _x_i1 = o#patt _x_i1 in - let _x_i2 = o#expr _x_i2 in BiEq (_x, _x_i1, _x_i2) - | BiAnt (_x, _x_i1) -> - let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in BiAnt (_x, _x_i1) - method unknown : 'a. 'a -> 'a = fun x -> x - end - - class fold = - object ((o : 'self_type)) - method string : string -> 'self_type = o#unknown - method list : - 'a. - ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type = - fun _f_a -> - function - | [] -> o - | _x :: _x_i1 -> - let o = _f_a o _x in let o = o#list _f_a _x_i1 in o - method with_constr : with_constr -> 'self_type = - function - | WcNil _x -> let o = o#loc _x in o - | WcTyp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | WcMod (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#ident _x_i2 in o - | WcTyS (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | WcMoS (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#ident _x_i2 in o - | WcAnd (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#with_constr _x_i1 in - let o = o#with_constr _x_i2 in o - | WcAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method virtual_flag : virtual_flag -> 'self_type = - function - | ViVirtual -> o - | ViNil -> o - | ViAnt _x -> let o = o#string _x in o - method str_item : str_item -> 'self_type = - function - | StNil _x -> let o = o#loc _x in o - | StCls (_x, _x_i1) -> - let o = o#loc _x in let o = o#class_expr _x_i1 in o - | StClt (_x, _x_i1) -> - let o = o#loc _x in let o = o#class_type _x_i1 in o - | StSem (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#str_item _x_i1 in - let o = o#str_item _x_i2 in o - | StDir (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | StExc (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in - let o = o#meta_option (fun o -> o#ident) _x_i2 in o - | StExp (_x, _x_i1) -> - let o = o#loc _x in let o = o#expr _x_i1 in o - | StExt (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#ctyp _x_i2 in - let o = o#meta_list (fun o -> o#string) _x_i3 in o - | StInc (_x, _x_i1) -> - let o = o#loc _x in let o = o#module_expr _x_i1 in o - | StMod (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_expr _x_i2 in o - | StRecMod (_x, _x_i1) -> - let o = o#loc _x in let o = o#module_binding _x_i1 in o - | StMty (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in o - | StOpn (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | StTyp (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | StVal (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#rec_flag _x_i1 in - let o = o#binding _x_i2 in o - | StAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method sig_item : sig_item -> 'self_type = - function - | SgNil _x -> let o = o#loc _x in o - | SgCls (_x, _x_i1) -> - let o = o#loc _x in let o = o#class_type _x_i1 in o - | SgClt (_x, _x_i1) -> - let o = o#loc _x in let o = o#class_type _x_i1 in o - | SgSem (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#sig_item _x_i1 in - let o = o#sig_item _x_i2 in o - | SgDir (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | SgExc (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | SgExt (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#ctyp _x_i2 in - let o = o#meta_list (fun o -> o#string) _x_i3 in o - | SgInc (_x, _x_i1) -> - let o = o#loc _x in let o = o#module_type _x_i1 in o - | SgMod (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in o - | SgRecMod (_x, _x_i1) -> - let o = o#loc _x in let o = o#module_binding _x_i1 in o - | SgMty (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in o - | SgOpn (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | SgTyp (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | SgVal (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o - | SgAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method row_var_flag : row_var_flag -> 'self_type = - function - | RvRowVar -> o - | RvNil -> o - | RvAnt _x -> let o = o#string _x in o - method rec_flag : rec_flag -> 'self_type = - function - | ReRecursive -> o - | ReNil -> o - | ReAnt _x -> let o = o#string _x in o - method rec_binding : rec_binding -> 'self_type = - function - | RbNil _x -> let o = o#loc _x in o - | RbSem (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#rec_binding _x_i1 in - let o = o#rec_binding _x_i2 in o - | RbEq (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#expr _x_i2 in o - | RbAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method private_flag : private_flag -> 'self_type = - function - | PrPrivate -> o - | PrNil -> o - | PrAnt _x -> let o = o#string _x in o - method patt : patt -> 'self_type = - function - | PaNil _x -> let o = o#loc _x in o - | PaId (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | PaAli (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaAny _x -> let o = o#loc _x in o - | PaApp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaArr (_x, _x_i1) -> - let o = o#loc _x in let o = o#patt _x_i1 in o - | PaCom (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaSem (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaChr (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaInt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaInt32 (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaInt64 (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaNativeInt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaFlo (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaLab (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#patt _x_i2 in o - | PaOlb (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#patt _x_i2 in o - | PaOlbi (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#patt _x_i2 in let o = o#expr _x_i3 in o - | PaOrp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaRng (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#patt _x_i2 in o - | PaRec (_x, _x_i1) -> - let o = o#loc _x in let o = o#patt _x_i1 in o - | PaEq (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#patt _x_i2 in o - | PaStr (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaTup (_x, _x_i1) -> - let o = o#loc _x in let o = o#patt _x_i1 in o - | PaTyc (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#ctyp _x_i2 in o - | PaTyp (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | PaVrn (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | PaLaz (_x, _x_i1) -> - let o = o#loc _x in let o = o#patt _x_i1 in o - | PaMod (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method override_flag : override_flag -> 'self_type = - function - | OvOverride -> o - | OvNil -> o - | OvAnt _x -> let o = o#string _x in o - method mutable_flag : mutable_flag -> 'self_type = - function - | MuMutable -> o - | MuNil -> o - | MuAnt _x -> let o = o#string _x in o - method module_type : module_type -> 'self_type = - function - | MtNil _x -> let o = o#loc _x in o - | MtId (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | MtFun (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in - let o = o#module_type _x_i3 in o - | MtQuo (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | MtSig (_x, _x_i1) -> - let o = o#loc _x in let o = o#sig_item _x_i1 in o - | MtWit (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#module_type _x_i1 in - let o = o#with_constr _x_i2 in o - | MtOf (_x, _x_i1) -> - let o = o#loc _x in let o = o#module_expr _x_i1 in o - | MtAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method module_expr : module_expr -> 'self_type = - function - | MeNil _x -> let o = o#loc _x in o - | MeId (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | MeApp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#module_expr _x_i1 in - let o = o#module_expr _x_i2 in o - | MeFun (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in - let o = o#module_expr _x_i3 in o - | MeStr (_x, _x_i1) -> - let o = o#loc _x in let o = o#str_item _x_i1 in o - | MeTyc (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#module_expr _x_i1 in - let o = o#module_type _x_i2 in o - | MePkg (_x, _x_i1) -> - let o = o#loc _x in let o = o#expr _x_i1 in o - | MeAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method module_binding : module_binding -> 'self_type = - function - | MbNil _x -> let o = o#loc _x in o - | MbAnd (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#module_binding _x_i1 in - let o = o#module_binding _x_i2 in o - | MbColEq (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in - let o = o#module_expr _x_i3 in o - | MbCol (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_type _x_i2 in o - | MbAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method meta_option : - 'a. - ('self_type -> 'a -> 'self_type) -> - 'a meta_option -> 'self_type = - fun _f_a -> - function - | ONone -> o - | OSome _x -> let o = _f_a o _x in o - | OAnt _x -> let o = o#string _x in o - method meta_list : - 'a. - ('self_type -> 'a -> 'self_type) -> - 'a meta_list -> 'self_type = - fun _f_a -> - function - | LNil -> o - | LCons (_x, _x_i1) -> - let o = _f_a o _x in - let o = o#meta_list _f_a _x_i1 in o - | LAnt _x -> let o = o#string _x in o - method meta_bool : meta_bool -> 'self_type = - function - | BTrue -> o - | BFalse -> o - | BAnt _x -> let o = o#string _x in o - method match_case : match_case -> 'self_type = - function - | McNil _x -> let o = o#loc _x in o - | McOr (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#match_case _x_i1 in - let o = o#match_case _x_i2 in o - | McArr (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#patt _x_i1 in - let o = o#expr _x_i2 in let o = o#expr _x_i3 in o - | McAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method loc : loc -> 'self_type = o#unknown - method ident : ident -> 'self_type = - function - | IdAcc (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#ident _x_i2 in o - | IdApp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#ident _x_i2 in o - | IdLid (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | IdUid (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | IdAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method expr : expr -> 'self_type = - function - | ExNil _x -> let o = o#loc _x in o - | ExId (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | ExAcc (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExApp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExAre (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExArr (_x, _x_i1) -> - let o = o#loc _x in let o = o#expr _x_i1 in o - | ExSem (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExAsf _x -> let o = o#loc _x in o - | ExAsr (_x, _x_i1) -> - let o = o#loc _x in let o = o#expr _x_i1 in o - | ExAss (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExChr (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExCoe (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#expr _x_i1 in - let o = o#ctyp _x_i2 in let o = o#ctyp _x_i3 in o - | ExFlo (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExFor (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#expr _x_i2 in - let o = o#expr _x_i3 in - let o = o#direction_flag _x_i4 in - let o = o#expr _x_i5 in o - | ExFun (_x, _x_i1) -> - let o = o#loc _x in let o = o#match_case _x_i1 in o - | ExIfe (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#expr _x_i1 in - let o = o#expr _x_i2 in let o = o#expr _x_i3 in o - | ExInt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExInt32 (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExInt64 (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExNativeInt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExLab (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | ExLaz (_x, _x_i1) -> - let o = o#loc _x in let o = o#expr _x_i1 in o - | ExLet (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#rec_flag _x_i1 in - let o = o#binding _x_i2 in let o = o#expr _x_i3 in o - | ExLmd (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#module_expr _x_i2 in - let o = o#expr _x_i3 in o - | ExMat (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#match_case _x_i2 in o - | ExNew (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | ExObj (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in - let o = o#class_str_item _x_i2 in o - | ExOlb (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | ExOvr (_x, _x_i1) -> - let o = o#loc _x in let o = o#rec_binding _x_i1 in o - | ExRec (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#rec_binding _x_i1 in - let o = o#expr _x_i2 in o - | ExSeq (_x, _x_i1) -> - let o = o#loc _x in let o = o#expr _x_i1 in o - | ExSnd (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#string _x_i2 in o - | ExSte (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExStr (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExTry (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#match_case _x_i2 in o - | ExTup (_x, _x_i1) -> - let o = o#loc _x in let o = o#expr _x_i1 in o - | ExCom (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExTyc (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#ctyp _x_i2 in o - | ExVrn (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | ExWhi (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#expr _x_i1 in let o = o#expr _x_i2 in o - | ExOpI (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ident _x_i1 in let o = o#expr _x_i2 in o - | ExFUN (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#expr _x_i2 in o - | ExPkg (_x, _x_i1) -> - let o = o#loc _x in let o = o#module_expr _x_i1 in o - method direction_flag : direction_flag -> 'self_type = - function - | DiTo -> o - | DiDownto -> o - | DiAnt _x -> let o = o#string _x in o - method ctyp : ctyp -> 'self_type = - function - | TyNil _x -> let o = o#loc _x in o - | TyAli (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyAny _x -> let o = o#loc _x in o - | TyApp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyArr (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyCls (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | TyLab (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o - | TyId (_x, _x_i1) -> - let o = o#loc _x in let o = o#ident _x_i1 in o - | TyMan (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyDcl (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#list (fun o -> o#ctyp) _x_i2 in - let o = o#ctyp _x_i3 in - let o = - o#list - (fun o (_x, _x_i1) -> - let o = o#ctyp _x in let o = o#ctyp _x_i1 in o) - _x_i4 - in o - | TyObj (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in - let o = o#row_var_flag _x_i2 in o - | TyOlb (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o - | TyPol (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyTypePol (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyQuo (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | TyQuP (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | TyQuM (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | TyAnP _x -> let o = o#loc _x in o - | TyAnM _x -> let o = o#loc _x in o - | TyVrn (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - | TyRec (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyCol (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TySem (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyCom (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TySum (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyOf (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyAnd (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyOr (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyPrv (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyMut (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyTup (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TySta (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyVrnEq (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyVrnSup (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyVrnInf (_x, _x_i1) -> - let o = o#loc _x in let o = o#ctyp _x_i1 in o - | TyVrnInfSup (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyAmp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyOfAmp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | TyPkg (_x, _x_i1) -> - let o = o#loc _x in let o = o#module_type _x_i1 in o - | TyAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method class_type : class_type -> 'self_type = - function - | CtNil _x -> let o = o#loc _x in o - | CtCon (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#virtual_flag _x_i1 in - let o = o#ident _x_i2 in let o = o#ctyp _x_i3 in o - | CtFun (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#class_type _x_i2 in o - | CtSig (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in - let o = o#class_sig_item _x_i2 in o - | CtAnd (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_type _x_i1 in - let o = o#class_type _x_i2 in o - | CtCol (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_type _x_i1 in - let o = o#class_type _x_i2 in o - | CtEq (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_type _x_i1 in - let o = o#class_type _x_i2 in o - | CtAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method class_str_item : class_str_item -> 'self_type = - function - | CrNil _x -> let o = o#loc _x in o - | CrSem (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_str_item _x_i1 in - let o = o#class_str_item _x_i2 in o - | CrCtr (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | CrInh (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#override_flag _x_i1 in - let o = o#class_expr _x_i2 in - let o = o#string _x_i3 in o - | CrIni (_x, _x_i1) -> - let o = o#loc _x in let o = o#expr _x_i1 in o - | CrMth (_x, _x_i1, _x_i2, _x_i3, _x_i4, _x_i5) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#override_flag _x_i2 in - let o = o#private_flag _x_i3 in - let o = o#expr _x_i4 in let o = o#ctyp _x_i5 in o - | CrVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#override_flag _x_i2 in - let o = o#mutable_flag _x_i3 in - let o = o#expr _x_i4 in o - | CrVir (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#private_flag _x_i2 in - let o = o#ctyp _x_i3 in o - | CrVvr (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#mutable_flag _x_i2 in - let o = o#ctyp _x_i3 in o - | CrAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method class_sig_item : class_sig_item -> 'self_type = - function - | CgNil _x -> let o = o#loc _x in o - | CgCtr (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o - | CgSem (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_sig_item _x_i1 in - let o = o#class_sig_item _x_i2 in o - | CgInh (_x, _x_i1) -> - let o = o#loc _x in let o = o#class_type _x_i1 in o - | CgMth (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#private_flag _x_i2 in - let o = o#ctyp _x_i3 in o - | CgVal (_x, _x_i1, _x_i2, _x_i3, _x_i4) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#mutable_flag _x_i2 in - let o = o#virtual_flag _x_i3 in - let o = o#ctyp _x_i4 in o - | CgVir (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#string _x_i1 in - let o = o#private_flag _x_i2 in - let o = o#ctyp _x_i3 in o - | CgAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method class_expr : class_expr -> 'self_type = - function - | CeNil _x -> let o = o#loc _x in o - | CeApp (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_expr _x_i1 in let o = o#expr _x_i2 in o - | CeCon (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#virtual_flag _x_i1 in - let o = o#ident _x_i2 in let o = o#ctyp _x_i3 in o - | CeFun (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#class_expr _x_i2 in o - | CeLet (_x, _x_i1, _x_i2, _x_i3) -> - let o = o#loc _x in - let o = o#rec_flag _x_i1 in - let o = o#binding _x_i2 in - let o = o#class_expr _x_i3 in o - | CeStr (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in - let o = o#class_str_item _x_i2 in o - | CeTyc (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_expr _x_i1 in - let o = o#class_type _x_i2 in o - | CeAnd (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_expr _x_i1 in - let o = o#class_expr _x_i2 in o - | CeEq (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#class_expr _x_i1 in - let o = o#class_expr _x_i2 in o - | CeAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method binding : binding -> 'self_type = - function - | BiNil _x -> let o = o#loc _x in o - | BiAnd (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#binding _x_i1 in let o = o#binding _x_i2 in o - | BiEq (_x, _x_i1, _x_i2) -> - let o = o#loc _x in - let o = o#patt _x_i1 in let o = o#expr _x_i2 in o - | BiAnt (_x, _x_i1) -> - let o = o#loc _x in let o = o#string _x_i1 in o - method unknown : 'a. 'a -> 'self_type = fun _ -> o - end - - let map_expr f = - object - inherit map as super - method expr = fun x -> f (super#expr x) - end - - let map_patt f = - object - inherit map as super - method patt = fun x -> f (super#patt x) - end - - let map_ctyp f = - object - inherit map as super - method ctyp = fun x -> f (super#ctyp x) - end - - let map_str_item f = - object - inherit map as super - method str_item = fun x -> f (super#str_item x) - end - - let map_sig_item f = - object - inherit map as super - method sig_item = fun x -> f (super#sig_item x) - end - - let map_loc f = - object - inherit map as super - method loc = fun x -> f (super#loc x) - end - - end - - end - - module DynAst = - struct - module Make (Ast : Sig.Ast) : Sig.DynAst with module Ast = Ast = - struct - module Ast = Ast - - type 'a tag = - | Tag_ctyp - | Tag_patt - | Tag_expr - | Tag_module_type - | Tag_sig_item - | Tag_with_constr - | Tag_module_expr - | Tag_str_item - | Tag_class_type - | Tag_class_sig_item - | Tag_class_expr - | Tag_class_str_item - | Tag_match_case - | Tag_ident - | Tag_binding - | Tag_rec_binding - | Tag_module_binding - - let string_of_tag = - function - | Tag_ctyp -> "ctyp" - | Tag_patt -> "patt" - | Tag_expr -> "expr" - | Tag_module_type -> "module_type" - | Tag_sig_item -> "sig_item" - | Tag_with_constr -> "with_constr" - | Tag_module_expr -> "module_expr" - | Tag_str_item -> "str_item" - | Tag_class_type -> "class_type" - | Tag_class_sig_item -> "class_sig_item" - | Tag_class_expr -> "class_expr" - | Tag_class_str_item -> "class_str_item" - | Tag_match_case -> "match_case" - | Tag_ident -> "ident" - | Tag_binding -> "binding" - | Tag_rec_binding -> "rec_binding" - | Tag_module_binding -> "module_binding" - - let ctyp_tag = Tag_ctyp - - let patt_tag = Tag_patt - - let expr_tag = Tag_expr - - let module_type_tag = Tag_module_type - - let sig_item_tag = Tag_sig_item - - let with_constr_tag = Tag_with_constr - - let module_expr_tag = Tag_module_expr - - let str_item_tag = Tag_str_item - - let class_type_tag = Tag_class_type - - let class_sig_item_tag = Tag_class_sig_item - - let class_expr_tag = Tag_class_expr - - let class_str_item_tag = Tag_class_str_item - - let match_case_tag = Tag_match_case - - let ident_tag = Tag_ident - - let binding_tag = Tag_binding - - let rec_binding_tag = Tag_rec_binding - - let module_binding_tag = Tag_module_binding - - type dyn - - external dyn_tag : 'a tag -> dyn tag = "%identity" - - module Pack (X : sig type 'a t - end) = - struct - type pack = ((dyn tag) * Obj.t) - - exception Pack_error - - let pack tag v = ((dyn_tag tag), (Obj.repr v)) - - let unpack (tag : 'a tag) (tag', obj) = - if (dyn_tag tag) = tag' - then (Obj.obj obj : 'a X.t) - else raise Pack_error - - let print_tag f (tag, _) = - Format.pp_print_string f (string_of_tag tag) - - end - - end - - end - - module Quotation = - struct - module Make (Ast : Sig.Camlp4Ast) : - Sig.Quotation with module Ast = Ast = - struct - module Ast = Ast - - module DynAst = DynAst.Make(Ast) - - module Loc = Ast.Loc - - open Format - - open Sig - - type 'a expand_fun = Loc.t -> string option -> string -> 'a - - module Exp_key = DynAst.Pack(struct type 'a t = unit - end) - - module Exp_fun = - DynAst.Pack(struct type 'a t = 'a expand_fun - end) - - let expanders_table : - (((string * Exp_key.pack) * Exp_fun.pack) list) ref = ref [] - - let default = ref "" - - let translate = ref (fun x -> x) - - let expander_name name = - match !translate name with | "" -> !default | name -> name - - let find name tag = - let key = ((expander_name name), (Exp_key.pack tag ())) - in Exp_fun.unpack tag (List.assoc key !expanders_table) - - let add name tag f = - let elt = ((name, (Exp_key.pack tag ())), (Exp_fun.pack tag f)) - in expanders_table := elt :: !expanders_table - - let dump_file = ref None - - module Error = - struct - type error = - | Finding - | Expanding - | ParsingResult of Loc.t * string - | Locating - - type t = (string * string * error * exn) - - exception E of t - - let print ppf (name, position, ctx, exn) = - let name = if name = "" then !default else name in - let pp x = - fprintf ppf "@?@[<2>While %s %S in a position of %S:" x - name position in - let () = - match ctx with - | Finding -> - (pp "finding quotation"; - if !expanders_table = [] - then - fprintf ppf - "@ There is no quotation expander available." - else - (fprintf ppf - "@ @[Available quotation expanders are:@\n"; - List.iter - (fun ((s, t), _) -> - fprintf ppf - "@[<2>%s@ (in@ a@ position@ of %a)@]@ " s - Exp_key.print_tag t) - !expanders_table; - fprintf ppf "@]")) - | Expanding -> pp "expanding quotation" - | Locating -> pp "parsing" - | ParsingResult (loc, str) -> - let () = pp "parsing result of quotation" - in - (match !dump_file with - | Some dump_file -> - let () = fprintf ppf " dumping result...\n" - in - (try - let oc = open_out_bin dump_file - in - (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)) - with - | _ -> - fprintf ppf - "Error while dumping result in file %S; dump aborted" - dump_file) - | None -> - fprintf ppf - "\n(consider setting variable Quotation.dump_file, or using the -QD option)") - in fprintf ppf "@\n%a@]@." ErrorHandler.print exn - - let to_string x = - let b = Buffer.create 50 in - let () = bprintf b "%a" print x in Buffer.contents b - - end - - let _ = let module M = ErrorHandler.Register(Error) in () - - open Error - - let expand_quotation loc expander pos_tag quot = - let loc_name_opt = - if quot.q_loc = "" then None else Some quot.q_loc - in - try expander loc loc_name_opt quot.q_contents - with | (Loc.Exc_located (_, (Error.E _)) as exc) -> raise exc - | Loc.Exc_located (iloc, exc) -> - let exc1 = - Error.E (((quot.q_name), pos_tag, Expanding, exc)) - in raise (Loc.Exc_located (iloc, exc1)) - | exc -> - let exc1 = - Error.E (((quot.q_name), pos_tag, Expanding, exc)) - in raise (Loc.Exc_located (loc, exc1)) - - let parse_quotation_result parse loc quot pos_tag str = - try parse loc str - with - | Loc.Exc_located (iloc, - (Error.E ((n, pos_tag, Expanding, exc)))) -> - let ctx = ParsingResult (iloc, quot.q_contents) in - let exc1 = Error.E ((n, pos_tag, ctx, exc)) - in raise (Loc.Exc_located (iloc, exc1)) - | Loc.Exc_located (iloc, ((Error.E _ as exc))) -> - raise (Loc.Exc_located (iloc, exc)) - | Loc.Exc_located (iloc, exc) -> - let ctx = ParsingResult (iloc, quot.q_contents) in - let exc1 = Error.E (((quot.q_name), pos_tag, ctx, exc)) - in raise (Loc.Exc_located (iloc, exc1)) - - let expand loc quotation tag = - let pos_tag = DynAst.string_of_tag tag in - let name = quotation.q_name in - let expander = - try find name tag - with | (Loc.Exc_located (_, (Error.E _)) as exc) -> raise exc - | Loc.Exc_located (qloc, exc) -> - raise - (Loc.Exc_located (qloc, - (Error.E ((name, pos_tag, Finding, exc))))) - | exc -> - raise - (Loc.Exc_located (loc, - (Error.E ((name, pos_tag, Finding, exc))))) in - let loc = Loc.join (Loc.move `start quotation.q_shift loc) - in expand_quotation loc expander pos_tag quotation - - end - - end - - module AstFilters = - struct - module Make (Ast : Sig.Camlp4Ast) : - Sig.AstFilters with module Ast = Ast = - struct - module Ast = Ast - - type 'a filter = 'a -> 'a - - let interf_filters = Queue.create () - - let fold_interf_filters f i = Queue.fold f i interf_filters - - let implem_filters = Queue.create () - - let fold_implem_filters f i = Queue.fold f i implem_filters - - let topphrase_filters = Queue.create () - - let fold_topphrase_filters f i = Queue.fold f i topphrase_filters - - let register_sig_item_filter f = Queue.add f interf_filters - - let register_str_item_filter f = Queue.add f implem_filters - - let register_topphrase_filter f = Queue.add f topphrase_filters - - end - - end - - module Camlp4Ast2OCamlAst : - sig - module Make (Camlp4Ast : Sig.Camlp4Ast) : - sig - open Camlp4Ast - - val sig_item : sig_item -> Camlp4_import.Parsetree.signature - - val str_item : str_item -> Camlp4_import.Parsetree.structure - - val phrase : str_item -> Camlp4_import.Parsetree.toplevel_phrase - - end - - end = - struct - module Make (Ast : Sig.Camlp4Ast) = - struct - open Format - - open Camlp4_import.Parsetree - - open Camlp4_import.Longident - - open Camlp4_import.Asttypes - - open Ast - - let constructors_arity () = !Camlp4_config.constructors_arity - - let error loc str = Loc.raise loc (Failure str) - - let char_of_char_token loc s = - try Token.Eval.char s - with | (Failure _ as exn) -> Loc.raise loc exn - - let string_of_string_token loc s = - try Token.Eval.string s - with | (Failure _ as exn) -> Loc.raise loc exn - - let remove_underscores s = - let l = String.length s in - let rec remove src dst = - if src >= l - then if dst >= l then s else String.sub s 0 dst - else - (match s.[src] with - | '_' -> remove (src + 1) dst - | c -> (s.[dst] <- c; remove (src + 1) (dst + 1))) - in remove 0 0 - - let mkloc = Loc.to_ocaml_location - - let mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc) - - let with_loc txt loc = - Camlp4_import.Location.mkloc txt (mkloc loc) - - let mktyp loc d = { ptyp_desc = d; ptyp_loc = mkloc loc; } - - let mkpat loc d = { ppat_desc = d; ppat_loc = mkloc loc; } - - let mkghpat loc d = { ppat_desc = d; ppat_loc = mkghloc loc; } - - let mkexp loc d = { pexp_desc = d; pexp_loc = mkloc loc; } - - let mkmty loc d = { pmty_desc = d; pmty_loc = mkloc loc; } - - let mksig loc d = { psig_desc = d; psig_loc = mkloc loc; } - - let mkmod loc d = { pmod_desc = d; pmod_loc = mkloc loc; } - - let mkstr loc d = { pstr_desc = d; pstr_loc = mkloc loc; } - - let mkfield loc d = { pfield_desc = d; pfield_loc = mkloc loc; } - - let mkcty loc d = { pcty_desc = d; pcty_loc = mkloc loc; } - - let mkcl loc d = { pcl_desc = d; pcl_loc = mkloc loc; } - - let mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; } - - let mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; } - - let mkpolytype t = - match t.ptyp_desc with - | Ptyp_poly (_, _) -> t - | _ -> { (t) with ptyp_desc = Ptyp_poly ([], t); } - - let mkvirtual = - function - | Ast.ViVirtual -> Virtual - | Ast.ViNil -> Concrete - | _ -> assert false - - let mkdirection = - function - | Ast.DiTo -> Upto - | Ast.DiDownto -> Downto - | _ -> assert false - - let lident s = Lident s - - let lident_with_loc s loc = with_loc (Lident s) loc - - let ldot l s = Ldot (l, s) - - let lapply l s = Lapply (l, s) - - let conv_con = - let t = Hashtbl.create 73 - in - (List.iter (fun (s, s') -> Hashtbl.add t s s') - [ ("True", "true"); ("False", "false"); (" True", "True"); - (" False", "False") ]; - fun s -> try Hashtbl.find t s with | Not_found -> s) - - let conv_lab = - let t = Hashtbl.create 73 - in - (List.iter (fun (s, s') -> Hashtbl.add t s s') - [ ("val", "contents") ]; - fun s -> try Hashtbl.find t s with | Not_found -> s) - - let array_function_no_loc str name = - ldot (lident str) - (if !Camlp4_config.unsafe then "unsafe_" ^ name else name) - - let array_function loc str name = - with_loc (array_function_no_loc str name) loc - - let mkrf = - function - | Ast.ReRecursive -> Recursive - | Ast.ReNil -> Nonrecursive - | _ -> assert false - - let mkli sloc s list = - let rec loop f = - function | i :: il -> loop (ldot (f i)) il | [] -> f s - in with_loc (loop lident list) sloc - - let rec ctyp_fa al = - function - | TyApp (_, f, a) -> ctyp_fa (a :: al) f - | f -> (f, al) - - let ident_tag ?(conv_lid = fun x -> x) i = - let rec self i acc = - match i with - | Ast.IdAcc (_, (Ast.IdLid (_, "*predef*")), - (Ast.IdLid (_, "option"))) -> - ((ldot (lident "*predef*") "option"), `lident) - | Ast.IdAcc (_, i1, i2) -> self i2 (Some (self i1 acc)) - | Ast.IdApp (_, i1, i2) -> - let i' = - Lapply ((fst (self i1 None)), (fst (self i2 None))) in - let x = - (match acc with - | None -> i' - | _ -> - error (loc_of_ident i) "invalid long identifier") - in (x, `app) - | Ast.IdUid (_, s) -> - let x = - (match acc with - | None -> lident s - | Some ((acc, (`uident | `app))) -> ldot acc s - | _ -> - error (loc_of_ident i) "invalid long identifier") - in (x, `uident) - | Ast.IdLid (_, s) -> - let x = - (match acc with - | None -> lident (conv_lid s) - | Some ((acc, (`uident | `app))) -> - ldot acc (conv_lid s) - | _ -> - error (loc_of_ident i) "invalid long identifier") - in (x, `lident) - | _ -> error (loc_of_ident i) "invalid long identifier" - in self i None - - let ident_noloc ?conv_lid i = fst (ident_tag ?conv_lid i) - - let ident ?conv_lid i = - with_loc (ident_noloc ?conv_lid i) (loc_of_ident i) - - let long_lident msg id = - match ident_tag id with - | (i, `lident) -> with_loc i (loc_of_ident id) - | _ -> error (loc_of_ident id) msg - - let long_type_ident = long_lident "invalid long identifier type" - - let long_class_ident = long_lident "invalid class name" - - let long_uident_noloc ?(conv_con = fun x -> x) i = - match ident_tag i with - | (Ldot (i, s), `uident) -> ldot i (conv_con s) - | (Lident s, `uident) -> lident (conv_con s) - | (i, `app) -> i - | _ -> error (loc_of_ident i) "uppercase identifier expected" - - let long_uident ?conv_con i = - with_loc (long_uident_noloc ?conv_con i) (loc_of_ident i) - - let rec ctyp_long_id_prefix t = - match t with - | Ast.TyId (_, i) -> ident_noloc i - | Ast.TyApp (_, m1, m2) -> - let li1 = ctyp_long_id_prefix m1 in - let li2 = ctyp_long_id_prefix m2 in Lapply (li1, li2) - | t -> error (loc_of_ctyp t) "invalid module expression" - - let ctyp_long_id t = - match t with - | Ast.TyId (_, i) -> (false, (long_type_ident i)) - | TyApp (loc, _, _) -> error loc "invalid type name" - | TyCls (_, i) -> (true, (ident i)) - | t -> error (loc_of_ctyp t) "invalid type" - - let rec ty_var_list_of_ctyp = - function - | Ast.TyApp (_, t1, t2) -> - (ty_var_list_of_ctyp t1) @ (ty_var_list_of_ctyp t2) - | Ast.TyQuo (_, s) -> [ s ] - | _ -> assert false - - let predef_option loc = - TyId - ((loc, - (IdAcc - ((loc, (IdLid ((loc, "*predef*"))), - (IdLid ((loc, "option")))))))) - - let rec ctyp = - function - | TyId (loc, i) -> - let li = long_type_ident i - in mktyp loc (Ptyp_constr (li, [])) - | TyAli (loc, t1, t2) -> - let (t, i) = - (match (t1, t2) with - | (t, TyQuo (_, s)) -> (t, s) - | (TyQuo (_, s), t) -> (t, s) - | _ -> error loc "invalid alias type") - in mktyp loc (Ptyp_alias ((ctyp t), i)) - | TyAny loc -> mktyp loc Ptyp_any - | (TyApp (loc, _, _) as f) -> - let (f, al) = ctyp_fa [] f in - let (is_cls, li) = ctyp_long_id f - in - if is_cls - then mktyp loc (Ptyp_class (li, (List.map ctyp al), [])) - else mktyp loc (Ptyp_constr (li, (List.map ctyp al))) - | TyArr (loc, (TyLab (_, lab, t1)), t2) -> - mktyp loc (Ptyp_arrow (lab, (ctyp t1), (ctyp t2))) - | TyArr (loc, (TyOlb (loc1, lab, t1)), t2) -> - let t1 = TyApp (loc1, (predef_option loc1), t1) - in - mktyp loc - (Ptyp_arrow (("?" ^ lab), (ctyp t1), (ctyp t2))) - | TyArr (loc, t1, t2) -> - mktyp loc (Ptyp_arrow ("", (ctyp t1), (ctyp t2))) - | Ast.TyObj (loc, fl, Ast.RvNil) -> - mktyp loc (Ptyp_object (meth_list fl [])) - | Ast.TyObj (loc, fl, Ast.RvRowVar) -> - mktyp loc - (Ptyp_object (meth_list fl [ mkfield loc Pfield_var ])) - | TyCls (loc, id) -> - mktyp loc (Ptyp_class ((ident id), [], [])) - | Ast.TyPkg (loc, pt) -> - let (i, cs) = package_type pt - in mktyp loc (Ptyp_package (i, cs)) - | TyLab (loc, _, _) -> - error loc "labelled type not allowed here" - | TyMan (loc, _, _) -> - error loc "manifest type not allowed here" - | TyOlb (loc, _, _) -> - error loc "labelled type not allowed here" - | TyPol (loc, t1, t2) -> - mktyp loc (Ptyp_poly ((ty_var_list_of_ctyp t1), (ctyp t2))) - | TyQuo (loc, s) -> mktyp loc (Ptyp_var s) - | TyRec (loc, _) -> error loc "record type not allowed here" - | TySum (loc, _) -> error loc "sum type not allowed here" - | TyPrv (loc, _) -> error loc "private type not allowed here" - | TyMut (loc, _) -> error loc "mutable type not allowed here" - | TyOr (loc, _, _) -> - error loc "type1 | type2 not allowed here" - | TyAnd (loc, _, _) -> - error loc "type1 and type2 not allowed here" - | TyOf (loc, _, _) -> - error loc "type1 of type2 not allowed here" - | TyCol (loc, _, _) -> - error loc "type1 : type2 not allowed here" - | TySem (loc, _, _) -> - error loc "type1 ; type2 not allowed here" - | Ast.TyTup (loc, (Ast.TySta (_, t1, t2))) -> - mktyp loc - (Ptyp_tuple - (List.map ctyp (list_of_ctyp t1 (list_of_ctyp t2 [])))) - | Ast.TyVrnEq (loc, t) -> - mktyp loc (Ptyp_variant ((row_field t), true, None)) - | Ast.TyVrnSup (loc, t) -> - mktyp loc (Ptyp_variant ((row_field t), false, None)) - | Ast.TyVrnInf (loc, t) -> - mktyp loc (Ptyp_variant ((row_field t), true, (Some []))) - | Ast.TyVrnInfSup (loc, t, t') -> - mktyp loc - (Ptyp_variant ((row_field t), true, - (Some (name_tags t')))) - | TyAnt (loc, _) -> error loc "antiquotation not allowed here" - | TyOfAmp (_, _, _) | TyAmp (_, _, _) | TySta (_, _, _) | - TyCom (_, _, _) | TyVrn (_, _) | TyQuM (_, _) | - TyQuP (_, _) | TyDcl (_, _, _, _, _) | TyAnP _ | TyAnM _ | - TyTypePol (_, _, _) | TyObj (_, _, (RvAnt _)) | TyNil _ | - TyTup (_, _) -> assert false - and row_field = - function - | Ast.TyNil _ -> [] - | Ast.TyVrn (_, i) -> [ Rtag (i, true, []) ] - | Ast.TyOfAmp (_, (Ast.TyVrn (_, i)), t) -> - [ Rtag (i, true, (List.map ctyp (list_of_ctyp t []))) ] - | Ast.TyOf (_, (Ast.TyVrn (_, i)), t) -> - [ Rtag (i, false, (List.map ctyp (list_of_ctyp t []))) ] - | Ast.TyOr (_, t1, t2) -> (row_field t1) @ (row_field t2) - | t -> [ Rinherit (ctyp t) ] - and name_tags = - function - | Ast.TyApp (_, t1, t2) -> (name_tags t1) @ (name_tags t2) - | Ast.TyVrn (_, s) -> [ s ] - | _ -> assert false - and meth_list fl acc = - match fl with - | Ast.TyNil _ -> acc - | Ast.TySem (_, t1, t2) -> meth_list t1 (meth_list t2 acc) - | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (_, lab)))), t) -> - (mkfield loc (Pfield (lab, (mkpolytype (ctyp t))))) :: acc - | _ -> assert false - and package_type_constraints wc acc = - match wc with - | Ast.WcNil _ -> acc - | Ast.WcTyp (_, (Ast.TyId (_, id)), ct) -> - ((ident id), (ctyp ct)) :: acc - | Ast.WcAnd (_, wc1, wc2) -> - package_type_constraints wc1 - (package_type_constraints wc2 acc) - | _ -> - error (loc_of_with_constr wc) - "unexpected `with constraint' for a package type" - and package_type : module_type -> package_type = - function - | Ast.MtWit (_, (Ast.MtId (_, i)), wc) -> - ((long_uident i), (package_type_constraints wc [])) - | Ast.MtId (_, i) -> ((long_uident i), []) - | mt -> error (loc_of_module_type mt) "unexpected package type" - - let mktype loc tl cl tk tp tm = - let (params, variance) = List.split tl - in - { - ptype_params = params; - ptype_cstrs = cl; - ptype_kind = tk; - ptype_private = tp; - ptype_manifest = tm; - ptype_loc = mkloc loc; - ptype_variance = variance; - } - - let mkprivate' m = if m then Private else Public - - let mkprivate = - function - | Ast.PrPrivate -> Private - | Ast.PrNil -> Public - | _ -> assert false - - let mktrecord = - function - | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (sloc, s)))), - (Ast.TyMut (_, t))) -> - ((with_loc s sloc), Mutable, (mkpolytype (ctyp t)), - (mkloc loc)) - | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (sloc, s)))), t) -> - ((with_loc s sloc), Immutable, (mkpolytype (ctyp t)), - (mkloc loc)) - | _ -> assert false - - let mkvariant = - function - | Ast.TyId (loc, (Ast.IdUid (sloc, s))) -> - ((with_loc (conv_con s) sloc), [], None, (mkloc loc)) - | Ast.TyOf (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))), t) -> - ((with_loc (conv_con s) sloc), - (List.map ctyp (list_of_ctyp t [])), None, (mkloc loc)) - | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))), - (Ast.TyArr (_, t, u))) -> - ((with_loc (conv_con s) sloc), - (List.map ctyp (list_of_ctyp t [])), (Some (ctyp u)), - (mkloc loc)) - | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))), t) -> - ((with_loc (conv_con s) sloc), [], (Some (ctyp t)), - (mkloc loc)) - | _ -> assert false - - let rec type_decl tl cl loc m pflag = - function - | Ast.TyMan (_, t1, t2) -> - type_decl tl cl loc (Some (ctyp t1)) pflag t2 - | Ast.TyPrv (_loc, t) -> - if pflag - then - error _loc - "multiple private keyword used, use only one instead" - else type_decl tl cl loc m true t - | Ast.TyRec (_, t) -> - mktype loc tl cl - (Ptype_record (List.map mktrecord (list_of_ctyp t []))) - (mkprivate' pflag) m - | Ast.TySum (_, t) -> - mktype loc tl cl - (Ptype_variant (List.map mkvariant (list_of_ctyp t []))) - (mkprivate' pflag) m - | t -> - if m <> None - then - error loc "only one manifest type allowed by definition" - else - (let m = - match t with - | Ast.TyNil _ -> None - | _ -> Some (ctyp t) - in mktype loc tl cl Ptype_abstract (mkprivate' pflag) m) - - let type_decl tl cl t loc = type_decl tl cl loc None false t - - let mkvalue_desc loc t p = - { pval_type = ctyp t; pval_prim = p; pval_loc = mkloc loc; } - - let rec list_of_meta_list = - function - | Ast.LNil -> [] - | Ast.LCons (x, xs) -> x :: (list_of_meta_list xs) - | Ast.LAnt _ -> assert false - - let mkmutable = - function - | Ast.MuMutable -> Mutable - | Ast.MuNil -> Immutable - | _ -> assert false - - let paolab lab p = - match (lab, p) with - | ("", - (Ast.PaId (_, (Ast.IdLid (_, i))) | - Ast.PaTyc (_, (Ast.PaId (_, (Ast.IdLid (_, i)))), _))) - -> i - | ("", p) -> error (loc_of_patt p) "bad ast in label" - | _ -> lab - - let opt_private_ctyp = - function - | Ast.TyPrv (_, t) -> (Ptype_abstract, Private, (ctyp t)) - | t -> (Ptype_abstract, Public, (ctyp t)) - - let rec type_parameters t acc = - match t with - | Ast.TyApp (_, t1, t2) -> - type_parameters t1 (type_parameters t2 acc) - | Ast.TyQuP (_, s) -> (s, (true, false)) :: acc - | Ast.TyQuM (_, s) -> (s, (false, true)) :: acc - | Ast.TyQuo (_, s) -> (s, (false, false)) :: acc - | _ -> assert false - - let rec optional_type_parameters t acc = - match t with - | Ast.TyApp (_, t1, t2) -> - optional_type_parameters t1 - (optional_type_parameters t2 acc) - | Ast.TyQuP (loc, s) -> - ((Some (with_loc s loc)), (true, false)) :: acc - | Ast.TyAnP _loc -> (None, (true, false)) :: acc - | Ast.TyQuM (loc, s) -> - ((Some (with_loc s loc)), (false, true)) :: acc - | Ast.TyAnM _loc -> (None, (false, true)) :: acc - | Ast.TyQuo (loc, s) -> - ((Some (with_loc s loc)), (false, false)) :: acc - | Ast.TyAny _loc -> (None, (false, false)) :: acc - | _ -> assert false - - let rec class_parameters t acc = - match t with - | Ast.TyCom (_, t1, t2) -> - class_parameters t1 (class_parameters t2 acc) - | Ast.TyQuP (loc, s) -> - ((with_loc s loc), (true, false)) :: acc - | Ast.TyQuM (loc, s) -> - ((with_loc s loc), (false, true)) :: acc - | Ast.TyQuo (loc, s) -> - ((with_loc s loc), (false, false)) :: acc - | _ -> assert false - - let rec type_parameters_and_type_name t acc = - match t with - | Ast.TyApp (_, t1, t2) -> - type_parameters_and_type_name t1 - (optional_type_parameters t2 acc) - | Ast.TyId (_, i) -> ((ident i), acc) - | _ -> assert false - - let mkwithtyp pwith_type loc id_tpl ct = - let (id, tpl) = type_parameters_and_type_name id_tpl [] in - let (params, variance) = List.split tpl in - let (kind, priv, ct) = opt_private_ctyp ct - in - (id, - (pwith_type - { - ptype_params = params; - ptype_cstrs = []; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = Some ct; - ptype_loc = mkloc loc; - ptype_variance = variance; - })) - - let rec mkwithc wc acc = - match wc with - | Ast.WcNil _ -> acc - | Ast.WcTyp (loc, id_tpl, ct) -> - (mkwithtyp (fun x -> Pwith_type x) loc id_tpl ct) :: acc - | Ast.WcMod (_, i1, i2) -> - ((long_uident i1), (Pwith_module (long_uident i2))) :: acc - | Ast.WcTyS (loc, id_tpl, ct) -> - (mkwithtyp (fun x -> Pwith_typesubst x) loc id_tpl ct) :: - acc - | Ast.WcMoS (_, i1, i2) -> - ((long_uident i1), (Pwith_modsubst (long_uident i2))) :: - acc - | Ast.WcAnd (_, wc1, wc2) -> mkwithc wc1 (mkwithc wc2 acc) - | Ast.WcAnt (loc, _) -> - error loc "bad with constraint (antiquotation)" - - let rec patt_fa al = - function - | PaApp (_, f, a) -> patt_fa (a :: al) f - | f -> (f, al) - - let rec deep_mkrangepat loc c1 c2 = - if c1 = c2 - then mkghpat loc (Ppat_constant (Const_char c1)) - else - mkghpat loc - (Ppat_or ((mkghpat loc (Ppat_constant (Const_char c1))), - (deep_mkrangepat loc (Char.chr ((Char.code c1) + 1)) c2))) - - let rec mkrangepat loc c1 c2 = - if c1 > c2 - then mkrangepat loc c2 c1 - else - if c1 = c2 - then mkpat loc (Ppat_constant (Const_char c1)) - else - mkpat loc - (Ppat_or ((mkghpat loc (Ppat_constant (Const_char c1))), - (deep_mkrangepat loc (Char.chr ((Char.code c1) + 1)) - c2))) - - let rec patt = - function - | Ast.PaId (loc, (Ast.IdLid (sloc, s))) -> - mkpat loc (Ppat_var (with_loc s sloc)) - | Ast.PaId (loc, i) -> - let p = - Ppat_construct ((long_uident ~conv_con i), None, - (constructors_arity ())) - in mkpat loc p - | PaAli (loc, p1, p2) -> - let (p, i) = - (match (p1, p2) with - | (p, Ast.PaId (_, (Ast.IdLid (sloc, s)))) -> - (p, (with_loc s sloc)) - | (Ast.PaId (_, (Ast.IdLid (sloc, s))), p) -> - (p, (with_loc s sloc)) - | _ -> error loc "invalid alias pattern") - in mkpat loc (Ppat_alias ((patt p), i)) - | PaAnt (loc, _) -> error loc "antiquotation not allowed here" - | PaAny loc -> mkpat loc Ppat_any - | Ast.PaApp (loc, (Ast.PaId (_, (Ast.IdUid (sloc, s)))), - (Ast.PaTup (_, (Ast.PaAny loc_any)))) -> - mkpat loc - (Ppat_construct ((lident_with_loc (conv_con s) sloc), - (Some (mkpat loc_any Ppat_any)), false)) - | (PaApp (loc, _, _) as f) -> - let (f, al) = patt_fa [] f in - let al = List.map patt al - in - (match (patt f).ppat_desc with - | Ppat_construct (li, None, _) -> - if constructors_arity () - then - mkpat loc - (Ppat_construct (li, - (Some (mkpat loc (Ppat_tuple al))), true)) - else - (let a = - match al with - | [ a ] -> a - | _ -> mkpat loc (Ppat_tuple al) - in - mkpat loc - (Ppat_construct (li, (Some a), false))) - | Ppat_variant (s, None) -> - let a = - if constructors_arity () - then mkpat loc (Ppat_tuple al) - else - (match al with - | [ a ] -> a - | _ -> mkpat loc (Ppat_tuple al)) - in mkpat loc (Ppat_variant (s, (Some a))) - | _ -> - error (loc_of_patt f) - "this is not a constructor, it cannot be applied in a pattern") - | PaArr (loc, p) -> - mkpat loc (Ppat_array (List.map patt (list_of_patt p []))) - | PaChr (loc, s) -> - mkpat loc - (Ppat_constant (Const_char (char_of_char_token loc s))) - | PaInt (loc, s) -> - let i = - (try int_of_string s - with - | Failure _ -> - error loc - "Integer literal exceeds the range of representable integers of type int") - in mkpat loc (Ppat_constant (Const_int i)) - | PaInt32 (loc, s) -> - let i32 = - (try Int32.of_string s - with - | Failure _ -> - error loc - "Integer literal exceeds the range of representable integers of type int32") - in mkpat loc (Ppat_constant (Const_int32 i32)) - | PaInt64 (loc, s) -> - let i64 = - (try Int64.of_string s - with - | Failure _ -> - error loc - "Integer literal exceeds the range of representable integers of type int64") - in mkpat loc (Ppat_constant (Const_int64 i64)) - | PaNativeInt (loc, s) -> - let nati = - (try Nativeint.of_string s - with - | Failure _ -> - error loc - "Integer literal exceeds the range of representable integers of type nativeint") - in mkpat loc (Ppat_constant (Const_nativeint nati)) - | PaFlo (loc, s) -> - mkpat loc - (Ppat_constant (Const_float (remove_underscores s))) - | PaLab (loc, _, _) -> - error loc "labeled pattern not allowed here" - | PaOlb (loc, _, _) | PaOlbi (loc, _, _, _) -> - error loc "labeled pattern not allowed here" - | PaOrp (loc, p1, p2) -> - mkpat loc (Ppat_or ((patt p1), (patt p2))) - | PaRng (loc, p1, p2) -> - (match (p1, p2) with - | (PaChr (loc1, c1), PaChr (loc2, c2)) -> - let c1 = char_of_char_token loc1 c1 in - let c2 = char_of_char_token loc2 c2 - in mkrangepat loc c1 c2 - | _ -> - error loc "range pattern allowed only for characters") - | PaRec (loc, p) -> - let ps = list_of_patt p [] in - let is_wildcard = - (function | Ast.PaAny _ -> true | _ -> false) in - let (wildcards, ps) = List.partition is_wildcard ps in - let is_closed = if wildcards = [] then Closed else Open - in - mkpat loc - (Ppat_record (((List.map mklabpat ps), is_closed))) - | PaStr (loc, s) -> - mkpat loc - (Ppat_constant - (Const_string (string_of_string_token loc s))) - | Ast.PaTup (loc, (Ast.PaCom (_, p1, p2))) -> - mkpat loc - (Ppat_tuple - (List.map patt (list_of_patt p1 (list_of_patt p2 [])))) - | Ast.PaTup (loc, _) -> error loc "singleton tuple pattern" - | PaTyc (loc, p, t) -> - mkpat loc (Ppat_constraint ((patt p), (ctyp t))) - | PaTyp (loc, i) -> mkpat loc (Ppat_type (long_type_ident i)) - | PaVrn (loc, s) -> - mkpat loc (Ppat_variant ((conv_con s), None)) - | PaLaz (loc, p) -> mkpat loc (Ppat_lazy (patt p)) - | PaMod (loc, m) -> mkpat loc (Ppat_unpack (with_loc m loc)) - | (PaEq (_, _, _) | PaSem (_, _, _) | PaCom (_, _, _) | PaNil _ - as p) -> error (loc_of_patt p) "invalid pattern" - and mklabpat = - function - | Ast.PaEq (_, i, p) -> - ((ident ~conv_lid: conv_lab i), (patt p)) - | p -> error (loc_of_patt p) "invalid pattern" - - let rec expr_fa al = - function - | ExApp (_, f, a) -> expr_fa (a :: al) f - | f -> (f, al) - - let rec class_expr_fa al = - function - | CeApp (_, ce, a) -> class_expr_fa (a :: al) ce - | ce -> (ce, al) - - let rec sep_expr_acc l = - function - | ExAcc (_, e1, e2) -> sep_expr_acc (sep_expr_acc l e2) e1 - | (Ast.ExId (loc, (Ast.IdUid (_, s))) as e) -> - (match l with - | [] -> [ (loc, [], e) ] - | (loc', sl, e) :: l -> - ((Loc.merge loc loc'), (s :: sl), e) :: l) - | Ast.ExId (_, ((Ast.IdAcc (_, _, _) as i))) -> - let rec normalize_acc = - (function - | Ast.IdAcc (_loc, i1, i2) -> - Ast.ExAcc (_loc, (normalize_acc i1), - (normalize_acc i2)) - | Ast.IdApp (_loc, i1, i2) -> - Ast.ExApp (_loc, (normalize_acc i1), - (normalize_acc i2)) - | (Ast.IdAnt (_loc, _) | Ast.IdUid (_loc, _) | - Ast.IdLid (_loc, _) - as i) -> Ast.ExId (_loc, i)) - in sep_expr_acc l (normalize_acc i) - | e -> ((loc_of_expr e), [], e) :: l - - let override_flag loc = - function - | Ast.OvOverride -> Override - | Ast.OvNil -> Fresh - | _ -> error loc "antiquotation not allowed here" - - let list_of_opt_ctyp ot acc = - match ot with | Ast.TyNil _ -> acc | t -> list_of_ctyp t acc - - let varify_constructors var_names = - let rec loop t = - let desc = - match t.ptyp_desc with - | Ptyp_any -> Ptyp_any - | Ptyp_var x -> Ptyp_var x - | Ptyp_arrow (label, core_type, core_type') -> - Ptyp_arrow (label, (loop core_type), (loop core_type')) - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr ({ txt = Lident s }, []) when - List.mem s var_names -> Ptyp_var ("&" ^ s) - | Ptyp_constr (longident, lst) -> - Ptyp_constr (longident, (List.map loop lst)) - | Ptyp_object lst -> - Ptyp_object (List.map loop_core_field lst) - | Ptyp_class (longident, lst, lbl_list) -> - Ptyp_class ((longident, (List.map loop lst), lbl_list)) - | Ptyp_alias (core_type, string) -> - Ptyp_alias (((loop core_type), string)) - | Ptyp_variant (row_field_list, flag, lbl_lst_option) -> - Ptyp_variant - (((List.map loop_row_field row_field_list), flag, - lbl_lst_option)) - | Ptyp_poly (string_lst, core_type) -> - Ptyp_poly ((string_lst, (loop core_type))) - | Ptyp_package (longident, lst) -> - Ptyp_package - ((longident, - (List.map (fun (n, typ) -> (n, (loop typ))) lst))) - in { (t) with ptyp_desc = desc; } - and loop_core_field t = - let desc = - match t.pfield_desc with - | Pfield ((n, typ)) -> Pfield ((n, (loop typ))) - | Pfield_var -> Pfield_var - in { (t) with pfield_desc = desc; } - and loop_row_field x = - match x with - | Rtag ((label, flag, lst)) -> - Rtag ((label, flag, (List.map loop lst))) - | Rinherit t -> Rinherit (loop t) - in loop - - let rec expr = - function - | Ast.ExAcc (loc, x, (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> - mkexp loc - (Pexp_apply - ((mkexp loc (Pexp_ident (lident_with_loc "!" loc))), - [ ("", (expr x)) ])) - | (ExAcc (loc, _, _) | Ast.ExId (loc, (Ast.IdAcc (_, _, _))) as - e) -> - let (e, l) = - (match sep_expr_acc [] e with - | (loc, ml, Ast.ExId (sloc, (Ast.IdUid (_, s)))) :: l -> - let ca = constructors_arity () - in - ((mkexp loc - (Pexp_construct ((mkli sloc (conv_con s) ml), - None, ca))), - l) - | (loc, ml, Ast.ExId (sloc, (Ast.IdLid (_, s)))) :: l -> - ((mkexp loc (Pexp_ident (mkli sloc s ml))), l) - | (_, [], e) :: l -> ((expr e), l) - | _ -> error loc "bad ast in expression") in - let (_, e) = - List.fold_left - (fun (loc_bp, e1) (loc_ep, ml, e2) -> - match e2 with - | Ast.ExId (sloc, (Ast.IdLid (_, s))) -> - let loc = Loc.merge loc_bp loc_ep - in - (loc, - (mkexp loc - (Pexp_field (e1, - (mkli sloc (conv_lab s) ml))))) - | _ -> - error (loc_of_expr e2) - "lowercase identifier expected") - (loc, e) l - in e - | ExAnt (loc, _) -> error loc "antiquotation not allowed here" - | (ExApp (loc, _, _) as f) -> - let (f, al) = expr_fa [] f in - let al = List.map label_expr al - in - (match (expr f).pexp_desc with - | Pexp_construct (li, None, _) -> - let al = List.map snd al - in - if constructors_arity () - then - mkexp loc - (Pexp_construct (li, - (Some (mkexp loc (Pexp_tuple al))), true)) - else - (let a = - match al with - | [ a ] -> a - | _ -> mkexp loc (Pexp_tuple al) - in - mkexp loc - (Pexp_construct (li, (Some a), false))) - | Pexp_variant (s, None) -> - let al = List.map snd al in - let a = - if constructors_arity () - then mkexp loc (Pexp_tuple al) - else - (match al with - | [ a ] -> a - | _ -> mkexp loc (Pexp_tuple al)) - in mkexp loc (Pexp_variant (s, (Some a))) - | _ -> mkexp loc (Pexp_apply ((expr f), al))) - | ExAre (loc, e1, e2) -> - mkexp loc - (Pexp_apply - ((mkexp loc - (Pexp_ident (array_function loc "Array" "get"))), - [ ("", (expr e1)); ("", (expr e2)) ])) - | ExArr (loc, e) -> - mkexp loc (Pexp_array (List.map expr (list_of_expr e []))) - | ExAsf loc -> mkexp loc Pexp_assertfalse - | ExAss (loc, e, v) -> - let e = - (match e with - | Ast.ExAcc (loc, x, - (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> - Pexp_apply - ((mkexp loc - (Pexp_ident (lident_with_loc ":=" loc))), - [ ("", (expr x)); ("", (expr v)) ]) - | ExAcc (loc, _, _) -> - (match (expr e).pexp_desc with - | Pexp_field (e, lab) -> - Pexp_setfield (e, lab, (expr v)) - | _ -> error loc "bad record access") - | ExAre (loc, e1, e2) -> - Pexp_apply - ((mkexp loc - (Pexp_ident (array_function loc "Array" "set"))), - [ ("", (expr e1)); ("", (expr e2)); ("", (expr v)) ]) - | Ast.ExId (_, (Ast.IdLid (lloc, lab))) -> - Pexp_setinstvar ((with_loc lab lloc), (expr v)) - | ExSte (loc, e1, e2) -> - Pexp_apply - ((mkexp loc - (Pexp_ident - (array_function loc "String" "set"))), - [ ("", (expr e1)); ("", (expr e2)); ("", (expr v)) ]) - | _ -> error loc "bad left part of assignment") - in mkexp loc e - | ExAsr (loc, e) -> mkexp loc (Pexp_assert (expr e)) - | ExChr (loc, s) -> - mkexp loc - (Pexp_constant (Const_char (char_of_char_token loc s))) - | ExCoe (loc, e, t1, t2) -> - let t1 = - (match t1 with | Ast.TyNil _ -> None | t -> Some (ctyp t)) - in - mkexp loc - (Pexp_constraint ((expr e), t1, (Some (ctyp t2)))) - | ExFlo (loc, s) -> - mkexp loc - (Pexp_constant (Const_float (remove_underscores s))) - | ExFor (loc, i, e1, e2, df, el) -> - let e3 = ExSeq (loc, el) - in - mkexp loc - (Pexp_for ((with_loc i loc), (expr e1), (expr e2), - (mkdirection df), (expr e3))) - | Ast.ExFun (loc, (Ast.McArr (_, (PaLab (_, lab, po)), w, e))) - -> - mkexp loc - (Pexp_function (lab, None, - [ ((patt_of_lab loc lab po), (when_expr e w)) ])) - | Ast.ExFun (loc, - (Ast.McArr (_, (PaOlbi (_, lab, p, e1)), w, e2))) -> - let lab = paolab lab p - in - mkexp loc - (Pexp_function (("?" ^ lab), (Some (expr e1)), - [ ((patt p), (when_expr e2 w)) ])) - | Ast.ExFun (loc, (Ast.McArr (_, (PaOlb (_, lab, p)), w, e))) - -> - let lab = paolab lab p - in - mkexp loc - (Pexp_function (("?" ^ lab), None, - [ ((patt_of_lab loc lab p), (when_expr e w)) ])) - | ExFun (loc, a) -> - mkexp loc (Pexp_function ("", None, (match_case a []))) - | ExIfe (loc, e1, e2, e3) -> - mkexp loc - (Pexp_ifthenelse ((expr e1), (expr e2), (Some (expr e3)))) - | ExInt (loc, s) -> - let i = - (try int_of_string s - with - | Failure _ -> - error loc - "Integer literal exceeds the range of representable integers of type int") - in mkexp loc (Pexp_constant (Const_int i)) - | ExInt32 (loc, s) -> - let i32 = - (try Int32.of_string s - with - | Failure _ -> - error loc - "Integer literal exceeds the range of representable integers of type int32") - in mkexp loc (Pexp_constant (Const_int32 i32)) - | ExInt64 (loc, s) -> - let i64 = - (try Int64.of_string s - with - | Failure _ -> - error loc - "Integer literal exceeds the range of representable integers of type int64") - in mkexp loc (Pexp_constant (Const_int64 i64)) - | ExNativeInt (loc, s) -> - let nati = - (try Nativeint.of_string s - with - | Failure _ -> - error loc - "Integer literal exceeds the range of representable integers of type nativeint") - in mkexp loc (Pexp_constant (Const_nativeint nati)) - | ExLab (loc, _, _) -> - error loc "labeled expression not allowed here" - | ExLaz (loc, e) -> mkexp loc (Pexp_lazy (expr e)) - | ExLet (loc, rf, bi, e) -> - mkexp loc (Pexp_let ((mkrf rf), (binding bi []), (expr e))) - | ExLmd (loc, i, me, e) -> - mkexp loc - (Pexp_letmodule ((with_loc i loc), (module_expr me), - (expr e))) - | ExMat (loc, e, a) -> - mkexp loc (Pexp_match ((expr e), (match_case a []))) - | ExNew (loc, id) -> mkexp loc (Pexp_new (long_type_ident id)) - | ExObj (loc, po, cfl) -> - let p = - (match po with | Ast.PaNil _ -> Ast.PaAny loc | p -> p) in - let cil = class_str_item cfl [] - in - mkexp loc - (Pexp_object - { pcstr_pat = patt p; pcstr_fields = cil; }) - | ExOlb (loc, _, _) -> - error loc "labeled expression not allowed here" - | ExOvr (loc, iel) -> - mkexp loc (Pexp_override (mkideexp iel [])) - | ExRec (loc, lel, eo) -> - (match lel with - | Ast.RbNil _ -> error loc "empty record" - | _ -> - let eo = - (match eo with - | Ast.ExNil _ -> None - | e -> Some (expr e)) - in mkexp loc (Pexp_record ((mklabexp lel []), eo))) - | ExSeq (_loc, e) -> - let rec loop = - (function - | [] -> expr (Ast.ExId (_loc, (Ast.IdUid (_loc, "()")))) - | [ e ] -> expr e - | e :: el -> - let _loc = Loc.merge (loc_of_expr e) _loc - in mkexp _loc (Pexp_sequence ((expr e), (loop el)))) - in loop (list_of_expr e []) - | ExSnd (loc, e, s) -> mkexp loc (Pexp_send ((expr e), s)) - | ExSte (loc, e1, e2) -> - mkexp loc - (Pexp_apply - ((mkexp loc - (Pexp_ident (array_function loc "String" "get"))), - [ ("", (expr e1)); ("", (expr e2)) ])) - | ExStr (loc, s) -> - mkexp loc - (Pexp_constant - (Const_string (string_of_string_token loc s))) - | ExTry (loc, e, a) -> - mkexp loc (Pexp_try ((expr e), (match_case a []))) - | Ast.ExTup (loc, (Ast.ExCom (_, e1, e2))) -> - mkexp loc - (Pexp_tuple - (List.map expr (list_of_expr e1 (list_of_expr e2 [])))) - | Ast.ExTup (loc, _) -> error loc "singleton tuple" - | ExTyc (loc, e, t) -> - mkexp loc - (Pexp_constraint ((expr e), (Some (ctyp t)), None)) - | Ast.ExId (loc, (Ast.IdUid (_, "()"))) -> - mkexp loc - (Pexp_construct ((lident_with_loc "()" loc), None, true)) - | Ast.ExId (loc, (Ast.IdLid (_, s))) -> - mkexp loc (Pexp_ident (lident_with_loc s loc)) - | Ast.ExId (loc, (Ast.IdUid (_, s))) -> - mkexp loc - (Pexp_construct ((lident_with_loc (conv_con s) loc), - None, true)) - | ExVrn (loc, s) -> - mkexp loc (Pexp_variant ((conv_con s), None)) - | ExWhi (loc, e1, el) -> - let e2 = ExSeq (loc, el) - in mkexp loc (Pexp_while ((expr e1), (expr e2))) - | Ast.ExOpI (loc, i, e) -> - mkexp loc (Pexp_open (Fresh, (long_uident i), (expr e))) - | Ast.ExPkg (loc, (Ast.MeTyc (_, me, pt))) -> - mkexp loc - (Pexp_constraint - (((mkexp loc (Pexp_pack (module_expr me))), - (Some (mktyp loc (Ptyp_package (package_type pt)))), - None))) - | Ast.ExPkg (loc, me) -> mkexp loc (Pexp_pack (module_expr me)) - | ExFUN (loc, i, e) -> mkexp loc (Pexp_newtype (i, (expr e))) - | Ast.ExCom (loc, _, _) -> - error loc "expr, expr: not allowed here" - | Ast.ExSem (loc, _, _) -> - error loc - "expr; expr: not allowed here, use do {...} or [|...|] to surround them" - | (ExId (_, _) | ExNil _ as e) -> - error (loc_of_expr e) "invalid expr" - and patt_of_lab _loc lab = - function - | Ast.PaNil _ -> - patt (Ast.PaId (_loc, (Ast.IdLid (_loc, lab)))) - | p -> patt p - and expr_of_lab _loc lab = - function - | Ast.ExNil _ -> - expr (Ast.ExId (_loc, (Ast.IdLid (_loc, lab)))) - | e -> expr e - and label_expr = - function - | ExLab (loc, lab, eo) -> (lab, (expr_of_lab loc lab eo)) - | ExOlb (loc, lab, eo) -> - (("?" ^ lab), (expr_of_lab loc lab eo)) - | e -> ("", (expr e)) - and binding x acc = - match x with - | Ast.BiAnd (_, x, y) -> binding x (binding y acc) - | Ast.BiEq (_loc, - (Ast.PaId (sloc, (Ast.IdLid (_, bind_name)))), - (Ast.ExTyc (_, e, (TyTypePol (_, vs, ty))))) -> - let rec id_to_string x = - (match x with - | Ast.TyId (_, (Ast.IdLid (_, x))) -> [ x ] - | Ast.TyApp (_, x, y) -> - (id_to_string x) @ (id_to_string y) - | _ -> assert false) in - let vars = id_to_string vs in - let ampersand_vars = List.map (fun x -> "&" ^ x) vars in - let ty' = varify_constructors vars (ctyp ty) in - let mkexp = mkexp _loc in - let mkpat = mkpat _loc in - let e = - mkexp - (Pexp_constraint ((expr e), (Some (ctyp ty)), None)) in - let rec mk_newtypes x = - (match x with - | [ newtype ] -> mkexp (Pexp_newtype ((newtype, e))) - | newtype :: newtypes -> - mkexp - (Pexp_newtype ((newtype, (mk_newtypes newtypes)))) - | [] -> assert false) in - let pat = - mkpat - (Ppat_constraint - (((mkpat (Ppat_var (with_loc bind_name sloc))), - (mktyp _loc (Ptyp_poly (ampersand_vars, ty')))))) in - let e = mk_newtypes vars in (pat, e) :: acc - | Ast.BiEq (_loc, p, - (Ast.ExTyc (_, e, (Ast.TyPol (_, vs, ty))))) -> - ((patt (Ast.PaTyc (_loc, p, (Ast.TyPol (_loc, vs, ty))))), - (expr e)) :: acc - | Ast.BiEq (_, p, e) -> ((patt p), (expr e)) :: acc - | Ast.BiNil _ -> acc - | _ -> assert false - and match_case x acc = - match x with - | Ast.McOr (_, x, y) -> match_case x (match_case y acc) - | Ast.McArr (_, p, w, e) -> ((patt p), (when_expr e w)) :: acc - | Ast.McNil _ -> acc - | _ -> assert false - and when_expr e w = - match w with - | Ast.ExNil _ -> expr e - | w -> mkexp (loc_of_expr w) (Pexp_when ((expr w), (expr e))) - and mklabexp x acc = - match x with - | Ast.RbSem (_, x, y) -> mklabexp x (mklabexp y acc) - | Ast.RbEq (_, i, e) -> - ((ident ~conv_lid: conv_lab i), (expr e)) :: acc - | _ -> assert false - and mkideexp x acc = - match x with - | Ast.RbNil _ -> acc - | Ast.RbSem (_, x, y) -> mkideexp x (mkideexp y acc) - | Ast.RbEq (_, (Ast.IdLid (sloc, s)), e) -> - ((with_loc s sloc), (expr e)) :: acc - | _ -> assert false - and mktype_decl x acc = - match x with - | Ast.TyAnd (_, x, y) -> mktype_decl x (mktype_decl y acc) - | Ast.TyDcl (cloc, c, tl, td, cl) -> - let cl = - List.map - (fun (t1, t2) -> - let loc = - Loc.merge (loc_of_ctyp t1) (loc_of_ctyp t2) - in ((ctyp t1), (ctyp t2), (mkloc loc))) - cl - in - ((with_loc c cloc), - (type_decl - (List.fold_right optional_type_parameters tl []) cl - td cloc)) :: - acc - | _ -> assert false - and module_type = - function - | Ast.MtNil loc -> - error loc "abstract/nil module type not allowed here" - | Ast.MtId (loc, i) -> mkmty loc (Pmty_ident (long_uident i)) - | Ast.MtFun (loc, n, nt, mt) -> - mkmty loc - (Pmty_functor ((with_loc n loc), (module_type nt), - (module_type mt))) - | Ast.MtQuo (loc, _) -> - error loc "module type variable not allowed here" - | Ast.MtSig (loc, sl) -> - mkmty loc (Pmty_signature (sig_item sl [])) - | Ast.MtWit (loc, mt, wc) -> - mkmty loc (Pmty_with ((module_type mt), (mkwithc wc []))) - | Ast.MtOf (loc, me) -> - mkmty loc (Pmty_typeof (module_expr me)) - | Ast.MtAnt (_, _) -> assert false - and sig_item s l = - match s with - | Ast.SgNil _ -> l - | SgCls (loc, cd) -> - (mksig loc - (Psig_class - (List.map class_info_class_type - (list_of_class_type cd [])))) :: - l - | SgClt (loc, ctd) -> - (mksig loc - (Psig_class_type - (List.map class_info_class_type - (list_of_class_type ctd [])))) :: - l - | Ast.SgSem (_, sg1, sg2) -> sig_item sg1 (sig_item sg2 l) - | SgDir (_, _, _) -> l - | Ast.SgExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s))))) -> - (mksig loc - (Psig_exception ((with_loc (conv_con s) loc), []))) :: - l - | Ast.SgExc (loc, - (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t))) -> - (mksig loc - (Psig_exception ((with_loc (conv_con s) loc), - (List.map ctyp (list_of_ctyp t []))))) :: - l - | SgExc (_, _) -> assert false - | SgExt (loc, n, t, sl) -> - (mksig loc - (Psig_value ((with_loc n loc), - (mkvalue_desc loc t (list_of_meta_list sl))))) :: - l - | SgInc (loc, mt) -> - (mksig loc (Psig_include (module_type mt))) :: l - | SgMod (loc, n, mt) -> - (mksig loc - (Psig_module ((with_loc n loc), (module_type mt)))) :: - l - | SgRecMod (loc, mb) -> - (mksig loc (Psig_recmodule (module_sig_binding mb []))) :: - l - | SgMty (loc, n, mt) -> - let si = - (match mt with - | MtQuo (_, _) -> Pmodtype_abstract - | _ -> Pmodtype_manifest (module_type mt)) - in (mksig loc (Psig_modtype ((with_loc n loc), si))) :: l - | SgOpn (loc, id) -> - (mksig loc (Psig_open (Fresh, (long_uident id)))) :: l - | SgTyp (loc, tdl) -> - (mksig loc (Psig_type (mktype_decl tdl []))) :: l - | SgVal (loc, n, t) -> - (mksig loc - (Psig_value ((with_loc n loc), (mkvalue_desc loc t [])))) :: - l - | Ast.SgAnt (loc, _) -> error loc "antiquotation in sig_item" - and module_sig_binding x acc = - match x with - | Ast.MbAnd (_, x, y) -> - module_sig_binding x (module_sig_binding y acc) - | Ast.MbCol (loc, s, mt) -> - ((with_loc s loc), (module_type mt)) :: acc - | _ -> assert false - and module_str_binding x acc = - match x with - | Ast.MbAnd (_, x, y) -> - module_str_binding x (module_str_binding y acc) - | Ast.MbColEq (loc, s, mt, me) -> - ((with_loc s loc), (module_type mt), (module_expr me)) :: - acc - | _ -> assert false - and module_expr = - function - | Ast.MeNil loc -> error loc "nil module expression" - | Ast.MeId (loc, i) -> mkmod loc (Pmod_ident (long_uident i)) - | Ast.MeApp (loc, me1, me2) -> - mkmod loc - (Pmod_apply ((module_expr me1), (module_expr me2))) - | Ast.MeFun (loc, n, mt, me) -> - mkmod loc - (Pmod_functor ((with_loc n loc), (module_type mt), - (module_expr me))) - | Ast.MeStr (loc, sl) -> - mkmod loc (Pmod_structure (str_item sl [])) - | Ast.MeTyc (loc, me, mt) -> - mkmod loc - (Pmod_constraint ((module_expr me), (module_type mt))) - | Ast.MePkg (loc, (Ast.ExTyc (_, e, (Ast.TyPkg (_, pt))))) -> - mkmod loc - (Pmod_unpack - (mkexp loc - (Pexp_constraint - (((expr e), - (Some - (mktyp loc (Ptyp_package (package_type pt)))), - None))))) - | Ast.MePkg (loc, e) -> mkmod loc (Pmod_unpack (expr e)) - | Ast.MeAnt (loc, _) -> - error loc "antiquotation in module_expr" - and str_item s l = - match s with - | Ast.StNil _ -> l - | StCls (loc, cd) -> - (mkstr loc - (Pstr_class - (List.map class_info_class_expr - (list_of_class_expr cd [])))) :: - l - | StClt (loc, ctd) -> - (mkstr loc - (Pstr_class_type - (List.map class_info_class_type - (list_of_class_type ctd [])))) :: - l - | Ast.StSem (_, st1, st2) -> str_item st1 (str_item st2 l) - | StDir (_, _, _) -> l - | Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), Ast. - ONone) -> - (mkstr loc - (Pstr_exception ((with_loc (conv_con s) loc), []))) :: - l - | Ast.StExc (loc, - (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t)), Ast. - ONone) -> - (mkstr loc - (Pstr_exception ((with_loc (conv_con s) loc), - (List.map ctyp (list_of_ctyp t []))))) :: - l - | Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), - (Ast.OSome i)) -> - (mkstr loc - (Pstr_exn_rebind ((with_loc (conv_con s) loc), - (long_uident ~conv_con i)))) :: - l - | Ast.StExc (loc, - (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, _)))), _)), - (Ast.OSome _)) -> error loc "type in exception alias" - | StExc (_, _, _) -> assert false - | StExp (loc, e) -> (mkstr loc (Pstr_eval (expr e))) :: l - | StExt (loc, n, t, sl) -> - (mkstr loc - (Pstr_primitive ((with_loc n loc), - (mkvalue_desc loc t (list_of_meta_list sl))))) :: - l - | StInc (loc, me) -> - (mkstr loc (Pstr_include (module_expr me))) :: l - | StMod (loc, n, me) -> - (mkstr loc - (Pstr_module ((with_loc n loc), (module_expr me)))) :: - l - | StRecMod (loc, mb) -> - (mkstr loc (Pstr_recmodule (module_str_binding mb []))) :: - l - | StMty (loc, n, mt) -> - (mkstr loc - (Pstr_modtype ((with_loc n loc), (module_type mt)))) :: - l - | StOpn (loc, id) -> - (mkstr loc (Pstr_open (Fresh, (long_uident id)))) :: l - | StTyp (loc, tdl) -> - (mkstr loc (Pstr_type (mktype_decl tdl []))) :: l - | StVal (loc, rf, bi) -> - (mkstr loc (Pstr_value ((mkrf rf), (binding bi [])))) :: l - | Ast.StAnt (loc, _) -> error loc "antiquotation in str_item" - and class_type = - function - | CtCon (loc, ViNil, id, tl) -> - mkcty loc - (Pcty_constr ((long_class_ident id), - (List.map ctyp (list_of_opt_ctyp tl [])))) - | CtFun (loc, (TyLab (_, lab, t)), ct) -> - mkcty loc (Pcty_fun (lab, (ctyp t), (class_type ct))) - | CtFun (loc, (TyOlb (loc1, lab, t)), ct) -> - let t = TyApp (loc1, (predef_option loc1), t) - in - mkcty loc - (Pcty_fun (("?" ^ lab), (ctyp t), (class_type ct))) - | CtFun (loc, t, ct) -> - mkcty loc (Pcty_fun ("", (ctyp t), (class_type ct))) - | CtSig (loc, t_o, ctfl) -> - let t = - (match t_o with | Ast.TyNil _ -> Ast.TyAny loc | t -> t) in - let cil = class_sig_item ctfl [] - in - mkcty loc - (Pcty_signature - { - pcsig_self = ctyp t; - pcsig_fields = cil; - pcsig_loc = mkloc loc; - }) - | CtCon (loc, _, _, _) -> - error loc "invalid virtual class inside a class type" - | CtAnt (_, _) | CtEq (_, _, _) | CtCol (_, _, _) | - CtAnd (_, _, _) | CtNil _ -> assert false - and class_info_class_expr ci = - match ci with - | CeEq (_, (CeCon (loc, vir, (IdLid (nloc, name)), params)), - ce) -> - let (loc_params, (params, variance)) = - (match params with - | Ast.TyNil _ -> (loc, ([], [])) - | t -> - ((loc_of_ctyp t), - (List.split (class_parameters t [])))) - in - { - pci_virt = mkvirtual vir; - pci_params = (params, (mkloc loc_params)); - pci_name = with_loc name nloc; - pci_expr = class_expr ce; - pci_loc = mkloc loc; - pci_variance = variance; - } - | ce -> error (loc_of_class_expr ce) "bad class definition" - and class_info_class_type ci = - match ci with - | CtEq (_, (CtCon (loc, vir, (IdLid (nloc, name)), params)), - ct) | - CtCol (_, (CtCon (loc, vir, (IdLid (nloc, name)), params)), - ct) - -> - let (loc_params, (params, variance)) = - (match params with - | Ast.TyNil _ -> (loc, ([], [])) - | t -> - ((loc_of_ctyp t), - (List.split (class_parameters t [])))) - in - { - pci_virt = mkvirtual vir; - pci_params = (params, (mkloc loc_params)); - pci_name = with_loc name nloc; - pci_expr = class_type ct; - pci_loc = mkloc loc; - pci_variance = variance; - } - | ct -> - error (loc_of_class_type ct) - "bad class/class type declaration/definition" - and class_sig_item c l = - match c with - | Ast.CgNil _ -> l - | CgCtr (loc, t1, t2) -> - (mkctf loc (Pctf_cstr (((ctyp t1), (ctyp t2))))) :: l - | Ast.CgSem (_, csg1, csg2) -> - class_sig_item csg1 (class_sig_item csg2 l) - | CgInh (loc, ct) -> - (mkctf loc (Pctf_inher (class_type ct))) :: l - | CgMth (loc, s, pf, t) -> - (mkctf loc - (Pctf_meth ((s, (mkprivate pf), (mkpolytype (ctyp t)))))) :: - l - | CgVal (loc, s, b, v, t) -> - (mkctf loc - (Pctf_val ((s, (mkmutable b), (mkvirtual v), (ctyp t))))) :: - l - | CgVir (loc, s, b, t) -> - (mkctf loc - (Pctf_virt ((s, (mkprivate b), (mkpolytype (ctyp t)))))) :: - l - | CgAnt (_, _) -> assert false - and class_expr = - function - | (CeApp (loc, _, _) as c) -> - let (ce, el) = class_expr_fa [] c in - let el = List.map label_expr el - in mkcl loc (Pcl_apply ((class_expr ce), el)) - | CeCon (loc, ViNil, id, tl) -> - mkcl loc - (Pcl_constr ((long_class_ident id), - (List.map ctyp (list_of_opt_ctyp tl [])))) - | CeFun (loc, (PaLab (_, lab, po)), ce) -> - mkcl loc - (Pcl_fun (lab, None, (patt_of_lab loc lab po), - (class_expr ce))) - | CeFun (loc, (PaOlbi (_, lab, p, e)), ce) -> - let lab = paolab lab p - in - mkcl loc - (Pcl_fun (("?" ^ lab), (Some (expr e)), (patt p), - (class_expr ce))) - | CeFun (loc, (PaOlb (_, lab, p)), ce) -> - let lab = paolab lab p - in - mkcl loc - (Pcl_fun (("?" ^ lab), None, (patt_of_lab loc lab p), - (class_expr ce))) - | CeFun (loc, p, ce) -> - mkcl loc (Pcl_fun ("", None, (patt p), (class_expr ce))) - | CeLet (loc, rf, bi, ce) -> - mkcl loc - (Pcl_let ((mkrf rf), (binding bi []), (class_expr ce))) - | CeStr (loc, po, cfl) -> - let p = - (match po with | Ast.PaNil _ -> Ast.PaAny loc | p -> p) in - let cil = class_str_item cfl [] - in - mkcl loc - (Pcl_structure - { pcstr_pat = patt p; pcstr_fields = cil; }) - | CeTyc (loc, ce, ct) -> - mkcl loc - (Pcl_constraint ((class_expr ce), (class_type ct))) - | CeCon (loc, _, _, _) -> - error loc "invalid virtual class inside a class expression" - | CeAnt (_, _) | CeEq (_, _, _) | CeAnd (_, _, _) | CeNil _ -> - assert false - and class_str_item c l = - match c with - | CrNil _ -> l - | CrCtr (loc, t1, t2) -> - (mkcf loc (Pcf_constr (((ctyp t1), (ctyp t2))))) :: l - | Ast.CrSem (_, cst1, cst2) -> - class_str_item cst1 (class_str_item cst2 l) - | CrInh (loc, ov, ce, pb) -> - let opb = if pb = "" then None else Some pb - in - (mkcf loc - (Pcf_inher ((override_flag loc ov), (class_expr ce), - opb))) :: - l - | CrIni (loc, e) -> (mkcf loc (Pcf_init (expr e))) :: l - | CrMth (loc, s, ov, pf, e, t) -> - let t = - (match t with - | Ast.TyNil _ -> None - | t -> Some (mkpolytype (ctyp t))) in - let e = mkexp loc (Pexp_poly ((expr e), t)) - in - (mkcf loc - (Pcf_meth - (((with_loc s loc), (mkprivate pf), - (override_flag loc ov), e)))) :: - l - | CrVal (loc, s, ov, mf, e) -> - (mkcf loc - (Pcf_val - (((with_loc s loc), (mkmutable mf), - (override_flag loc ov), (expr e))))) :: - l - | CrVir (loc, s, pf, t) -> - (mkcf loc - (Pcf_virt - (((with_loc s loc), (mkprivate pf), - (mkpolytype (ctyp t)))))) :: - l - | CrVvr (loc, s, mf, t) -> - (mkcf loc - (Pcf_valvirt - (((with_loc s loc), (mkmutable mf), (ctyp t))))) :: - l - | CrAnt (_, _) -> assert false - - let sig_item ast = sig_item ast [] - - let str_item ast = str_item ast [] - - let directive = - function - | Ast.ExNil _ -> Pdir_none - | ExStr (_, s) -> Pdir_string s - | ExInt (_, i) -> Pdir_int (int_of_string i) - | Ast.ExId (_, (Ast.IdUid (_, "True"))) -> Pdir_bool true - | Ast.ExId (_, (Ast.IdUid (_, "False"))) -> Pdir_bool false - | e -> Pdir_ident (ident_noloc (ident_of_expr e)) - - let phrase = - function - | StDir (_, d, dp) -> Ptop_dir (d, (directive dp)) - | si -> Ptop_def (str_item si) - - end - - end - - module CleanAst = - struct - module Make (Ast : Sig.Camlp4Ast) = - struct - class clean_ast = - object inherit Ast.map as super - method with_constr = - fun wc -> - match super#with_constr wc with - | Ast.WcAnd (_, (Ast.WcNil _), wc) | - Ast.WcAnd (_, wc, (Ast.WcNil _)) -> wc - | wc -> wc - method expr = - fun e -> - match super#expr e with - | Ast.ExLet (_, _, (Ast.BiNil _), e) | - Ast.ExRec (_, (Ast.RbNil _), e) | - Ast.ExCom (_, (Ast.ExNil _), e) | - Ast.ExCom (_, e, (Ast.ExNil _)) | - Ast.ExSem (_, (Ast.ExNil _), e) | - Ast.ExSem (_, e, (Ast.ExNil _)) -> e - | e -> e - method patt = - fun p -> - match super#patt p with - | Ast.PaAli (_, p, (Ast.PaNil _)) | - Ast.PaOrp (_, (Ast.PaNil _), p) | - Ast.PaOrp (_, p, (Ast.PaNil _)) | - Ast.PaCom (_, (Ast.PaNil _), p) | - Ast.PaCom (_, p, (Ast.PaNil _)) | - Ast.PaSem (_, (Ast.PaNil _), p) | - Ast.PaSem (_, p, (Ast.PaNil _)) -> p - | p -> p - method match_case = - fun mc -> - match super#match_case mc with - | Ast.McOr (_, (Ast.McNil _), mc) | - Ast.McOr (_, mc, (Ast.McNil _)) -> mc - | mc -> mc - method binding = - fun bi -> - match super#binding bi with - | Ast.BiAnd (_, (Ast.BiNil _), bi) | - Ast.BiAnd (_, bi, (Ast.BiNil _)) -> bi - | bi -> bi - method rec_binding = - fun rb -> - match super#rec_binding rb with - | Ast.RbSem (_, (Ast.RbNil _), bi) | - Ast.RbSem (_, bi, (Ast.RbNil _)) -> bi - | bi -> bi - method module_binding = - fun mb -> - match super#module_binding mb with - | Ast.MbAnd (_, (Ast.MbNil _), mb) | - Ast.MbAnd (_, mb, (Ast.MbNil _)) -> mb - | mb -> mb - method ctyp = - fun t -> - match super#ctyp t with - | Ast.TyPol (_, (Ast.TyNil _), t) | - Ast.TyAli (_, (Ast.TyNil _), t) | - Ast.TyAli (_, t, (Ast.TyNil _)) | - Ast.TyArr (_, t, (Ast.TyNil _)) | - Ast.TyArr (_, (Ast.TyNil _), t) | - Ast.TyOr (_, (Ast.TyNil _), t) | - Ast.TyOr (_, t, (Ast.TyNil _)) | - Ast.TyOf (_, t, (Ast.TyNil _)) | - Ast.TyAnd (_, (Ast.TyNil _), t) | - Ast.TyAnd (_, t, (Ast.TyNil _)) | - Ast.TySem (_, t, (Ast.TyNil _)) | - Ast.TySem (_, (Ast.TyNil _), t) | - Ast.TyCom (_, (Ast.TyNil _), t) | - Ast.TyCom (_, t, (Ast.TyNil _)) | - Ast.TyAmp (_, t, (Ast.TyNil _)) | - Ast.TyAmp (_, (Ast.TyNil _), t) | - Ast.TySta (_, (Ast.TyNil _), t) | - Ast.TySta (_, t, (Ast.TyNil _)) -> t - | t -> t - method sig_item = - fun sg -> - match super#sig_item sg with - | Ast.SgSem (_, (Ast.SgNil _), sg) | - Ast.SgSem (_, sg, (Ast.SgNil _)) -> sg - | Ast.SgTyp (loc, (Ast.TyNil _)) -> Ast.SgNil loc - | sg -> sg - method str_item = - fun st -> - match super#str_item st with - | Ast.StSem (_, (Ast.StNil _), st) | - Ast.StSem (_, st, (Ast.StNil _)) -> st - | Ast.StTyp (loc, (Ast.TyNil _)) -> Ast.StNil loc - | Ast.StVal (loc, _, (Ast.BiNil _)) -> Ast.StNil loc - | st -> st - method module_type = - fun mt -> - match super#module_type mt with - | Ast.MtWit (_, mt, (Ast.WcNil _)) -> mt - | mt -> mt - method class_expr = - fun ce -> - match super#class_expr ce with - | Ast.CeAnd (_, (Ast.CeNil _), ce) | - Ast.CeAnd (_, ce, (Ast.CeNil _)) -> ce - | ce -> ce - method class_type = - fun ct -> - match super#class_type ct with - | Ast.CtAnd (_, (Ast.CtNil _), ct) | - Ast.CtAnd (_, ct, (Ast.CtNil _)) -> ct - | ct -> ct - method class_sig_item = - fun csg -> - match super#class_sig_item csg with - | Ast.CgSem (_, (Ast.CgNil _), csg) | - Ast.CgSem (_, csg, (Ast.CgNil _)) -> csg - | csg -> csg - method class_str_item = - fun cst -> - match super#class_str_item cst with - | Ast.CrSem (_, (Ast.CrNil _), cst) | - Ast.CrSem (_, cst, (Ast.CrNil _)) -> cst - | cst -> cst - end - - end - - end - - module CommentFilter : - sig - module Make (Token : Sig.Camlp4Token) : - sig - open Token - - type t - - val mk : unit -> t - - val define : Token.Filter.t -> t -> unit - - val filter : - t -> (Token.t * Loc.t) Stream.t -> (Token.t * Loc.t) Stream.t - - val take_list : t -> (string * Loc.t) list - - val take_stream : t -> (string * Loc.t) Stream.t - - end - - end = - struct - module Make (Token : Sig.Camlp4Token) = - struct - open Token - - type t = - (((string * Loc.t) Stream.t) * ((string * Loc.t) Queue.t)) - - let mk () = - let q = Queue.create () in - let f _ = try Some (Queue.take q) with | Queue.Empty -> None - in ((Stream.from f), q) - - let filter (_, q) = - let rec self (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some ((Sig.COMMENT x, loc)) -> - (Stream.junk __strm; - let xs = __strm in (Queue.add (x, loc) q; self xs)) - | Some x -> - (Stream.junk __strm; - let xs = __strm - in Stream.icons x (Stream.slazy (fun _ -> self xs))) - | _ -> Stream.sempty - in self - - let take_list (_, q) = - let rec self accu = - if Queue.is_empty q - then accu - else self ((Queue.take q) :: accu) - in self [] - - let take_stream = fst - - let define token_fiter comments_strm = - Token.Filter.define_filter token_fiter - (fun previous strm -> previous (filter comments_strm strm)) - - end - - end - - module DynLoader : sig include Sig.DynLoader - end = - struct - type t = string Queue.t - - exception Error of string * string - - let include_dir x y = Queue.add y x - - let fold_load_path x f acc = Queue.fold (fun x y -> f y x) acc x - - let mk ?(ocaml_stdlib = true) ?(camlp4_stdlib = true) () = - let q = Queue.create () - in - (if ocaml_stdlib - then include_dir q Camlp4_config.ocaml_standard_library - else (); - if camlp4_stdlib - then - (include_dir q Camlp4_config.camlp4_standard_library; - include_dir q - (Filename.concat Camlp4_config.camlp4_standard_library - "Camlp4Parsers"); - include_dir q - (Filename.concat Camlp4_config.camlp4_standard_library - "Camlp4Printers"); - include_dir q - (Filename.concat Camlp4_config.camlp4_standard_library - "Camlp4Filters")) - else (); - include_dir q "."; - q) - - let find_in_path x name = - if not (Filename.is_implicit name) - then if Sys.file_exists name then name else raise Not_found - else - (let res = - fold_load_path x - (fun dir -> - function - | None -> - let fullname = Filename.concat dir name - in - if Sys.file_exists fullname - then Some fullname - else None - | x -> x) - None - in match res with | None -> raise Not_found | Some x -> x) - - let load = - let _initialized = ref false - in - fun _path file -> - (if not !_initialized - then - (try - (Dynlink.init (); - Dynlink.allow_unsafe_modules true; - _initialized := true) - with - | Dynlink.Error e -> - raise - (Error ("Camlp4's dynamic loader initialization", - (Dynlink.error_message e)))) - else (); - let fname = - try find_in_path _path file - with - | Not_found -> - raise (Error (file, "file not found in path")) - in - try Dynlink.loadfile fname - with - | Dynlink.Error e -> - raise (Error (fname, (Dynlink.error_message e)))) - - let is_native = Dynlink.is_native - - end - - module EmptyError : sig include Sig.Error - end = - struct - type t = unit - - exception E of t - - let print _ = assert false - - let to_string _ = assert false - - end - - module EmptyPrinter : - sig module Make (Ast : Sig.Ast) : Sig.Printer(Ast).S - end = - struct - module Make (Ast : Sig.Ast) = - struct - let print_interf ?input_file:(_) ?output_file:(_) _ = - failwith "No interface printer" - - let print_implem ?input_file:(_) ?output_file:(_) _ = - failwith "No implementation printer" - - end - - end - - module FreeVars : - sig - module Make (Ast : Sig.Camlp4Ast) : - sig - module S : Set.S with type elt = string - - val fold_binding_vars : - (string -> 'accu -> 'accu) -> Ast.binding -> 'accu -> 'accu - - class ['accu] c_fold_pattern_vars : - (string -> 'accu -> 'accu) -> - 'accu -> - object inherit Ast.fold val acc : 'accu method acc : 'accu - end - - val fold_pattern_vars : - (string -> 'accu -> 'accu) -> Ast.patt -> 'accu -> 'accu - - class ['accu] fold_free_vars : - (string -> 'accu -> 'accu) -> - ?env_init: S.t -> - 'accu -> - object ('self_type) - inherit Ast.fold - val free : 'accu - val env : S.t - method free : 'accu - method set_env : S.t -> 'self_type - method add_atom : string -> 'self_type - method add_patt : Ast.patt -> 'self_type - method add_binding : Ast.binding -> 'self_type - end - - val free_vars : S.t -> Ast.expr -> S.t - - end - - end = - struct - module Make (Ast : Sig.Camlp4Ast) = - struct - module S = Set.Make(String) - - class ['accu] c_fold_pattern_vars f init = - object inherit Ast.fold as super - val acc = init - method acc : 'accu = acc - method patt = - function - | Ast.PaId (_, (Ast.IdLid (_, s))) | - Ast.PaLab (_, s, (Ast.PaNil _)) | - Ast.PaOlb (_, s, (Ast.PaNil _)) -> {< acc = f s acc; >} - | p -> super#patt p - end - - let fold_pattern_vars f p init = - ((new c_fold_pattern_vars f init)#patt p)#acc - - let rec fold_binding_vars f bi acc = - match bi with - | Ast.BiAnd (_, bi1, bi2) -> - fold_binding_vars f bi1 (fold_binding_vars f bi2 acc) - | Ast.BiEq (_, p, _) -> fold_pattern_vars f p acc - | Ast.BiNil _ -> acc - | Ast.BiAnt (_, _) -> assert false - - class ['accu] fold_free_vars (f : string -> 'accu -> 'accu) - ?(env_init = S.empty) free_init = - object (o) - inherit Ast.fold as super - val free = (free_init : 'accu) - val env = (env_init : S.t) - method free = free - method set_env = fun env -> {< env = env; >} - method add_atom = fun s -> {< env = S.add s env; >} - method add_patt = - fun p -> {< env = fold_pattern_vars S.add p env; >} - method add_binding = - fun bi -> {< env = fold_binding_vars S.add bi env; >} - method expr = - function - | Ast.ExId (_, (Ast.IdLid (_, s))) | - Ast.ExLab (_, s, (Ast.ExNil _)) | - Ast.ExOlb (_, s, (Ast.ExNil _)) -> - if S.mem s env then o else {< free = f s free; >} - | Ast.ExLet (_, Ast.ReNil, bi, e) -> - (((o#add_binding bi)#expr e)#set_env env)#binding bi - | Ast.ExLet (_, Ast.ReRecursive, bi, e) -> - (((o#add_binding bi)#expr e)#binding bi)#set_env env - | Ast.ExFor (_, s, e1, e2, _, e3) -> - ((((o#expr e1)#expr e2)#add_atom s)#expr e3)#set_env - env - | Ast.ExId (_, _) | Ast.ExNew (_, _) -> o - | Ast.ExObj (_, p, cst) -> - ((o#add_patt p)#class_str_item cst)#set_env env - | e -> super#expr e - method match_case = - function - | Ast.McArr (_, p, e1, e2) -> - (((o#add_patt p)#expr e1)#expr e2)#set_env env - | m -> super#match_case m - method str_item = - function - | Ast.StExt (_, s, t, _) -> (o#ctyp t)#add_atom s - | Ast.StVal (_, Ast.ReNil, bi) -> - (o#binding bi)#add_binding bi - | Ast.StVal (_, Ast.ReRecursive, bi) -> - (o#add_binding bi)#binding bi - | st -> super#str_item st - method class_expr = - function - | Ast.CeFun (_, p, ce) -> - ((o#add_patt p)#class_expr ce)#set_env env - | Ast.CeLet (_, Ast.ReNil, bi, ce) -> - (((o#binding bi)#add_binding bi)#class_expr ce)#set_env - env - | Ast.CeLet (_, Ast.ReRecursive, bi, ce) -> - (((o#add_binding bi)#binding bi)#class_expr ce)#set_env - env - | Ast.CeStr (_, p, cst) -> - ((o#add_patt p)#class_str_item cst)#set_env env - | ce -> super#class_expr ce - method class_str_item = - function - | (Ast.CrInh (_, _, _, "") as cst) -> - super#class_str_item cst - | Ast.CrInh (_, _, ce, s) -> (o#class_expr ce)#add_atom s - | Ast.CrVal (_, s, _, _, e) -> (o#expr e)#add_atom s - | Ast.CrVvr (_, s, _, t) -> (o#ctyp t)#add_atom s - | cst -> super#class_str_item cst - method module_expr = - function - | Ast.MeStr (_, st) -> (o#str_item st)#set_env env - | me -> super#module_expr me - end - - let free_vars env_init e = - let fold = new fold_free_vars S.add ~env_init S.empty - in (fold#expr e)#free - - end - - end - - module Grammar = - struct - module Structure = - struct - open Sig.Grammar - - module type S = - sig - module Loc : Sig.Loc - - module Token : Sig.Token with module Loc = Loc - - module Lexer : Sig.Lexer with module Loc = Loc - and module Token = Token - - module Action : Sig.Grammar.Action - - type gram = - { gfilter : Token.Filter.t; - gkeywords : (string, int ref) Hashtbl.t; - glexer : - Loc.t -> char Stream.t -> (Token.t * Loc.t) Stream.t; - warning_verbose : bool ref; error_verbose : bool ref - } - - type token_info = - { prev_loc : Loc.t; cur_loc : Loc.t; prev_loc_only : bool - } - - type token_stream = (Token.t * token_info) Stream.t - - type efun = token_stream -> Action.t - - type token_pattern = ((Token.t -> bool) * string) - - type internal_entry = - { egram : gram; ename : string; - mutable estart : int -> efun; - mutable econtinue : int -> Loc.t -> Action.t -> efun; - mutable edesc : desc - } - and desc = - | Dlevels of level list - | Dparser of (token_stream -> Action.t) - and level = - { assoc : assoc; lname : string option; lsuffix : tree; - lprefix : tree - } - and symbol = - | Smeta of string * symbol list * Action.t - | Snterm of internal_entry - | Snterml of internal_entry * string - | Slist0 of symbol - | Slist0sep of symbol * symbol - | Slist1 of symbol - | Slist1sep of symbol * symbol - | Sopt of symbol - | Stry of symbol - | Sself - | Snext - | Stoken of token_pattern - | Skeyword of string - | Stree of tree - and tree = - | Node of node - | LocAct of Action.t * Action.t list - | DeadEnd - and node = - { node : symbol; son : tree; brother : tree - } - - type production_rule = ((symbol list) * Action.t) - - type single_extend_statment = - ((string option) * (assoc option) * (production_rule list)) - - type extend_statment = - ((position option) * (single_extend_statment list)) - - type delete_statment = symbol list - - type ('a, 'b, 'c) fold = - internal_entry -> - symbol list -> ('a Stream.t -> 'b) -> 'a Stream.t -> 'c - - type ('a, 'b, 'c) foldsep = - internal_entry -> - symbol list -> - ('a Stream.t -> 'b) -> - ('a Stream.t -> unit) -> 'a Stream.t -> 'c - - val get_filter : gram -> Token.Filter.t - - val using : gram -> string -> unit - - val removing : gram -> string -> unit - - end - - module Make (Lexer : Sig.Lexer) = - struct - module Loc = Lexer.Loc - - module Token = Lexer.Token - - module Action : Sig.Grammar.Action = - struct - type t = Obj.t - - let mk = Obj.repr - - let get = Obj.obj - - let getf = Obj.obj - - let getf2 = Obj.obj - - end - - module Lexer = Lexer - - type gram = - { gfilter : Token.Filter.t; - gkeywords : (string, int ref) Hashtbl.t; - glexer : - Loc.t -> char Stream.t -> (Token.t * Loc.t) Stream.t; - warning_verbose : bool ref; error_verbose : bool ref - } - - type token_info = - { prev_loc : Loc.t; cur_loc : Loc.t; prev_loc_only : bool - } - - type token_stream = (Token.t * token_info) Stream.t - - type efun = token_stream -> Action.t - - type token_pattern = ((Token.t -> bool) * string) - - type internal_entry = - { egram : gram; ename : string; - mutable estart : int -> efun; - mutable econtinue : int -> Loc.t -> Action.t -> efun; - mutable edesc : desc - } - and desc = - | Dlevels of level list - | Dparser of (token_stream -> Action.t) - and level = - { assoc : assoc; lname : string option; lsuffix : tree; - lprefix : tree - } - and symbol = - | Smeta of string * symbol list * Action.t - | Snterm of internal_entry - | Snterml of internal_entry * string - | Slist0 of symbol - | Slist0sep of symbol * symbol - | Slist1 of symbol - | Slist1sep of symbol * symbol - | Sopt of symbol - | Stry of symbol - | Sself - | Snext - | Stoken of token_pattern - | Skeyword of string - | Stree of tree - and tree = - | Node of node - | LocAct of Action.t * Action.t list - | DeadEnd - and node = - { node : symbol; son : tree; brother : tree - } - - type production_rule = ((symbol list) * Action.t) - - type single_extend_statment = - ((string option) * (assoc option) * (production_rule list)) - - type extend_statment = - ((position option) * (single_extend_statment list)) - - type delete_statment = symbol list - - type ('a, 'b, 'c) fold = - internal_entry -> - symbol list -> ('a Stream.t -> 'b) -> 'a Stream.t -> 'c - - type ('a, 'b, 'c) foldsep = - internal_entry -> - symbol list -> - ('a Stream.t -> 'b) -> - ('a Stream.t -> unit) -> 'a Stream.t -> 'c - - let get_filter g = g.gfilter - - let token_location r = r.cur_loc - - type 'a not_filtered = 'a - - let using { gkeywords = table; gfilter = filter } kwd = - let r = - try Hashtbl.find table kwd - with - | Not_found -> - let r = ref 0 in (Hashtbl.add table kwd r; r) - in (Token.Filter.keyword_added filter kwd (!r = 0); incr r) - - let removing { gkeywords = table; gfilter = filter } kwd = - let r = Hashtbl.find table kwd in - let () = decr r - in - if !r = 0 - then - (Token.Filter.keyword_removed filter kwd; - Hashtbl.remove table kwd) - else () - - end - - end - - module Search = - struct - module Make (Structure : Structure.S) = - struct - open Structure - - let tree_in_entry prev_symb tree = - function - | Dlevels levels -> - let rec search_levels = - (function - | [] -> tree - | level :: levels -> - (match search_level level with - | Some tree -> tree - | None -> search_levels levels)) - and search_level level = - (match search_tree level.lsuffix with - | Some t -> - Some - (Node - { node = Sself; son = t; brother = DeadEnd; - }) - | None -> search_tree level.lprefix) - and search_tree t = - if (tree <> DeadEnd) && (t == tree) - then Some t - else - (match t with - | Node n -> - (match search_symbol n.node with - | Some symb -> - Some - (Node - { - node = symb; - son = n.son; - brother = DeadEnd; - }) - | None -> - (match search_tree n.son with - | Some t -> - Some - (Node - { - node = n.node; - son = t; - brother = DeadEnd; - }) - | None -> search_tree n.brother)) - | LocAct (_, _) | DeadEnd -> None) - and search_symbol symb = - (match symb with - | Snterm _ | Snterml (_, _) | Slist0 _ | - Slist0sep (_, _) | Slist1 _ | Slist1sep (_, _) | - Sopt _ | Stry _ | Stoken _ | Stree _ | - Skeyword _ when symb == prev_symb -> Some symb - | Slist0 symb -> - (match search_symbol symb with - | Some symb -> Some (Slist0 symb) - | None -> None) - | Slist0sep (symb, sep) -> - (match search_symbol symb with - | Some symb -> Some (Slist0sep (symb, sep)) - | None -> - (match search_symbol sep with - | Some sep -> Some (Slist0sep (symb, sep)) - | None -> None)) - | Slist1 symb -> - (match search_symbol symb with - | Some symb -> Some (Slist1 symb) - | None -> None) - | Slist1sep (symb, sep) -> - (match search_symbol symb with - | Some symb -> Some (Slist1sep (symb, sep)) - | None -> - (match search_symbol sep with - | Some sep -> Some (Slist1sep (symb, sep)) - | None -> None)) - | Sopt symb -> - (match search_symbol symb with - | Some symb -> Some (Sopt symb) - | None -> None) - | Stry symb -> - (match search_symbol symb with - | Some symb -> Some (Stry symb) - | None -> None) - | Stree t -> - (match search_tree t with - | Some t -> Some (Stree t) - | None -> None) - | _ -> None) - in search_levels levels - | Dparser _ -> tree - - end - - end - - module Tools = - struct - let get_prev_loc_only = ref false - - module Make (Structure : Structure.S) = - struct - open Structure - - let empty_entry ename _ = - raise (Stream.Error ("entry [" ^ (ename ^ "] is empty"))) - - let rec stream_map f (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some x -> - (Stream.junk __strm; - let strm = __strm - in - Stream.lcons (fun _ -> f x) - (Stream.slazy (fun _ -> stream_map f strm))) - | _ -> Stream.sempty - - let keep_prev_loc strm = - match Stream.peek strm with - | None -> Stream.sempty - | Some ((tok0, init_loc)) -> - let rec go prev_loc strm1 = - if !get_prev_loc_only - then - Stream.lcons - (fun _ -> - (tok0, - { - prev_loc = prev_loc; - cur_loc = prev_loc; - prev_loc_only = true; - })) - (Stream.slazy (fun _ -> go prev_loc strm1)) - else - (let (__strm : _ Stream.t) = strm1 - in - match Stream.peek __strm with - | Some ((tok, cur_loc)) -> - (Stream.junk __strm; - let strm = __strm - in - Stream.lcons - (fun _ -> - (tok, - { - prev_loc = prev_loc; - cur_loc = cur_loc; - prev_loc_only = false; - })) - (Stream.slazy - (fun _ -> go cur_loc strm))) - | _ -> Stream.sempty) - in go init_loc strm - - let drop_prev_loc strm = - stream_map (fun (tok, r) -> (tok, (r.cur_loc))) strm - - let get_cur_loc strm = - match Stream.peek strm with - | Some ((_, r)) -> r.cur_loc - | None -> Loc.ghost - - let get_prev_loc strm = - (get_prev_loc_only := true; - let result = - match Stream.peek strm with - | Some - ((_, { prev_loc = prev_loc; prev_loc_only = true })) - -> (Stream.junk strm; prev_loc) - | Some - ((_, { prev_loc = prev_loc; prev_loc_only = false })) - -> prev_loc - | None -> Loc.ghost - in (get_prev_loc_only := false; result)) - - let is_level_labelled n lev = - match lev.lname with | Some n1 -> n = n1 | None -> false - - let warning_verbose = ref true - - let rec get_token_list entry tokl last_tok tree = - match tree with - | Node - { - node = (Stoken _ | Skeyword _ as tok); - son = son; - brother = DeadEnd - } -> get_token_list entry (last_tok :: tokl) tok son - | _ -> - if tokl = [] - then None - else - Some - (((List.rev (last_tok :: tokl)), last_tok, tree)) - - let is_antiquot s = - let len = String.length s in (len > 1) && (s.[0] = '$') - - let eq_Stoken_ids s1 s2 = - (not (is_antiquot s1)) && - ((not (is_antiquot s2)) && (s1 = s2)) - - let logically_eq_symbols entry = - let rec eq_symbols s1 s2 = - match (s1, s2) with - | (Snterm e1, Snterm e2) -> e1.ename = e2.ename - | (Snterm e1, Sself) -> e1.ename = entry.ename - | (Sself, Snterm e2) -> entry.ename = e2.ename - | (Snterml (e1, l1), Snterml (e2, l2)) -> - (e1.ename = e2.ename) && (l1 = l2) - | (Slist0 s1, Slist0 s2) | (Slist1 s1, Slist1 s2) | - (Sopt s1, Sopt s2) | (Stry s1, Stry s2) -> - eq_symbols s1 s2 - | (Slist0sep (s1, sep1), Slist0sep (s2, sep2)) | - (Slist1sep (s1, sep1), Slist1sep (s2, sep2)) -> - (eq_symbols s1 s2) && (eq_symbols sep1 sep2) - | (Stree t1, Stree t2) -> eq_trees t1 t2 - | (Stoken ((_, s1)), Stoken ((_, s2))) -> - eq_Stoken_ids s1 s2 - | _ -> s1 = s2 - and eq_trees t1 t2 = - match (t1, t2) with - | (Node n1, Node n2) -> - (eq_symbols n1.node n2.node) && - ((eq_trees n1.son n2.son) && - (eq_trees n1.brother n2.brother)) - | ((LocAct (_, _) | DeadEnd), (LocAct (_, _) | DeadEnd)) - -> true - | _ -> false - in eq_symbols - - let rec eq_symbol s1 s2 = - match (s1, s2) with - | (Snterm e1, Snterm e2) -> e1 == e2 - | (Snterml (e1, l1), Snterml (e2, l2)) -> - (e1 == e2) && (l1 = l2) - | (Slist0 s1, Slist0 s2) | (Slist1 s1, Slist1 s2) | - (Sopt s1, Sopt s2) | (Stry s1, Stry s2) -> - eq_symbol s1 s2 - | (Slist0sep (s1, sep1), Slist0sep (s2, sep2)) | - (Slist1sep (s1, sep1), Slist1sep (s2, sep2)) -> - (eq_symbol s1 s2) && (eq_symbol sep1 sep2) - | (Stree _, Stree _) -> false - | (Stoken ((_, s1)), Stoken ((_, s2))) -> - eq_Stoken_ids s1 s2 - | _ -> s1 = s2 - - end - - end - - module Print : - sig - module Make (Structure : Structure.S) : - sig - val flatten_tree : - Structure.tree -> (Structure.symbol list) list - - val print_symbol : - Format.formatter -> Structure.symbol -> unit - - val print_meta : - Format.formatter -> string -> Structure.symbol list -> unit - - val print_symbol1 : - Format.formatter -> Structure.symbol -> unit - - val print_rule : - Format.formatter -> Structure.symbol list -> unit - - val print_level : - Format.formatter -> - (Format.formatter -> unit -> unit) -> - (Structure.symbol list) list -> unit - - val levels : Format.formatter -> Structure.level list -> unit - - val entry : - Format.formatter -> Structure.internal_entry -> unit - - end - - module MakeDump (Structure : Structure.S) : - sig - val print_symbol : - Format.formatter -> Structure.symbol -> unit - - val print_meta : - Format.formatter -> string -> Structure.symbol list -> unit - - val print_symbol1 : - Format.formatter -> Structure.symbol -> unit - - val print_rule : - Format.formatter -> Structure.symbol list -> unit - - val print_level : - Format.formatter -> - (Format.formatter -> unit -> unit) -> - (Structure.symbol list) list -> unit - - val levels : Format.formatter -> Structure.level list -> unit - - val entry : - Format.formatter -> Structure.internal_entry -> unit - - end - - end = - struct - module Make (Structure : Structure.S) = - struct - open Structure - - open Format - - open Sig.Grammar - - let rec flatten_tree = - function - | DeadEnd -> [] - | LocAct (_, _) -> [ [] ] - | Node { node = n; brother = b; son = s } -> - (List.map (fun l -> n :: l) (flatten_tree s)) @ - (flatten_tree b) - - let rec print_symbol ppf = - function - | Smeta (n, sl, _) -> print_meta ppf n sl - | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s - | Slist0sep (s, t) -> - fprintf ppf "LIST0 %a SEP %a" print_symbol1 s - print_symbol1 t - | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s - | Slist1sep (s, t) -> - fprintf ppf "LIST1 %a SEP %a" print_symbol1 s - print_symbol1 t - | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s - | Stry s -> fprintf ppf "TRY %a" print_symbol1 s - | Snterml (e, l) -> fprintf ppf "%s@ LEVEL@ %S" e.ename l - | (Snterm _ | Snext | Sself | Stree _ | Stoken _ | - Skeyword _ - as s) -> print_symbol1 ppf s - and print_meta ppf n sl = - let rec loop i = - function - | [] -> () - | s :: sl -> - let j = - (try String.index_from n i ' ' - with | Not_found -> String.length n) - in - (fprintf ppf "%s %a" (String.sub n i (j - i)) - print_symbol1 s; - if sl = [] - then () - else - (fprintf ppf " "; - loop (min (j + 1) (String.length n)) sl)) - in loop 0 sl - and print_symbol1 ppf = - function - | Snterm e -> pp_print_string ppf e.ename - | Sself -> pp_print_string ppf "SELF" - | Snext -> pp_print_string ppf "NEXT" - | Stoken ((_, descr)) -> pp_print_string ppf descr - | Skeyword s -> fprintf ppf "%S" s - | Stree t -> - print_level ppf pp_print_space (flatten_tree t) - | (Smeta (_, _, _) | Snterml (_, _) | Slist0 _ | - Slist0sep (_, _) | Slist1 _ | Slist1sep (_, _) | - Sopt _ | Stry _ - as s) -> fprintf ppf "(%a)" print_symbol s - and print_rule ppf symbols = - (fprintf ppf "@["; - let _ = - List.fold_left - (fun sep symbol -> - (fprintf ppf "%t%a" sep print_symbol symbol; - fun ppf -> fprintf ppf ";@ ")) - (fun _ -> ()) symbols - in fprintf ppf "@]") - and print_level ppf pp_print_space rules = - (fprintf ppf "@[[ "; - let _ = - List.fold_left - (fun sep rule -> - (fprintf ppf "%t%a" sep print_rule rule; - fun ppf -> fprintf ppf "%a| " pp_print_space ())) - (fun _ -> ()) rules - in fprintf ppf " ]@]") - - let levels ppf elev = - let _ = - List.fold_left - (fun sep lev -> - let rules = - (List.map (fun t -> Sself :: t) - (flatten_tree lev.lsuffix)) - @ (flatten_tree lev.lprefix) - in - (fprintf ppf "%t@[" sep; - (match lev.lname with - | Some n -> fprintf ppf "%S@;<1 2>" n - | None -> ()); - (match lev.assoc with - | LeftA -> fprintf ppf "LEFTA" - | RightA -> fprintf ppf "RIGHTA" - | NonA -> fprintf ppf "NONA"); - fprintf ppf "@]@;<1 2>"; - print_level ppf pp_force_newline rules; - fun ppf -> fprintf ppf "@,| ")) - (fun _ -> ()) elev - in () - - let entry ppf e = - (fprintf ppf "@[%s: [ " e.ename; - (match e.edesc with - | Dlevels elev -> levels ppf elev - | Dparser _ -> fprintf ppf ""); - fprintf ppf " ]@]") - - end - - module MakeDump (Structure : Structure.S) = - struct - open Structure - - open Format - - open Sig.Grammar - - type brothers = | Bro of symbol * brothers list - - let rec print_tree ppf tree = - let rec get_brothers acc = - function - | DeadEnd -> List.rev acc - | LocAct (_, _) -> List.rev acc - | Node { node = n; brother = b; son = s } -> - get_brothers ((Bro (n, (get_brothers [] s))) :: acc) - b - and print_brothers ppf brothers = - if brothers = [] - then fprintf ppf "@ []" - else - List.iter - (function - | Bro (n, xs) -> - (fprintf ppf "@ @[- %a" print_symbol n; - (match xs with - | [] -> () - | [ _ ] -> - (try - print_children ppf (get_children [] xs) - with - | Exit -> - fprintf ppf ":%a" print_brothers xs) - | _ -> fprintf ppf ":%a" print_brothers xs); - fprintf ppf "@]")) - brothers - and print_children ppf = - List.iter (fprintf ppf ";@ %a" print_symbol) - and get_children acc = - function - | [] -> List.rev acc - | [ Bro (n, x) ] -> get_children (n :: acc) x - | _ -> raise Exit - in print_brothers ppf (get_brothers [] tree) - and print_symbol ppf = - function - | Smeta (n, sl, _) -> print_meta ppf n sl - | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s - | Slist0sep (s, t) -> - fprintf ppf "LIST0 %a SEP %a" print_symbol1 s - print_symbol1 t - | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s - | Slist1sep (s, t) -> - fprintf ppf "LIST1 %a SEP %a" print_symbol1 s - print_symbol1 t - | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s - | Stry s -> fprintf ppf "TRY %a" print_symbol1 s - | Snterml (e, l) -> fprintf ppf "%s@ LEVEL@ %S" e.ename l - | (Snterm _ | Snext | Sself | Stree _ | Stoken _ | - Skeyword _ - as s) -> print_symbol1 ppf s - and print_meta ppf n sl = - let rec loop i = - function - | [] -> () - | s :: sl -> - let j = - (try String.index_from n i ' ' - with | Not_found -> String.length n) - in - (fprintf ppf "%s %a" (String.sub n i (j - i)) - print_symbol1 s; - if sl = [] - then () - else - (fprintf ppf " "; - loop (min (j + 1) (String.length n)) sl)) - in loop 0 sl - and print_symbol1 ppf = - function - | Snterm e -> pp_print_string ppf e.ename - | Sself -> pp_print_string ppf "SELF" - | Snext -> pp_print_string ppf "NEXT" - | Stoken ((_, descr)) -> pp_print_string ppf descr - | Skeyword s -> fprintf ppf "%S" s - | Stree t -> print_tree ppf t - | (Smeta (_, _, _) | Snterml (_, _) | Slist0 _ | - Slist0sep (_, _) | Slist1 _ | Slist1sep (_, _) | - Sopt _ | Stry _ - as s) -> fprintf ppf "(%a)" print_symbol s - and print_rule ppf symbols = - (fprintf ppf "@["; - let _ = - List.fold_left - (fun sep symbol -> - (fprintf ppf "%t%a" sep print_symbol symbol; - fun ppf -> fprintf ppf ";@ ")) - (fun _ -> ()) symbols - in fprintf ppf "@]") - and print_level ppf pp_print_space rules = - (fprintf ppf "@[[ "; - let _ = - List.fold_left - (fun sep rule -> - (fprintf ppf "%t%a" sep print_rule rule; - fun ppf -> fprintf ppf "%a| " pp_print_space ())) - (fun _ -> ()) rules - in fprintf ppf " ]@]") - - let levels ppf elev = - let _ = - List.fold_left - (fun sep lev -> - (fprintf ppf "%t@[" sep; - (match lev.lname with - | Some n -> fprintf ppf "%S@;<1 2>" n - | None -> ()); - (match lev.assoc with - | LeftA -> fprintf ppf "LEFTA" - | RightA -> fprintf ppf "RIGHTA" - | NonA -> fprintf ppf "NONA"); - fprintf ppf "@]@;<1 2>"; - fprintf ppf "@[suffix:@ "; - print_tree ppf lev.lsuffix; - fprintf ppf "@]@ @[prefix:@ "; - print_tree ppf lev.lprefix; - fprintf ppf "@]"; - fun ppf -> fprintf ppf "@,| ")) - (fun _ -> ()) elev - in () - - let entry ppf e = - (fprintf ppf "@[%s: [ " e.ename; - (match e.edesc with - | Dlevels elev -> levels ppf elev - | Dparser _ -> fprintf ppf ""); - fprintf ppf " ]@]") - - end - - end - - module Failed = - struct - module Make (Structure : Structure.S) = - struct - module Tools = Tools.Make(Structure) - - module Search = Search.Make(Structure) - - module Print = Print.Make(Structure) - - open Structure - - open Format - - let rec name_of_symbol entry = - function - | Snterm e -> "[" ^ (e.ename ^ "]") - | Snterml (e, l) -> - "[" ^ (e.ename ^ (" level " ^ (l ^ "]"))) - | Sself | Snext -> "[" ^ (entry.ename ^ "]") - | Stoken ((_, descr)) -> descr - | Skeyword kwd -> "\"" ^ (kwd ^ "\"") - | _ -> "???" - - let rec name_of_symbol_failed entry = - function - | Slist0 s | Slist0sep (s, _) | Slist1 s | Slist1sep (s, _) - | Sopt s | Stry s -> name_of_symbol_failed entry s - | Stree t -> name_of_tree_failed entry t - | s -> name_of_symbol entry s - and name_of_tree_failed entry = - function - | Node { node = s; brother = bro; son = son } -> - let tokl = - (match s with - | Stoken _ | Skeyword _ -> - Tools.get_token_list entry [] s son - | _ -> None) - in - (match tokl with - | None -> - let txt = name_of_symbol_failed entry s in - let txt = - (match (s, son) with - | (Sopt _, Node _) -> - txt ^ - (" or " ^ - (name_of_tree_failed entry son)) - | _ -> txt) in - let txt = - (match bro with - | DeadEnd | LocAct (_, _) -> txt - | Node _ -> - txt ^ - (" or " ^ - (name_of_tree_failed entry bro))) - in txt - | Some ((tokl, _, _)) -> - List.fold_left - (fun s tok -> - (if s = "" then "" else s ^ " then ") ^ - (match tok with - | Stoken ((_, descr)) -> descr - | Skeyword kwd -> kwd - | _ -> assert false)) - "" tokl) - | DeadEnd | LocAct (_, _) -> "???" - - let magic _s x = Obj.magic x - - let tree_failed entry prev_symb_result prev_symb tree = - let txt = name_of_tree_failed entry tree in - let txt = - match prev_symb with - | Slist0 s -> - let txt1 = name_of_symbol_failed entry s - in txt1 ^ (" or " ^ (txt ^ " expected")) - | Slist1 s -> - let txt1 = name_of_symbol_failed entry s - in txt1 ^ (" or " ^ (txt ^ " expected")) - | Slist0sep (s, sep) -> - (match magic "tree_failed: 'a -> list 'b" - prev_symb_result - with - | [] -> - let txt1 = name_of_symbol_failed entry s - in txt1 ^ (" or " ^ (txt ^ " expected")) - | _ -> - let txt1 = name_of_symbol_failed entry sep - in txt1 ^ (" or " ^ (txt ^ " expected"))) - | Slist1sep (s, sep) -> - (match magic "tree_failed: 'a -> list 'b" - prev_symb_result - with - | [] -> - let txt1 = name_of_symbol_failed entry s - in txt1 ^ (" or " ^ (txt ^ " expected")) - | _ -> - let txt1 = name_of_symbol_failed entry sep - in txt1 ^ (" or " ^ (txt ^ " expected"))) - | Stry _ | Sopt _ | Stree _ -> txt ^ " expected" - | _ -> - txt ^ - (" expected after " ^ - (name_of_symbol entry prev_symb)) - in - (if !(entry.egram.error_verbose) - then - (let tree = - Search.tree_in_entry prev_symb tree entry.edesc in - let ppf = err_formatter - in - (fprintf ppf "@[@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf - "Parse error in entry [%s], rule:@;<0 2>" - entry.ename; - fprintf ppf "@["; - Print.print_level ppf pp_force_newline - (Print.flatten_tree tree); - fprintf ppf "@]@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "@]@.")) - else (); - txt ^ (" (in [" ^ (entry.ename ^ "])"))) - - let symb_failed entry prev_symb_result prev_symb symb = - let tree = - Node { node = symb; brother = DeadEnd; son = DeadEnd; } - in tree_failed entry prev_symb_result prev_symb tree - - let symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2 - - end - - end - - module Parser = - struct - module Make (Structure : Structure.S) = - struct - module Tools = Tools.Make(Structure) - - module Failed = Failed.Make(Structure) - - module Print = Print.Make(Structure) - - open Structure - - open Sig.Grammar - - module StreamOrig = Stream - - let njunk strm n = for i = 1 to n do Stream.junk strm done - - let loc_bp = Tools.get_cur_loc - - let loc_ep = Tools.get_prev_loc - - let drop_prev_loc = Tools.drop_prev_loc - - let add_loc bp parse_fun strm = - let x = parse_fun strm in - let ep = loc_ep strm in - let loc = - if (Loc.start_off bp) > (Loc.stop_off ep) - then Loc.join bp - else Loc.merge bp ep - in (x, loc) - - let stream_peek_nth strm n = - let rec loop i = - function - | x :: xs -> if i = 1 then Some x else loop (i - 1) xs - | [] -> None - in loop n (Stream.npeek n strm) - - module Stream = - struct - type 'a t = 'a StreamOrig.t - - exception Failure = StreamOrig.Failure - - exception Error = StreamOrig.Error - - let peek = StreamOrig.peek - - let junk = StreamOrig.junk - - let dup strm = - let peek_nth n = - let rec loop n = - function - | [] -> None - | [ x ] -> if n = 0 then Some x else None - | _ :: l -> loop (n - 1) l - in loop n (Stream.npeek (n + 1) strm) - in Stream.from peek_nth - - end - - let try_parser ps strm = - let strm' = Stream.dup strm in - let r = - try ps strm' - with - | Stream.Error _ | Loc.Exc_located (_, (Stream.Error _)) - -> raise Stream.Failure - | exc -> raise exc - in (njunk strm (StreamOrig.count strm'); r) - - let level_number entry lab = - let rec lookup levn = - function - | [] -> failwith ("unknown level " ^ lab) - | lev :: levs -> - if Tools.is_level_labelled lab lev - then levn - else lookup (succ levn) levs - in - match entry.edesc with - | Dlevels elev -> lookup 0 elev - | Dparser _ -> raise Not_found - - let strict_parsing = ref false - - let strict_parsing_warning = ref false - - let rec top_symb entry = - function - | Sself | Snext -> Snterm entry - | Snterml (e, _) -> Snterm e - | Slist1sep (s, sep) -> Slist1sep ((top_symb entry s), sep) - | _ -> raise Stream.Failure - - let top_tree entry = - function - | Node { node = s; brother = bro; son = son } -> - Node - { node = top_symb entry s; brother = bro; son = son; - } - | LocAct (_, _) | DeadEnd -> raise Stream.Failure - - let entry_of_symb entry = - function - | Sself | Snext -> entry - | Snterm e -> e - | Snterml (e, _) -> e - | _ -> raise Stream.Failure - - let continue entry loc a s son p1 (__strm : _ Stream.t) = - let a = (entry_of_symb entry s).econtinue 0 loc a __strm in - let act = - try p1 __strm - with - | Stream.Failure -> - raise - (Stream.Error (Failed.tree_failed entry a s son)) - in Action.mk (fun _ -> Action.getf act a) - - let skip_if_empty bp strm = - if (loc_bp strm) = bp - then Action.mk (fun _ -> raise Stream.Failure) - else raise Stream.Failure - - let do_recover parser_of_tree entry nlevn alevn loc a s son - (__strm : _ Stream.t) = - try - parser_of_tree entry nlevn alevn (top_tree entry son) - __strm - with - | Stream.Failure -> - (try skip_if_empty loc __strm - with - | Stream.Failure -> - continue entry loc a s son - (parser_of_tree entry nlevn alevn son) __strm) - - let recover parser_of_tree entry nlevn alevn loc a s son strm - = - if !strict_parsing - then - raise (Stream.Error (Failed.tree_failed entry a s son)) - else - (let _ = - if !strict_parsing_warning - then - (let msg = Failed.tree_failed entry a s son - in - (Format.eprintf - "Warning: trying to recover from syntax error"; - if entry.ename <> "" - then Format.eprintf " in [%s]" entry.ename - else (); - Format.eprintf "\n%s%a@." msg Loc.print loc)) - else () - in - do_recover parser_of_tree entry nlevn alevn loc a s - son strm) - - let rec parser_of_tree entry nlevn alevn = - function - | DeadEnd -> - (fun (__strm : _ Stream.t) -> raise Stream.Failure) - | LocAct (act, _) -> (fun (__strm : _ Stream.t) -> act) - | Node - { - node = Sself; - son = LocAct (act, _); - brother = DeadEnd - } -> - (fun (__strm : _ Stream.t) -> - let a = entry.estart alevn __strm - in Action.getf act a) - | Node { node = Sself; son = LocAct (act, _); brother = bro - } -> - let p2 = parser_of_tree entry nlevn alevn bro - in - (fun (__strm : _ Stream.t) -> - match try Some (entry.estart alevn __strm) - with | Stream.Failure -> None - with - | Some a -> Action.getf act a - | _ -> p2 __strm) - | Node { node = s; son = son; brother = DeadEnd } -> - let tokl = - (match s with - | Stoken _ | Skeyword _ -> - Tools.get_token_list entry [] s son - | _ -> None) - in - (match tokl with - | None -> - let ps = parser_of_symbol entry nlevn s in - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn s son - in - (fun strm -> - let bp = loc_bp strm in - let (__strm : _ Stream.t) = strm in - let a = ps __strm in - let act = - try p1 bp a __strm - with - | Stream.Failure -> - raise (Stream.Error "") - in Action.getf act a) - | Some ((tokl, last_tok, son)) -> - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = - parser_cont p1 entry nlevn alevn last_tok son - in parser_of_token_list p1 tokl) - | Node { node = s; son = son; brother = bro } -> - let tokl = - (match s with - | Stoken _ | Skeyword _ -> - Tools.get_token_list entry [] s son - | _ -> None) - in - (match tokl with - | None -> - let ps = parser_of_symbol entry nlevn s in - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = - parser_cont p1 entry nlevn alevn s son in - let p2 = parser_of_tree entry nlevn alevn bro - in - (fun strm -> - let bp = loc_bp strm in - let (__strm : _ Stream.t) = strm - in - match try Some (ps __strm) - with | Stream.Failure -> None - with - | Some a -> - let act = - (try p1 bp a __strm - with - | Stream.Failure -> - raise (Stream.Error "")) - in Action.getf act a - | _ -> p2 __strm) - | Some ((tokl, last_tok, son)) -> - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = - parser_cont p1 entry nlevn alevn last_tok son in - let p1 = parser_of_token_list p1 tokl in - let p2 = parser_of_tree entry nlevn alevn bro - in - (fun (__strm : _ Stream.t) -> - try p1 __strm - with | Stream.Failure -> p2 __strm)) - and - parser_cont p1 entry nlevn alevn s son loc a - (__strm : _ Stream.t) = - try p1 __strm - with - | Stream.Failure -> - (try - recover parser_of_tree entry nlevn alevn loc a s son - __strm - with - | Stream.Failure -> - raise - (Stream.Error (Failed.tree_failed entry a s son))) - and parser_of_token_list p1 tokl = - let rec loop n = - function - | Stoken ((tematch, _)) :: tokl -> - (match tokl with - | [] -> - let ps strm = - (match stream_peek_nth strm n with - | Some ((tok, _)) when tematch tok -> - (njunk strm n; Action.mk tok) - | _ -> raise Stream.Failure) - in - (fun strm -> - let bp = loc_bp strm in - let (__strm : _ Stream.t) = strm in - let a = ps __strm in - let act = - try p1 bp a __strm - with - | Stream.Failure -> - raise (Stream.Error "") - in Action.getf act a) - | _ -> - let ps strm = - (match stream_peek_nth strm n with - | Some ((tok, _)) when tematch tok -> tok - | _ -> raise Stream.Failure) in - let p1 = loop (n + 1) tokl - in - (fun (__strm : _ Stream.t) -> - let tok = ps __strm in - let s = __strm in - let act = p1 s in Action.getf act tok)) - | Skeyword kwd :: tokl -> - (match tokl with - | [] -> - let ps strm = - (match stream_peek_nth strm n with - | Some ((tok, _)) when - Token.match_keyword kwd tok -> - (njunk strm n; Action.mk tok) - | _ -> raise Stream.Failure) - in - (fun strm -> - let bp = loc_bp strm in - let (__strm : _ Stream.t) = strm in - let a = ps __strm in - let act = - try p1 bp a __strm - with - | Stream.Failure -> - raise (Stream.Error "") - in Action.getf act a) - | _ -> - let ps strm = - (match stream_peek_nth strm n with - | Some ((tok, _)) when - Token.match_keyword kwd tok -> tok - | _ -> raise Stream.Failure) in - let p1 = loop (n + 1) tokl - in - (fun (__strm : _ Stream.t) -> - let tok = ps __strm in - let s = __strm in - let act = p1 s in Action.getf act tok)) - | _ -> invalid_arg "parser_of_token_list" - in loop 1 tokl - and parser_of_symbol entry nlevn = - function - | Smeta (_, symbl, act) -> - let act = Obj.magic act entry symbl in - let pl = List.map (parser_of_symbol entry nlevn) symbl - in - Obj.magic - (List.fold_left (fun act p -> Obj.magic act p) act - pl) - | Slist0 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al (__strm : _ Stream.t) = - (match try Some (ps __strm) - with | Stream.Failure -> None - with - | Some a -> loop (a :: al) __strm - | _ -> al) - in - (fun (__strm : _ Stream.t) -> - let a = loop [] __strm in Action.mk (List.rev a)) - | Slist0sep (symb, sep) -> - let ps = parser_of_symbol entry nlevn symb in - let pt = parser_of_symbol entry nlevn sep in - let rec kont al (__strm : _ Stream.t) = - (match try Some (pt __strm) - with | Stream.Failure -> None - with - | Some v -> - let a = - (try ps __strm - with - | Stream.Failure -> - raise - (Stream.Error - (Failed.symb_failed entry v sep symb))) - in kont (a :: al) __strm - | _ -> al) - in - (fun (__strm : _ Stream.t) -> - match try Some (ps __strm) - with | Stream.Failure -> None - with - | Some a -> - let s = __strm - in Action.mk (List.rev (kont [ a ] s)) - | _ -> Action.mk []) - | Slist1 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al (__strm : _ Stream.t) = - (match try Some (ps __strm) - with | Stream.Failure -> None - with - | Some a -> loop (a :: al) __strm - | _ -> al) - in - (fun (__strm : _ Stream.t) -> - let a = ps __strm in - let s = __strm - in Action.mk (List.rev (loop [ a ] s))) - | Slist1sep (symb, sep) -> - let ps = parser_of_symbol entry nlevn symb in - let pt = parser_of_symbol entry nlevn sep in - let rec kont al (__strm : _ Stream.t) = - (match try Some (pt __strm) - with | Stream.Failure -> None - with - | Some v -> - let a = - (try ps __strm - with - | Stream.Failure -> - (try parse_top_symb entry symb __strm - with - | Stream.Failure -> - raise - (Stream.Error - (Failed.symb_failed entry v sep - symb)))) - in kont (a :: al) __strm - | _ -> al) - in - (fun (__strm : _ Stream.t) -> - let a = ps __strm in - let s = __strm - in Action.mk (List.rev (kont [ a ] s))) - | Sopt s -> - let ps = parser_of_symbol entry nlevn s - in - (fun (__strm : _ Stream.t) -> - match try Some (ps __strm) - with | Stream.Failure -> None - with - | Some a -> Action.mk (Some a) - | _ -> Action.mk None) - | Stry s -> - let ps = parser_of_symbol entry nlevn s - in try_parser ps - | Stree t -> - let pt = parser_of_tree entry 1 0 t - in - (fun strm -> - let bp = loc_bp strm in - let (__strm : _ Stream.t) = strm in - let (act, loc) = add_loc bp pt __strm - in Action.getf act loc) - | Snterm e -> - (fun (__strm : _ Stream.t) -> e.estart 0 __strm) - | Snterml (e, l) -> - (fun (__strm : _ Stream.t) -> - e.estart (level_number e l) __strm) - | Sself -> - (fun (__strm : _ Stream.t) -> entry.estart 0 __strm) - | Snext -> - (fun (__strm : _ Stream.t) -> entry.estart nlevn __strm) - | Skeyword kwd -> - (fun (__strm : _ Stream.t) -> - match Stream.peek __strm with - | Some ((tok, _)) when Token.match_keyword kwd tok - -> (Stream.junk __strm; Action.mk tok) - | _ -> raise Stream.Failure) - | Stoken ((f, _)) -> - (fun (__strm : _ Stream.t) -> - match Stream.peek __strm with - | Some ((tok, _)) when f tok -> - (Stream.junk __strm; Action.mk tok) - | _ -> raise Stream.Failure) - and parse_top_symb entry symb strm = - parser_of_symbol entry 0 (top_symb entry symb) strm - - let rec start_parser_of_levels entry clevn = - function - | [] -> - (fun _ (__strm : _ Stream.t) -> raise Stream.Failure) - | lev :: levs -> - let p1 = start_parser_of_levels entry (succ clevn) levs - in - (match lev.lprefix with - | DeadEnd -> p1 - | tree -> - let alevn = - (match lev.assoc with - | LeftA | NonA -> succ clevn - | RightA -> clevn) in - let p2 = - parser_of_tree entry (succ clevn) alevn tree - in - (match levs with - | [] -> - (fun levn strm -> - let bp = loc_bp strm in - let (__strm : _ Stream.t) = strm in - let (act, loc) = - add_loc bp p2 __strm in - let strm = __strm in - let a = Action.getf act loc - in entry.econtinue levn loc a strm) - | _ -> - (fun levn strm -> - if levn > clevn - then p1 levn strm - else - (let bp = loc_bp strm in - let (__strm : _ Stream.t) = strm - in - match try - Some - (add_loc bp p2 __strm) - with - | Stream.Failure -> None - with - | Some ((act, loc)) -> - let a = Action.getf act loc - in - entry.econtinue levn loc a - strm - | _ -> p1 levn __strm)))) - - let start_parser_of_entry entry = - match entry.edesc with - | Dlevels [] -> Tools.empty_entry entry.ename - | Dlevels elev -> start_parser_of_levels entry 0 elev - | Dparser p -> (fun _ -> p) - - let rec continue_parser_of_levels entry clevn = - function - | [] -> - (fun _ _ _ (__strm : _ Stream.t) -> - raise Stream.Failure) - | lev :: levs -> - let p1 = - continue_parser_of_levels entry (succ clevn) levs - in - (match lev.lsuffix with - | DeadEnd -> p1 - | tree -> - let alevn = - (match lev.assoc with - | LeftA | NonA -> succ clevn - | RightA -> clevn) in - let p2 = - parser_of_tree entry (succ clevn) alevn tree - in - (fun levn bp a strm -> - if levn > clevn - then p1 levn bp a strm - else - (let (__strm : _ Stream.t) = strm - in - try p1 levn bp a __strm - with - | Stream.Failure -> - let (act, loc) = - add_loc bp p2 __strm in - let a = Action.getf2 act a loc - in entry.econtinue levn loc a strm))) - - let continue_parser_of_entry entry = - match entry.edesc with - | Dlevels elev -> - let p = continue_parser_of_levels entry 0 elev - in - (fun levn bp a (__strm : _ Stream.t) -> - try p levn bp a __strm with | Stream.Failure -> a) - | Dparser _ -> - (fun _ _ _ (__strm : _ Stream.t) -> - raise Stream.Failure) - - end - - end - - module Insert = - struct - module Make (Structure : Structure.S) = - struct - module Tools = Tools.Make(Structure) - - module Parser = Parser.Make(Structure) - - open Structure - - open Format - - open Sig.Grammar - - let is_before s1 s2 = - match (s1, s2) with - | ((Skeyword _ | Stoken _), (Skeyword _ | Stoken _)) -> - false - | ((Skeyword _ | Stoken _), _) -> true - | _ -> false - - let rec derive_eps = - function - | Slist0 _ | Slist0sep (_, _) | Sopt _ -> true - | Stry s -> derive_eps s - | Stree t -> tree_derive_eps t - | Slist1 _ | Slist1sep (_, _) | Stoken _ | Skeyword _ -> - false - | Smeta (_, _, _) | Snterm _ | Snterml (_, _) | Snext | - Sself -> false - and tree_derive_eps = - function - | LocAct (_, _) -> true - | Node { node = s; brother = bro; son = son } -> - ((derive_eps s) && (tree_derive_eps son)) || - (tree_derive_eps bro) - | DeadEnd -> false - - let empty_lev lname assoc = - let assoc = match assoc with | Some a -> a | None -> LeftA - in - { - assoc = assoc; - lname = lname; - lsuffix = DeadEnd; - lprefix = DeadEnd; - } - - let change_lev entry lev n lname assoc = - let a = - match assoc with - | None -> lev.assoc - | Some a -> - (if - (a <> lev.assoc) && !(entry.egram.warning_verbose) - then - (eprintf - " Changing associativity of level \"%s\"\n" - n; - flush Pervasives.stderr) - else (); - a) - in - ((match lname with - | Some n -> - if - (lname <> lev.lname) && - !(entry.egram.warning_verbose) - then - (eprintf " Level label \"%s\" ignored\n" n; - flush Pervasives.stderr) - else () - | None -> ()); - { - assoc = a; - lname = lev.lname; - lsuffix = lev.lsuffix; - lprefix = lev.lprefix; - }) - - let change_to_self entry = - function | Snterm e when e == entry -> Sself | x -> x - - let get_level entry position levs = - match position with - | Some First -> ([], empty_lev, levs) - | Some Last -> (levs, empty_lev, []) - | Some (Level n) -> - let rec get = - (function - | [] -> - (eprintf - "No level labelled \"%s\" in entry \"%s\"\n" - n entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend") - | lev :: levs -> - if Tools.is_level_labelled n lev - then ([], (change_lev entry lev n), levs) - else - (let (levs1, rlev, levs2) = get levs - in ((lev :: levs1), rlev, levs2))) - in get levs - | Some (Before n) -> - let rec get = - (function - | [] -> - (eprintf - "No level labelled \"%s\" in entry \"%s\"\n" - n entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend") - | lev :: levs -> - if Tools.is_level_labelled n lev - then ([], empty_lev, (lev :: levs)) - else - (let (levs1, rlev, levs2) = get levs - in ((lev :: levs1), rlev, levs2))) - in get levs - | Some (After n) -> - let rec get = - (function - | [] -> - (eprintf - "No level labelled \"%s\" in entry \"%s\"\n" - n entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend") - | lev :: levs -> - if Tools.is_level_labelled n lev - then ([ lev ], empty_lev, levs) - else - (let (levs1, rlev, levs2) = get levs - in ((lev :: levs1), rlev, levs2))) - in get levs - | None -> - (match levs with - | lev :: levs -> - ([], (change_lev entry lev ""), levs) - | [] -> ([], empty_lev, [])) - - let rec check_gram entry = - function - | Snterm e -> - if ( != ) e.egram entry.egram - then - (eprintf - "\ - Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush Pervasives.stderr; - failwith "Grammar.extend error") - else () - | Snterml (e, _) -> - if ( != ) e.egram entry.egram - then - (eprintf - "\ - Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush Pervasives.stderr; - failwith "Grammar.extend error") - else () - | Smeta (_, sl, _) -> List.iter (check_gram entry) sl - | Slist0sep (s, t) -> - (check_gram entry t; check_gram entry s) - | Slist1sep (s, t) -> - (check_gram entry t; check_gram entry s) - | Slist0 s | Slist1 s | Sopt s | Stry s -> - check_gram entry s - | Stree t -> tree_check_gram entry t - | Snext | Sself | Stoken _ | Skeyword _ -> () - and tree_check_gram entry = - function - | Node { node = n; brother = bro; son = son } -> - (check_gram entry n; - tree_check_gram entry bro; - tree_check_gram entry son) - | LocAct (_, _) | DeadEnd -> () - - let get_initial = - function - | Sself :: symbols -> (true, symbols) - | symbols -> (false, symbols) - - let insert_tokens gram symbols = - let rec insert = - function - | Smeta (_, sl, _) -> List.iter insert sl - | Slist0 s | Slist1 s | Sopt s | Stry s -> insert s - | Slist0sep (s, t) -> (insert s; insert t) - | Slist1sep (s, t) -> (insert s; insert t) - | Stree t -> tinsert t - | Skeyword kwd -> using gram kwd - | Snterm _ | Snterml (_, _) | Snext | Sself | Stoken _ -> - () - and tinsert = - function - | Node { node = s; brother = bro; son = son } -> - (insert s; tinsert bro; tinsert son) - | LocAct (_, _) | DeadEnd -> () - in List.iter insert symbols - - let insert_tree entry gsymbols action tree = - let rec insert symbols tree = - match symbols with - | s :: sl -> insert_in_tree s sl tree - | [] -> - (match tree with - | Node { node = s; son = son; brother = bro } -> - Node - { - node = s; - son = son; - brother = insert [] bro; - } - | LocAct (old_action, action_list) -> - let () = - if !(entry.egram.warning_verbose) - then - eprintf - " Grammar extension: in [%s] some rule has been masked@." - entry.ename - else () - in LocAct (action, (old_action :: action_list)) - | DeadEnd -> LocAct (action, [])) - and insert_in_tree s sl tree = - match try_insert s sl tree with - | Some t -> t - | None -> - Node - { - node = s; - son = insert sl DeadEnd; - brother = tree; - } - and try_insert s sl tree = - match tree with - | Node { node = s1; son = son; brother = bro } -> - if Tools.eq_symbol s s1 - then - (let t = - Node - { - node = s1; - son = insert sl son; - brother = bro; - } - in Some t) - else - if - (is_before s1 s) || - ((derive_eps s) && (not (derive_eps s1))) - then - (let bro = - match try_insert s sl bro with - | Some bro -> bro - | None -> - Node - { - node = s; - son = insert sl DeadEnd; - brother = bro; - } in - let t = - Node { node = s1; son = son; brother = bro; } - in Some t) - else - (match try_insert s sl bro with - | Some bro -> - let t = - Node - { node = s1; son = son; brother = bro; } - in Some t - | None -> None) - | LocAct (_, _) | DeadEnd -> None - in insert gsymbols tree - - let insert_level entry e1 symbols action slev = - match e1 with - | true -> - { - assoc = slev.assoc; - lname = slev.lname; - lsuffix = - insert_tree entry symbols action slev.lsuffix; - lprefix = slev.lprefix; - } - | false -> - { - assoc = slev.assoc; - lname = slev.lname; - lsuffix = slev.lsuffix; - lprefix = - insert_tree entry symbols action slev.lprefix; - } - - let levels_of_rules entry position rules = - let elev = - match entry.edesc with - | Dlevels elev -> elev - | Dparser _ -> - (eprintf "Error: entry not extensible: \"%s\"\n" - entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend") - in - if rules = [] - then elev - else - (let (levs1, make_lev, levs2) = - get_level entry position elev in - let (levs, _) = - List.fold_left - (fun (levs, make_lev) (lname, assoc, level) -> - let lev = make_lev lname assoc in - let lev = - List.fold_left - (fun lev (symbols, action) -> - let symbols = - List.map (change_to_self entry) - symbols - in - (List.iter (check_gram entry) symbols; - let (e1, symbols) = - get_initial symbols - in - (insert_tokens entry.egram symbols; - insert_level entry e1 symbols - action lev))) - lev level - in ((lev :: levs), empty_lev)) - ([], make_lev) rules - in levs1 @ ((List.rev levs) @ levs2)) - - let extend entry (position, rules) = - let elev = levels_of_rules entry position rules - in - (entry.edesc <- Dlevels elev; - entry.estart <- - (fun lev strm -> - let f = Parser.start_parser_of_entry entry - in (entry.estart <- f; f lev strm)); - entry.econtinue <- - fun lev bp a strm -> - let f = Parser.continue_parser_of_entry entry - in (entry.econtinue <- f; f lev bp a strm)) - - end - - end - - module Delete = - struct - exception Rule_not_found of (string * string) - - let _ = - let () = - Printexc.register_printer - (function - | Rule_not_found ((symbols, entry)) -> - let msg = - Printf.sprintf - "rule %S cannot be found in entry\n%s" symbols - entry - in Some msg - | _ -> None) - in () - - module Make (Structure : Structure.S) = - struct - module Tools = Tools.Make(Structure) - - module Parser = Parser.Make(Structure) - - module Print = Print.Make(Structure) - - open Structure - - let raise_rule_not_found entry symbols = - let to_string f x = - let buff = Buffer.create 128 in - let ppf = Format.formatter_of_buffer buff - in - (f ppf x; - Format.pp_print_flush ppf (); - Buffer.contents buff) in - let entry = to_string Print.entry entry in - let symbols = to_string Print.print_rule symbols - in raise (Rule_not_found ((symbols, entry))) - - let delete_rule_in_tree entry = - let rec delete_in_tree symbols tree = - match (symbols, tree) with - | (s :: sl, Node n) -> - if Tools.logically_eq_symbols entry s n.node - then delete_son sl n - else - (match delete_in_tree symbols n.brother with - | Some ((dsl, t)) -> - Some - ((dsl, - (Node - { - node = n.node; - son = n.son; - brother = t; - }))) - | None -> None) - | (_ :: _, _) -> None - | ([], Node n) -> - (match delete_in_tree [] n.brother with - | Some ((dsl, t)) -> - Some - ((dsl, - (Node - { - node = n.node; - son = n.son; - brother = t; - }))) - | None -> None) - | ([], DeadEnd) -> None - | ([], LocAct (_, [])) -> Some (((Some []), DeadEnd)) - | ([], LocAct (_, (action :: list))) -> - Some ((None, (LocAct (action, list)))) - and delete_son sl n = - match delete_in_tree sl n.son with - | Some ((Some dsl, DeadEnd)) -> - Some (((Some (n.node :: dsl)), (n.brother))) - | Some ((Some dsl, t)) -> - let t = - Node - { node = n.node; son = t; brother = n.brother; } - in Some (((Some (n.node :: dsl)), t)) - | Some ((None, t)) -> - let t = - Node - { node = n.node; son = t; brother = n.brother; } - in Some ((None, t)) - | None -> None - in delete_in_tree - - let rec decr_keyw_use gram = - function - | Skeyword kwd -> removing gram kwd - | Smeta (_, sl, _) -> List.iter (decr_keyw_use gram) sl - | Slist0 s | Slist1 s | Sopt s | Stry s -> - decr_keyw_use gram s - | Slist0sep (s1, s2) -> - (decr_keyw_use gram s1; decr_keyw_use gram s2) - | Slist1sep (s1, s2) -> - (decr_keyw_use gram s1; decr_keyw_use gram s2) - | Stree t -> decr_keyw_use_in_tree gram t - | Sself | Snext | Snterm _ | Snterml (_, _) | Stoken _ -> - () - and decr_keyw_use_in_tree gram = - function - | DeadEnd | LocAct (_, _) -> () - | Node n -> - (decr_keyw_use gram n.node; - decr_keyw_use_in_tree gram n.son; - decr_keyw_use_in_tree gram n.brother) - - let rec delete_rule_in_suffix entry symbols = - function - | lev :: levs -> - (match delete_rule_in_tree entry symbols lev.lsuffix - with - | Some ((dsl, t)) -> - ((match dsl with - | Some dsl -> - List.iter (decr_keyw_use entry.egram) dsl - | None -> ()); - (match t with - | DeadEnd when lev.lprefix == DeadEnd -> levs - | _ -> - let lev = - { - assoc = lev.assoc; - lname = lev.lname; - lsuffix = t; - lprefix = lev.lprefix; - } - in lev :: levs)) - | None -> - let levs = - delete_rule_in_suffix entry symbols levs - in lev :: levs) - | [] -> raise_rule_not_found entry symbols - - let rec delete_rule_in_prefix entry symbols = - function - | lev :: levs -> - (match delete_rule_in_tree entry symbols lev.lprefix - with - | Some ((dsl, t)) -> - ((match dsl with - | Some dsl -> - List.iter (decr_keyw_use entry.egram) dsl - | None -> ()); - (match t with - | DeadEnd when lev.lsuffix == DeadEnd -> levs - | _ -> - let lev = - { - assoc = lev.assoc; - lname = lev.lname; - lsuffix = lev.lsuffix; - lprefix = t; - } - in lev :: levs)) - | None -> - let levs = - delete_rule_in_prefix entry symbols levs - in lev :: levs) - | [] -> raise_rule_not_found entry symbols - - let rec delete_rule_in_level_list entry symbols levs = - match symbols with - | Sself :: symbols -> - delete_rule_in_suffix entry symbols levs - | Snterm e :: symbols when e == entry -> - delete_rule_in_suffix entry symbols levs - | _ -> delete_rule_in_prefix entry symbols levs - - let delete_rule entry sl = - match entry.edesc with - | Dlevels levs -> - let levs = delete_rule_in_level_list entry sl levs - in - (entry.edesc <- Dlevels levs; - entry.estart <- - (fun lev strm -> - let f = Parser.start_parser_of_entry entry - in (entry.estart <- f; f lev strm)); - entry.econtinue <- - (fun lev bp a strm -> - let f = Parser.continue_parser_of_entry entry - in (entry.econtinue <- f; f lev bp a strm))) - | Dparser _ -> () - - end - - end - - module Fold : - sig - module Make (Structure : Structure.S) : - sig - open Structure - - val sfold0 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold - - val sfold1 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold - - val sfold0sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) foldsep - - end - - end = - struct - module Make (Structure : Structure.S) = - struct - open Structure - - open Format - - module Parse = Parser.Make(Structure) - - module Fail = Failed.Make(Structure) - - open Sig.Grammar - - module Stream = - struct - type 'a t = 'a Stream.t - - exception Failure = Stream.Failure - - exception Error = Stream.Error - - end - - let sfold0 f e _entry _symbl psymb = - let rec fold accu (__strm : _ Stream.t) = - match try Some (psymb __strm) - with | Stream.Failure -> None - with - | Some a -> fold (f a accu) __strm - | _ -> accu - in fun (__strm : _ Stream.t) -> fold e __strm - - let sfold1 f e _entry _symbl psymb = - let rec fold accu (__strm : _ Stream.t) = - match try Some (psymb __strm) - with | Stream.Failure -> None - with - | Some a -> fold (f a accu) __strm - | _ -> accu - in - fun (__strm : _ Stream.t) -> - let a = psymb __strm - in - try fold (f a e) __strm - with | Stream.Failure -> raise (Stream.Error "") - - let sfold0sep f e entry symbl psymb psep = - let failed = - function - | [ symb; sep ] -> Fail.symb_failed_txt entry sep symb - | _ -> "failed" in - let rec kont accu (__strm : _ Stream.t) = - match try Some (psep __strm) - with | Stream.Failure -> None - with - | Some () -> - let a = - (try psymb __strm - with - | Stream.Failure -> - raise (Stream.Error (failed symbl))) - in kont (f a accu) __strm - | _ -> accu - in - fun (__strm : _ Stream.t) -> - match try Some (psymb __strm) - with | Stream.Failure -> None - with - | Some a -> kont (f a e) __strm - | _ -> e - - let sfold1sep f e entry symbl psymb psep = - let failed = - function - | [ symb; sep ] -> Fail.symb_failed_txt entry sep symb - | _ -> "failed" in - let parse_top = - function - | [ symb; _ ] -> Parse.parse_top_symb entry symb - | _ -> raise Stream.Failure in - let rec kont accu (__strm : _ Stream.t) = - match try Some (psep __strm) - with | Stream.Failure -> None - with - | Some () -> - let a = - (try - try psymb __strm - with - | Stream.Failure -> - let a = - (try parse_top symbl __strm - with - | Stream.Failure -> - raise (Stream.Error (failed symbl))) - in Obj.magic a - with | Stream.Failure -> raise (Stream.Error "")) - in kont (f a accu) __strm - | _ -> accu - in - fun (__strm : _ Stream.t) -> - let a = psymb __strm in kont (f a e) __strm - - end - - end - - module Entry = - struct - module Make (Structure : Structure.S) = - struct - module Dump = Print.MakeDump(Structure) - - module Print = Print.Make(Structure) - - module Tools = Tools.Make(Structure) - - open Format - - open Structure - - open Tools - - type 'a t = internal_entry - - let name e = e.ename - - let print ppf e = fprintf ppf "%a@\n" Print.entry e - - let dump ppf e = fprintf ppf "%a@\n" Dump.entry e - - let mk g n = - { - egram = g; - ename = n; - estart = empty_entry n; - econtinue = - (fun _ _ _ (__strm : _ Stream.t) -> - raise Stream.Failure); - edesc = Dlevels []; - } - - let action_parse entry ts : Action.t = - try entry.estart 0 ts - with - | Stream.Failure -> - Loc.raise (get_prev_loc ts) - (Stream.Error ("illegal begin of " ^ entry.ename)) - | (Loc.Exc_located (_, _) as exc) -> raise exc - | exc -> Loc.raise (get_prev_loc ts) exc - - let lex entry loc cs = entry.egram.glexer loc cs - - let lex_string entry loc str = - lex entry loc (Stream.of_string str) - - let filter entry ts = - keep_prev_loc - (Token.Filter.filter (get_filter entry.egram) ts) - - let parse_tokens_after_filter entry ts = - Action.get (action_parse entry ts) - - let parse_tokens_before_filter entry ts = - parse_tokens_after_filter entry (filter entry ts) - - let parse entry loc cs = - parse_tokens_before_filter entry (lex entry loc cs) - - let parse_string entry loc str = - parse_tokens_before_filter entry (lex_string entry loc str) - - let of_parser g n - (p : (Token.t * token_info) Stream.t -> 'a) : 'a t = - let f ts = Action.mk (p ts) - in - { - egram = g; - ename = n; - estart = (fun _ -> f); - econtinue = - (fun _ _ _ (__strm : _ Stream.t) -> - raise Stream.Failure); - edesc = Dparser f; - } - - let setup_parser e - (p : (Token.t * token_info) Stream.t -> 'a) - = - let f ts = Action.mk (p ts) - in - (e.estart <- (fun _ -> f); - e.econtinue <- - (fun _ _ _ (__strm : _ Stream.t) -> - raise Stream.Failure); - e.edesc <- Dparser f) - - let clear e = - (e.estart <- - (fun _ (__strm : _ Stream.t) -> raise Stream.Failure); - e.econtinue <- - (fun _ _ _ (__strm : _ Stream.t) -> raise Stream.Failure); - e.edesc <- Dlevels []) - - let obj x = x - - end - - end - - module Static = - struct - let uncurry f (x, y) = f x y - - let flip f x y = f y x - - module Make (Lexer : Sig.Lexer) : - Sig.Grammar.Static with module Loc = Lexer.Loc - and module Token = Lexer.Token = - struct - module Structure = Structure.Make(Lexer) - - module Delete = Delete.Make(Structure) - - module Insert = Insert.Make(Structure) - - module Fold = Fold.Make(Structure) - - module Tools = Tools.Make(Structure) - - include Structure - - let gram = - let gkeywords = Hashtbl.create 301 - in - { - gkeywords = gkeywords; - gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); - glexer = Lexer.mk (); - warning_verbose = ref true; - error_verbose = Camlp4_config.verbose; - } - - module Entry = - struct - module E = Entry.Make(Structure) - - type 'a t = 'a E.t - - let mk = E.mk gram - - let of_parser name strm = E.of_parser gram name strm - - let setup_parser = E.setup_parser - - let name = E.name - - let print = E.print - - let clear = E.clear - - let dump = E.dump - - let obj x = x - - end - - let get_filter () = gram.gfilter - - let lex loc cs = gram.glexer loc cs - - let lex_string loc str = lex loc (Stream.of_string str) - - let filter ts = - Tools.keep_prev_loc (Token.Filter.filter gram.gfilter ts) - - let parse_tokens_after_filter entry ts = - Entry.E.parse_tokens_after_filter entry ts - - let parse_tokens_before_filter entry ts = - parse_tokens_after_filter entry (filter ts) - - let parse entry loc cs = - parse_tokens_before_filter entry (lex loc cs) - - let parse_string entry loc str = - parse_tokens_before_filter entry (lex_string loc str) - - let delete_rule = Delete.delete_rule - - let srules e rl = - Stree - (List.fold_left (flip (uncurry (Insert.insert_tree e))) - DeadEnd rl) - - let sfold0 = Fold.sfold0 - - let sfold1 = Fold.sfold1 - - let sfold0sep = Fold.sfold0sep - - let extend = Insert.extend - - end - - end - - module Dynamic = - struct - module Make (Lexer : Sig.Lexer) : - Sig.Grammar.Dynamic with module Loc = Lexer.Loc - and module Token = Lexer.Token = - struct - module Structure = Structure.Make(Lexer) - - module Delete = Delete.Make(Structure) - - module Insert = Insert.Make(Structure) - - module Entry = Entry.Make(Structure) - - module Fold = Fold.Make(Structure) - - module Tools = Tools.Make(Structure) - - include Structure - - let mk () = - let gkeywords = Hashtbl.create 301 - in - { - gkeywords = gkeywords; - gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); - glexer = Lexer.mk (); - warning_verbose = ref true; - error_verbose = Camlp4_config.verbose; - } - - let get_filter g = g.gfilter - - let lex g loc cs = g.glexer loc cs - - let lex_string g loc str = lex g loc (Stream.of_string str) - - let filter g ts = - Tools.keep_prev_loc (Token.Filter.filter g.gfilter ts) - - let parse_tokens_after_filter entry ts = - Entry.parse_tokens_after_filter entry ts - - let parse_tokens_before_filter entry ts = - parse_tokens_after_filter entry (filter entry.egram ts) - - let parse entry loc cs = - parse_tokens_before_filter entry (lex entry.egram loc cs) - - let parse_string entry loc str = - parse_tokens_before_filter entry - (lex_string entry.egram loc str) - - let delete_rule = Delete.delete_rule - - let srules e rl = - let t = - List.fold_left - (fun tree (symbols, action) -> - Insert.insert_tree e symbols action tree) - DeadEnd rl - in Stree t - - let sfold0 = Fold.sfold0 - - let sfold1 = Fold.sfold1 - - let sfold0sep = Fold.sfold0sep - - let extend = Insert.extend - - end - - end - - end - - end - -module Printers = - struct - module DumpCamlp4Ast : - sig - module Id : Sig.Id - - module Make (Syntax : Sig.Syntax) : Sig.Printer(Syntax.Ast).S - - end = - struct - module Id = - struct - let name = "Camlp4Printers.DumpCamlp4Ast" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Syntax) : Sig.Printer(Syntax.Ast).S = - struct - include Syntax - - let with_open_out_file x f = - match x with - | Some file -> - let oc = open_out_bin file - in (f oc; flush oc; close_out oc) - | None -> - (set_binary_mode_out stdout true; f stdout; flush stdout) - - let dump_ast magic ast oc = - (output_string oc magic; output_value oc ast) - - let print_interf ?input_file:(_) ?output_file ast = - with_open_out_file output_file - (dump_ast Camlp4_config.camlp4_ast_intf_magic_number ast) - - let print_implem ?input_file:(_) ?output_file ast = - with_open_out_file output_file - (dump_ast Camlp4_config.camlp4_ast_impl_magic_number ast) - - end - - end - - module DumpOCamlAst : - sig - module Id : Sig.Id - - module Make (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax.Ast).S - - end = - struct - module Id : Sig.Id = - struct - let name = "Camlp4Printers.DumpOCamlAst" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax.Ast).S = - struct - include Syntax - - module Ast2pt = Struct.Camlp4Ast2OCamlAst.Make(Ast) - - let with_open_out_file x f = - match x with - | Some file -> - let oc = open_out_bin file - in (f oc; flush oc; close_out oc) - | None -> - (set_binary_mode_out stdout true; f stdout; flush stdout) - - let dump_pt magic fname pt oc = - (output_string oc magic; - output_value oc (if fname = "-" then "" else fname); - output_value oc pt) - - let print_interf ?(input_file = "-") ?output_file ast = - let pt = Ast2pt.sig_item ast - in - with_open_out_file output_file - (dump_pt Camlp4_config.ocaml_ast_intf_magic_number - input_file pt) - - let print_implem ?(input_file = "-") ?output_file ast = - let pt = Ast2pt.str_item ast - in - with_open_out_file output_file - (dump_pt Camlp4_config.ocaml_ast_impl_magic_number - input_file pt) - - end - - end - - module Null : - sig - module Id : Sig.Id - - module Make (Syntax : Sig.Syntax) : Sig.Printer(Syntax.Ast).S - - end = - struct - module Id = - struct - let name = "Camlp4.Printers.Null" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Syntax) = - struct - include Syntax - - let print_interf ?input_file:(_) ?output_file:(_) _ = () - - let print_implem ?input_file:(_) ?output_file:(_) _ = () - - end - - end - - module OCaml : - sig - module Id : Sig.Id - - module Make (Syntax : Sig.Camlp4Syntax) : - sig - open Format - - include Sig.Camlp4Syntax with module Loc = Syntax.Loc - and module Token = Syntax.Token and module Ast = Syntax.Ast - and module Gram = Syntax.Gram - - type sep = (unit, formatter, unit) format - - type fun_binding = [ | `patt of Ast.patt | `newtype of string ] - - val list' : - (formatter -> 'a -> unit) -> - ('b, formatter, unit) format -> - (unit, formatter, unit) format -> - formatter -> 'a list -> unit - - val list : - (formatter -> 'a -> unit) -> - ('b, formatter, unit) format -> formatter -> 'a list -> unit - - val lex_string : string -> Token.t - - val is_infix : string -> bool - - val is_keyword : string -> bool - - val ocaml_char : string -> string - - val get_expr_args : - Ast.expr -> Ast.expr list -> (Ast.expr * (Ast.expr list)) - - val get_patt_args : - Ast.patt -> Ast.patt list -> (Ast.patt * (Ast.patt list)) - - val get_ctyp_args : - Ast.ctyp -> Ast.ctyp list -> (Ast.ctyp * (Ast.ctyp list)) - - val expr_fun_args : Ast.expr -> ((fun_binding list) * Ast.expr) - - class printer : - ?curry_constr: bool -> - ?comments: bool -> - unit -> - object ('a) - method interf : formatter -> Ast.sig_item -> unit - method implem : formatter -> Ast.str_item -> unit - method sig_item : formatter -> Ast.sig_item -> unit - method str_item : formatter -> Ast.str_item -> unit - val pipe : bool - val semi : bool - val semisep : sep - val no_semisep : sep - method value_val : string - method value_let : string - method andsep : sep - method anti : formatter -> string -> unit - method class_declaration : - formatter -> Ast.class_expr -> unit - method class_expr : formatter -> Ast.class_expr -> unit - method class_sig_item : - formatter -> Ast.class_sig_item -> unit - method class_str_item : - formatter -> Ast.class_str_item -> unit - method class_type : formatter -> Ast.class_type -> unit - method constrain : - formatter -> (Ast.ctyp * Ast.ctyp) -> unit - method ctyp : formatter -> Ast.ctyp -> unit - method ctyp1 : formatter -> Ast.ctyp -> unit - method constructor_type : formatter -> Ast.ctyp -> unit - method dot_expr : formatter -> Ast.expr -> unit - method apply_expr : formatter -> Ast.expr -> unit - method expr : formatter -> Ast.expr -> unit - method expr_list : formatter -> Ast.expr list -> unit - method expr_list_cons : - bool -> formatter -> Ast.expr -> unit - method fun_binding : formatter -> fun_binding -> unit - method functor_arg : - formatter -> (string * Ast.module_type) -> unit - method functor_args : - formatter -> (string * Ast.module_type) list -> unit - method ident : formatter -> Ast.ident -> unit - method numeric : formatter -> string -> string -> unit - method binding : formatter -> Ast.binding -> unit - method record_binding : - formatter -> Ast.rec_binding -> unit - method match_case : formatter -> Ast.match_case -> unit - method match_case_aux : - formatter -> Ast.match_case -> unit - method mk_expr_list : - Ast.expr -> ((Ast.expr list) * (Ast.expr option)) - method mk_patt_list : - Ast.patt -> ((Ast.patt list) * (Ast.patt option)) - method simple_module_expr : - formatter -> Ast.module_expr -> unit - method module_expr : - formatter -> Ast.module_expr -> unit - method module_expr_get_functor_args : - (string * Ast.module_type) list -> - Ast.module_expr -> - (((string * Ast.module_type) list) * Ast. - module_expr * (Ast.module_type option)) - method module_rec_binding : - formatter -> Ast.module_binding -> unit - method module_type : - formatter -> Ast.module_type -> unit - method override_flag : - formatter -> Ast.override_flag -> unit - method mutable_flag : - formatter -> Ast.mutable_flag -> unit - method direction_flag : - formatter -> Ast.direction_flag -> unit - method rec_flag : formatter -> Ast.rec_flag -> unit - method node : formatter -> 'b -> ('b -> Loc.t) -> unit - method patt : formatter -> Ast.patt -> unit - method patt1 : formatter -> Ast.patt -> unit - method patt2 : formatter -> Ast.patt -> unit - method patt3 : formatter -> Ast.patt -> unit - method patt4 : formatter -> Ast.patt -> unit - method patt5 : formatter -> Ast.patt -> unit - method patt_tycon : formatter -> Ast.patt -> unit - method patt_expr_fun_args : - formatter -> (fun_binding * Ast.expr) -> unit - method patt_class_expr_fun_args : - formatter -> (Ast.patt * Ast.class_expr) -> unit - method print_comments_before : - Loc.t -> formatter -> unit - method private_flag : - formatter -> Ast.private_flag -> unit - method virtual_flag : - formatter -> Ast.virtual_flag -> unit - method quoted_string : formatter -> string -> unit - method raise_match_failure : formatter -> Loc.t -> unit - method reset : 'a - method reset_semi : 'a - method semisep : sep - method set_comments : bool -> 'a - method set_curry_constr : bool -> 'a - method set_loc_and_comments : 'a - method set_semisep : sep -> 'a - method simple_ctyp : formatter -> Ast.ctyp -> unit - method simple_expr : formatter -> Ast.expr -> unit - method simple_patt : formatter -> Ast.patt -> unit - method seq : formatter -> Ast.expr -> unit - method string : formatter -> string -> unit - method sum_type : formatter -> Ast.ctyp -> unit - method type_params : formatter -> Ast.ctyp list -> unit - method class_params : formatter -> Ast.ctyp -> unit - method under_pipe : 'a - method under_semi : 'a - method var : formatter -> string -> unit - method with_constraint : - formatter -> Ast.with_constr -> unit - end - - val with_outfile : - string option -> (formatter -> 'a -> unit) -> 'a -> unit - - val print : - string option -> - (printer -> formatter -> 'a -> unit) -> 'a -> unit - - end - - module MakeMore (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax. - Ast).S - - end = - struct - open Format - - module Id = - struct - let name = "Camlp4.Printers.OCaml" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - include Syntax - - type sep = (unit, formatter, unit) format - - type fun_binding = [ | `patt of Ast.patt | `newtype of string ] - - let pp = fprintf - - let cut f = fprintf f "@ " - - let list' elt sep sep' f = - let rec loop = - function - | [] -> () - | x :: xs -> (pp f sep; elt f x; pp f sep'; loop xs) - in - function - | [] -> () - | [ x ] -> (elt f x; pp f sep') - | x :: xs -> (elt f x; pp f sep'; loop xs) - - let list elt sep f = - let rec loop = - function | [] -> () | x :: xs -> (pp f sep; elt f x; loop xs) - in - function - | [] -> () - | [ x ] -> elt f x - | x :: xs -> (elt f x; loop xs) - - let rec list_of_meta_list = - function - | Ast.LNil -> [] - | Ast.LCons (x, xs) -> x :: (list_of_meta_list xs) - | Ast.LAnt _ -> assert false - - let meta_list elt sep f mxs = - let xs = list_of_meta_list mxs in list elt sep f xs - - module CommentFilter = Struct.CommentFilter.Make(Token) - - let comment_filter = CommentFilter.mk () - - let _ = CommentFilter.define (Gram.get_filter ()) comment_filter - - module StringSet = Set.Make(String) - - let infix_lidents = - [ "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or" ] - - let is_infix = - let first_chars = - [ '='; '<'; '>'; '|'; '&'; '$'; '@'; '^'; '+'; '-'; '*'; '/'; - '%'; '\\' ] - and infixes = - List.fold_right StringSet.add infix_lidents StringSet.empty - in - fun s -> - (StringSet.mem s infixes) || - ((s <> "") && (List.mem s.[0] first_chars)) - - let is_keyword = - let keywords = - List.fold_right StringSet.add - [ "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 - - module Lexer = Struct.Lexer.Make(Token) - - let _ = let module M = ErrorHandler.Register(Lexer.Error) in () - - open Sig - - let lexer s = - Lexer.from_string ~quotations: !Camlp4_config.quotations Loc. - ghost s - - let lex_string str = - try - let (__strm : _ Stream.t) = lexer str - in - match Stream.peek __strm with - | Some ((tok, _)) -> - (Stream.junk __strm; - (match Stream.peek __strm with - | Some ((EOI, _)) -> (Stream.junk __strm; tok) - | _ -> raise (Stream.Error ""))) - | _ -> raise Stream.Failure - with - | Stream.Failure | Stream.Error _ -> - failwith - (sprintf - "Cannot print %S this string contains more than one token" - str) - | Lexer.Error.E exn -> - failwith - (sprintf - "Cannot print %S this identifier does not respect OCaml lexing rules (%s)" - str (Lexer.Error.to_string exn)) - - let ocaml_char x = Char.escaped (Struct.Token.Eval.char x) - - let rec get_expr_args a al = - match a with - | Ast.ExApp (_, a1, a2) -> get_expr_args a1 (a2 :: al) - | _ -> (a, al) - - let rec get_patt_args a al = - match a with - | Ast.PaApp (_, a1, a2) -> get_patt_args a1 (a2 :: al) - | _ -> (a, al) - - let rec get_ctyp_args a al = - match a with - | Ast.TyApp (_, a1, a2) -> get_ctyp_args a1 (a2 :: al) - | _ -> (a, al) - - let is_irrefut_patt = Ast.is_irrefut_patt - - let rec expr_fun_args = - function - | (Ast.ExFun (_, (Ast.McArr (_, p, (Ast.ExNil _), e))) as ge) - -> - if is_irrefut_patt p - then - (let (pl, e) = expr_fun_args e in (((`patt p) :: pl), e)) - else ([], ge) - | Ast.ExFUN (_, i, e) -> - let (pl, e) = expr_fun_args e in (((`newtype i) :: pl), e) - | ge -> ([], ge) - - let rec class_expr_fun_args = - function - | (Ast.CeFun (_, p, ce) as ge) -> - if is_irrefut_patt p - then - (let (pl, ce) = class_expr_fun_args ce in ((p :: pl), ce)) - else ([], ge) - | ge -> ([], ge) - - let rec do_print_comments_before loc f (__strm : _ Stream.t) = - match Stream.peek __strm with - | Some ((comm, comm_loc)) when Loc.strictly_before comm_loc loc - -> - (Stream.junk __strm; - let s = __strm in - let () = f comm comm_loc - in do_print_comments_before loc f s) - | _ -> () - - class printer ?curry_constr:(init_curry_constr = false) - ?(comments = true) () = - object (o) - val pipe = false - val semi = false - method under_pipe = {< pipe = true; >} - method under_semi = {< semi = true; >} - method reset_semi = {< semi = false; >} - method reset = {< pipe = false; semi = false; >} - val semisep = (";;" : sep) - val no_semisep = ("" : sep) - val mode = if comments then `comments else `no_comments - val curry_constr = init_curry_constr - val var_conversion = false - method andsep : sep = "@]@ @[<2>and@ " - method value_val = "val" - method value_let = "let" - method semisep = semisep - method set_semisep = fun s -> {< semisep = s; >} - method set_comments = - fun b -> - {< mode = if b then `comments else `no_comments; >} - method set_loc_and_comments = {< mode = `loc_and_comments; >} - method set_curry_constr = fun b -> {< curry_constr = b; >} - method print_comments_before = - fun loc f -> - match mode with - | `comments -> - do_print_comments_before loc - (fun c _ -> pp f "%s@ " c) - (CommentFilter.take_stream comment_filter) - | `loc_and_comments -> - let () = pp f "(*loc: %a*)@ " Loc.dump loc - in - do_print_comments_before loc - (fun s -> pp f "%s(*comm_loc: %a*)@ " s Loc.dump) - (CommentFilter.take_stream comment_filter) - | _ -> () - method var = - fun f -> - function - | "" -> pp f "$lid:\"\"$" - | "[]" -> pp f "[]" - | "()" -> pp f "()" - | " True" -> pp f "True" - | " False" -> pp f "False" - | v -> - (match (var_conversion, v) with - | (true, "val") -> pp f "contents" - | (true, "True") -> pp f "true" - | (true, "False") -> pp f "false" - | _ -> - (match lex_string v with - | LIDENT s | UIDENT s | ESCAPED_IDENT s when - is_keyword 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 -> - pp_print_string f s - | tok -> - failwith - (sprintf - "Bad token used as an identifier: %s" - (Token.to_string tok)))) - method type_params = - fun f -> - function - | [] -> () - | [ x ] -> pp f "%a@ " o#ctyp x - | l -> pp f "@[<1>(%a)@]@ " (list o#ctyp ",@ ") l - method class_params = - fun f -> - function - | Ast.TyCom (_, t1, t2) -> - pp f "@[<1>%a,@ %a@]" o#class_params t1 - o#class_params t2 - | x -> o#ctyp f x - method override_flag = - fun f -> - function - | Ast.OvOverride -> pp f "!" - | Ast.OvNil -> () - | Ast.OvAnt s -> o#anti f s - method mutable_flag = - fun f -> - function - | Ast.MuMutable -> pp f "mutable@ " - | Ast.MuNil -> () - | Ast.MuAnt s -> o#anti f s - method rec_flag = - fun f -> - function - | Ast.ReRecursive -> pp f "rec@ " - | Ast.ReNil -> () - | Ast.ReAnt s -> o#anti f s - method virtual_flag = - fun f -> - function - | Ast.ViVirtual -> pp f "virtual@ " - | Ast.ViNil -> () - | Ast.ViAnt s -> o#anti f s - method private_flag = - fun f -> - function - | Ast.PrPrivate -> pp f "private@ " - | Ast.PrNil -> () - | Ast.PrAnt s -> o#anti f s - method anti = fun f s -> pp f "$%s$" s - method seq = - fun f -> - function - | Ast.ExSem (_, e1, e2) -> - pp f "%a;@ %a" o#under_semi#seq e1 o#seq e2 - | Ast.ExSeq (_, e) -> o#seq f e - | e -> o#expr f e - method match_case = - fun f -> - function - | Ast.McNil _loc -> - pp f "@[<2>@ _ ->@ %a@]" o#raise_match_failure _loc - | a -> o#match_case_aux f a - method match_case_aux = - fun f -> - function - | Ast.McNil _ -> () - | Ast.McAnt (_, s) -> o#anti f s - | Ast.McOr (_, a1, a2) -> - pp f "%a%a" o#match_case_aux a1 o#match_case_aux a2 - | Ast.McArr (_, p, (Ast.ExNil _), e) -> - pp f "@ | @[<2>%a@ ->@ %a@]" o#patt p - o#under_pipe#expr e - | Ast.McArr (_, p, w, e) -> - pp f "@ | @[<2>%a@ when@ %a@ ->@ %a@]" o#patt p - o#under_pipe#expr w o#under_pipe#expr e - method fun_binding = - fun f -> - function - | `patt p -> o#simple_patt f p - | `newtype i -> pp f "(type %s)" i - method binding = - fun f bi -> - let () = o#node f bi Ast.loc_of_binding - in - match bi with - | Ast.BiNil _ -> () - | Ast.BiAnd (_, b1, b2) -> - (o#binding f b1; pp f o#andsep; o#binding f b2) - | Ast.BiEq (_, p, e) -> - let (pl, e') = - (match p with - | Ast.PaTyc (_, _, _) -> ([], e) - | _ -> expr_fun_args e) - in - (match (p, e') with - | (Ast.PaId (_, (Ast.IdLid (_, _))), - Ast.ExTyc (_, e', t)) -> - pp f "%a :@ %a =@ %a" - (list o#fun_binding "@ ") - ((`patt p) :: pl) o#ctyp t o#expr e' - | (Ast.PaId (_, (Ast.IdLid (_, _))), _) -> - pp f "%a @[<0>%a=@]@ %a" o#simple_patt p - (list' o#fun_binding "" "@ ") pl o#expr e' - | _ -> pp f "%a =@ %a" o#simple_patt p o#expr e) - | Ast.BiAnt (_, s) -> o#anti f s - method record_binding = - fun f bi -> - let () = o#node f bi Ast.loc_of_rec_binding - in - match bi with - | Ast.RbNil _ -> () - | Ast.RbEq (_, i, e) -> - pp f "@ @[<2>%a =@ %a@];" o#var_ident i o#expr e - | Ast.RbSem (_, b1, b2) -> - (o#under_semi#record_binding f b1; - o#under_semi#record_binding f b2) - | Ast.RbAnt (_, s) -> o#anti f s - method mk_patt_list = - function - | Ast.PaApp (_, - (Ast.PaApp (_, (Ast.PaId (_, (Ast.IdUid (_, "::")))), - p1)), - p2) -> - let (pl, c) = o#mk_patt_list p2 in ((p1 :: pl), c) - | Ast.PaId (_, (Ast.IdUid (_, "[]"))) -> ([], None) - | p -> ([], (Some p)) - method mk_expr_list = - function - | Ast.ExApp (_, - (Ast.ExApp (_, (Ast.ExId (_, (Ast.IdUid (_, "::")))), - e1)), - e2) -> - let (el, c) = o#mk_expr_list e2 in ((e1 :: el), c) - | Ast.ExId (_, (Ast.IdUid (_, "[]"))) -> ([], None) - | e -> ([], (Some e)) - method expr_list = - fun f -> - function - | [] -> pp f "[]" - | [ e ] -> pp f "[ %a ]" o#under_semi#expr e - | el -> - pp f "@[<2>[ %a@] ]" (list o#under_semi#expr ";@ ") - el - method expr_list_cons = - fun simple f e -> - let (el, c) = o#mk_expr_list e - in - match c with - | None -> o#expr_list f el - | Some x -> - (if simple - then pp f "@[<2>(%a)@]" - else pp f "@[<2>%a@]") - (list o#under_semi#dot_expr " ::@ ") (el @ [ x ]) - method patt_expr_fun_args = - fun f (p, e) -> - let (pl, e) = expr_fun_args e - in - pp f "%a@ ->@ %a" (list o#fun_binding "@ ") (p :: pl) - o#expr e - method patt_class_expr_fun_args = - fun f (p, ce) -> - let (pl, ce) = class_expr_fun_args ce - in - pp f "%a =@]@ %a" (list o#simple_patt "@ ") (p :: pl) - o#class_expr ce - method constrain = - fun f (t1, t2) -> - pp f "@[<2>constraint@ %a =@ %a@]" o#ctyp t1 o#ctyp t2 - method sum_type = - fun f t -> - match Ast.list_of_ctyp t [] with - | [] -> () - | ts -> - pp f "@[| %a@]" - (list o#constructor_declaration "@ | ") ts - method private constructor_declaration = - fun f t -> - match t with - | Ast.TyCol (_, t1, (Ast.TyArr (_, t2, t3))) -> - pp f "@[<2>%a :@ @[<2>%a@ ->@ %a@]@]" o#ctyp t1 - o#constructor_type t2 o#ctyp t3 - | t -> o#ctyp f t - method string = fun f -> pp f "%s" - method quoted_string = fun f -> pp f "%S" - method numeric = - fun f num suff -> - if num.[0] = '-' - then pp f "(%s%s)" num suff - else pp f "%s%s" num suff - method module_expr_get_functor_args = - fun accu -> - function - | Ast.MeFun (_, s, mt, me) -> - o#module_expr_get_functor_args ((s, mt) :: accu) me - | Ast.MeTyc (_, me, mt) -> - ((List.rev accu), me, (Some mt)) - | me -> ((List.rev accu), me, None) - method functor_args = fun f -> list o#functor_arg "@ " f - method functor_arg = - fun f (s, mt) -> - pp f "@[<2>(%a :@ %a)@]" o#var s o#module_type mt - method module_rec_binding = - fun f -> - function - | Ast.MbNil _ -> () - | Ast.MbColEq (_, s, mt, me) -> - pp f "@[<2>%a :@ %a =@ %a@]" o#var s o#module_type mt - o#module_expr me - | Ast.MbCol (_, s, mt) -> - pp f "@[<2>%a :@ %a@]" o#var s o#module_type mt - | Ast.MbAnd (_, mb1, mb2) -> - (o#module_rec_binding f mb1; - pp f o#andsep; - o#module_rec_binding f mb2) - | Ast.MbAnt (_, s) -> o#anti f s - method class_declaration = - fun f -> - function - | Ast.CeTyc (_, ce, ct) -> - pp f "%a :@ %a" o#class_expr ce o#class_type ct - | ce -> o#class_expr f ce - method raise_match_failure = - fun f _loc -> - let n = Loc.file_name _loc in - let l = Loc.start_line _loc in - let c = (Loc.start_off _loc) - (Loc.start_bol _loc) - in - o#expr f - (Ast.ExApp (_loc, - (Ast.ExId (_loc, (Ast.IdLid (_loc, "raise")))), - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdUid (_loc, "Match_failure")))), - (Ast.ExStr (_loc, - (Ast.safe_string_escaped n))))), - (Ast.ExInt (_loc, (string_of_int l))))), - (Ast.ExInt (_loc, (string_of_int c))))))) - method node : 'a. formatter -> 'a -> ('a -> Loc.t) -> unit = - fun f node loc_of_node -> - o#print_comments_before (loc_of_node node) f - method ident = - fun f i -> - let () = o#node f i Ast.loc_of_ident - in - match i with - | Ast.IdAcc (_, i1, i2) -> - pp f "%a.@,%a" o#ident i1 o#ident i2 - | Ast.IdApp (_, i1, i2) -> - pp f "%a@,(%a)" o#ident i1 o#ident i2 - | Ast.IdAnt (_, s) -> o#anti f s - | Ast.IdLid (_, s) | Ast.IdUid (_, s) -> o#var f s - method private var_ident = {< var_conversion = true; >}#ident - method expr = - fun f e -> - let () = o#node f e Ast.loc_of_expr - in - match e with - | (Ast.ExLet (_, _, _, _) | Ast.ExLmd (_, _, _, _) as - e) when semi -> pp f "(%a)" o#reset#expr e - | (Ast.ExMat (_, _, _) | Ast.ExTry (_, _, _) | - Ast.ExFun (_, _) - as e) when pipe || semi -> - pp f "(%a)" o#reset#expr e - | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "~-")))), - x) -> pp f "@[<2>-@ %a@]" o#dot_expr x - | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "~-.")))), - x) -> pp f "@[<2>-.@ %a@]" o#dot_expr x - | Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExId (_, (Ast.IdUid (_, "::")))), _)), - _) -> o#expr_list_cons false f e - | Ast.ExApp (_loc, - (Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, n)))), - x)), - y) when is_infix n -> - pp f "@[<2>%a@ %s@ %a@]" o#apply_expr x n - o#apply_expr y - | Ast.ExApp (_, x, y) -> - let (a, al) = get_expr_args x [ y ] - in - if - (not curry_constr) && - (Ast.is_expr_constructor a) - then - (match al with - | [ Ast.ExTup (_, _) ] -> - pp f "@[<2>%a@ (%a)@]" o#apply_expr x - o#expr y - | [ _ ] -> - pp f "@[<2>%a@ %a@]" o#apply_expr x - o#apply_expr y - | al -> - pp f "@[<2>%a@ (%a)@]" o#apply_expr a - (list o#under_pipe#apply_expr ",@ ") al) - else - pp f "@[<2>%a@]" (list o#apply_expr "@ ") - (a :: al) - | Ast.ExAss (_, - (Ast.ExAcc (_, e1, - (Ast.ExId (_, (Ast.IdLid (_, "val")))))), - e2) -> - pp f "@[<2>%a :=@ %a@]" o#dot_expr e1 o#expr e2 - | Ast.ExAss (_, e1, e2) -> - pp f "@[<2>%a@ <-@ %a@]" o#dot_expr e1 o#expr e2 - | Ast.ExFun (loc, (Ast.McNil _)) -> - pp f "@[<2>fun@ _@ ->@ %a@]" o#raise_match_failure - loc - | Ast.ExFun (_, (Ast.McArr (_, p, (Ast.ExNil _), e))) - when is_irrefut_patt p -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args - ((`patt p), e) - | Ast.ExFUN (_, i, e) -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args - ((`newtype i), e) - | Ast.ExFun (_, a) -> - pp f "@[function%a@]" o#match_case a - | Ast.ExIfe (_, e1, e2, e3) -> - pp f - "@[@[<2>if@ %a@]@ @[<2>then@ %a@]@ @[<2>else@ %a@]@]" - o#expr e1 o#under_semi#expr e2 o#under_semi#expr - e3 - | Ast.ExLaz (_, e) -> - pp f "@[<2>lazy@ %a@]" o#simple_expr e - | Ast.ExLet (_, r, bi, e) -> - (match e with - | Ast.ExLet (_, _, _, _) -> - pp f "@[<0>@[<2>let %a%a in@]@ %a@]" - o#rec_flag r o#binding bi o#reset_semi#expr - e - | _ -> - pp f - "@[@[<2>let %a%a@]@ @[in@ %a@]@]" - o#rec_flag r o#binding bi o#reset_semi#expr - e) - | Ast.ExOpI (_, i, e) -> - pp f "@[<2>let open %a@]@ @[<2>in@ %a@]" o#ident i - o#reset_semi#expr e - | Ast.ExMat (_, e, a) -> - pp f "@[@[@[<2>match %a@]@ with@]%a@]" - o#expr e o#match_case a - | Ast.ExTry (_, e, a) -> - pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" - o#expr e o#match_case a - | Ast.ExAsf _ -> pp f "@[<2>assert@ false@]" - | Ast.ExAsr (_, e) -> - pp f "@[<2>assert@ %a@]" o#dot_expr e - | Ast.ExLmd (_, s, me, e) -> - pp f "@[<2>let module %a =@ %a@]@ @[<2>in@ %a@]" - o#var s o#module_expr me o#reset_semi#expr e - | Ast.ExObj (_, (Ast.PaNil _), cst) -> - pp f "@[@[object@ %a@]@ end@]" - o#class_str_item cst - | Ast.ExObj (_, (Ast.PaTyc (_, p, t)), cst) -> - pp f - "@[@[object @[<1>(%a :@ %a)@]@ %a@]@ end@]" - o#patt p o#ctyp t o#class_str_item cst - | Ast.ExObj (_, p, cst) -> - pp f - "@[@[object @[<2>(%a)@]@ %a@]@ end@]" - o#patt p o#class_str_item cst - | e -> o#apply_expr f e - method apply_expr = - fun f e -> - let () = o#node f e Ast.loc_of_expr - in - match e with - | Ast.ExNew (_, i) -> pp f "@[<2>new@ %a@]" o#ident i - | e -> o#dot_expr f e - method dot_expr = - fun f e -> - let () = o#node f e Ast.loc_of_expr - in - match e with - | Ast.ExAcc (_, e, - (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> - pp f "@[<2>!@,%a@]" o#simple_expr e - | Ast.ExAcc (_, e1, e2) -> - pp f "@[<2>%a.@,%a@]" o#dot_expr e1 o#dot_expr e2 - | Ast.ExAre (_, e1, e2) -> - pp f "@[<2>%a.@,(%a)@]" o#dot_expr e1 o#expr e2 - | Ast.ExSte (_, e1, e2) -> - pp f "%a.@[<1>[@,%a@]@,]" o#dot_expr e1 o#expr e2 - | Ast.ExSnd (_, e, s) -> - pp f "@[<2>%a#@,%s@]" o#dot_expr e s - | e -> o#simple_expr f e - method simple_expr = - fun f e -> - let () = o#node f e Ast.loc_of_expr - in - match e with - | Ast.ExNil _ -> () - | Ast.ExSeq (_, e) -> pp f "@[(%a)@]" o#seq e - | Ast.ExApp (_, - (Ast.ExApp (_, - (Ast.ExId (_, (Ast.IdUid (_, "::")))), _)), - _) -> o#expr_list_cons true f e - | Ast.ExTup (_, e) -> pp f "@[<1>(%a)@]" o#expr e - | Ast.ExArr (_, e) -> - pp f "@[<0>@[<2>[|@ %a@]@ |]@]" o#under_semi#expr e - | Ast.ExCoe (_, e, (Ast.TyNil _), t) -> - pp f "@[<2>(%a :>@ %a)@]" o#expr e o#ctyp t - | Ast.ExCoe (_, e, t1, t2) -> - pp f "@[<2>(%a :@ %a :>@ %a)@]" o#expr e o#ctyp t1 - o#ctyp t2 - | Ast.ExTyc (_, e, t) -> - pp f "@[<2>(%a :@ %a)@]" o#expr e o#ctyp t - | Ast.ExAnt (_, s) -> o#anti f s - | Ast.ExFor (_, s, e1, e2, df, 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 - | Ast.ExInt (_, s) -> o#numeric f s "" - | Ast.ExNativeInt (_, s) -> o#numeric f s "n" - | Ast.ExInt64 (_, s) -> o#numeric f s "L" - | Ast.ExInt32 (_, s) -> o#numeric f s "l" - | Ast.ExFlo (_, s) -> o#numeric f s "" - | Ast.ExChr (_, s) -> pp f "'%s'" (ocaml_char s) - | Ast.ExId (_, i) -> o#var_ident f i - | Ast.ExRec (_, b, (Ast.ExNil _)) -> - pp f "@[@[{%a@]@ }@]" o#record_binding b - | Ast.ExRec (_, b, e) -> - pp f "@[@[{@ (%a)@ with%a@]@ }@]" - o#expr e o#record_binding b - | Ast.ExStr (_, s) -> pp f "\"%s\"" s - | Ast.ExWhi (_, e1, e2) -> - pp f "@[<2>while@ %a@ do@ %a@ done@]" o#expr e1 - o#seq e2 - | Ast.ExLab (_, s, (Ast.ExNil _)) -> pp f "~%s" s - | Ast.ExLab (_, s, e) -> - pp f "@[<2>~%s:@ %a@]" s o#dot_expr e - | Ast.ExOlb (_, s, (Ast.ExNil _)) -> pp f "?%s" s - | Ast.ExOlb (_, s, e) -> - pp f "@[<2>?%s:@ %a@]" s o#dot_expr e - | Ast.ExVrn (_, s) -> pp f "`%a" o#var s - | Ast.ExOvr (_, b) -> - pp f "@[@[{<%a@]@ >}@]" o#record_binding - b - | Ast.ExCom (_, e1, e2) -> - pp f "%a,@ %a" o#simple_expr e1 o#simple_expr e2 - | Ast.ExSem (_, e1, e2) -> - pp f "%a;@ %a" o#under_semi#expr e1 o#expr e2 - | Ast.ExPkg (_, (Ast.MeTyc (_, me, mt))) -> - pp f "@[@[(module %a : %a@])@]" - o#module_expr me o#module_type mt - | Ast.ExPkg (_, me) -> - pp f "@[@[(module %a@])@]" o#module_expr - me - | Ast.ExApp (_, _, _) | Ast.ExAcc (_, _, _) | - Ast.ExAre (_, _, _) | Ast.ExSte (_, _, _) | - Ast.ExAss (_, _, _) | Ast.ExSnd (_, _, _) | - Ast.ExFun (_, _) | Ast.ExFUN (_, _, _) | - Ast.ExMat (_, _, _) | Ast.ExTry (_, _, _) | - Ast.ExIfe (_, _, _, _) | Ast.ExLet (_, _, _, _) | - Ast.ExLmd (_, _, _, _) | Ast.ExOpI (_, _, _) | - Ast.ExAsr (_, _) | Ast.ExAsf _ | Ast.ExLaz (_, _) | - Ast.ExNew (_, _) | Ast.ExObj (_, _, _) -> - pp f "(%a)" o#reset#expr e - method direction_flag = - fun f b -> - match b with - | Ast.DiTo -> pp_print_string f "to" - | Ast.DiDownto -> pp_print_string f "downto" - | Ast.DiAnt s -> o#anti f s - method patt = - fun f p -> - let () = o#node f p Ast.loc_of_patt - in - match p with - | Ast.PaAli (_, p1, p2) -> - pp f "@[<1>(%a@ as@ %a)@]" o#patt p1 o#patt p2 - | Ast.PaEq (_, i, p) -> - pp f "@[<2>%a =@ %a@]" o#var_ident i o#patt p - | Ast.PaSem (_, p1, p2) -> - pp f "%a;@ %a" o#patt p1 o#patt p2 - | p -> o#patt1 f p - method patt1 = - fun f -> - function - | Ast.PaOrp (_, p1, p2) -> - pp f "@[<2>%a@ |@ %a@]" o#patt1 p1 o#patt2 p2 - | p -> o#patt2 f p - method patt2 = fun f p -> o#patt3 f p - method patt3 = - fun f -> - function - | Ast.PaRng (_, p1, p2) -> - pp f "@[<2>%a@ ..@ %a@]" o#patt3 p1 o#patt4 p2 - | Ast.PaCom (_, p1, p2) -> - pp f "%a,@ %a" o#patt3 p1 o#patt3 p2 - | p -> o#patt4 f p - method patt4 = - fun f -> - function - | (Ast.PaApp (_, - (Ast.PaApp (_, - (Ast.PaId (_, (Ast.IdUid (_, "::")))), _)), - _) - as p) -> - let (pl, c) = o#mk_patt_list p - in - (match c with - | None -> - pp f "@[<2>[@ %a@]@ ]" (list o#patt ";@ ") pl - | Some x -> - pp f "@[<2>%a@]" (list o#patt5 " ::@ ") - (pl @ [ x ])) - | p -> o#patt5 f p - method patt5 = - fun f -> - function - | (Ast.PaApp (_, - (Ast.PaApp (_, - (Ast.PaId (_, (Ast.IdUid (_, "::")))), _)), - _) - as p) -> o#simple_patt f p - | Ast.PaLaz (_, p) -> - pp f "@[<2>lazy %a@]" o#simple_patt p - | Ast.PaApp (_, x, y) -> - let (a, al) = get_patt_args x [ y ] - in - 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 - | [ Ast.PaTup (_, _) ] -> - 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) - | p -> o#simple_patt f p - method simple_patt = - fun f p -> - let () = o#node f p Ast.loc_of_patt - in - match p with - | Ast.PaNil _ -> () - | Ast.PaId (_, i) -> o#var_ident f i - | Ast.PaAnt (_, s) -> o#anti f s - | Ast.PaAny _ -> pp f "_" - | Ast.PaMod (_, m) -> pp f "(module %s)" m - | Ast.PaTup (_, p) -> pp f "@[<1>(%a)@]" o#patt3 p - | Ast.PaRec (_, p) -> pp f "@[{@ %a@]@ }" o#patt p - | Ast.PaStr (_, s) -> pp f "\"%s\"" s - | Ast.PaTyc (_, p, t) -> - pp f "@[<1>(%a :@ %a)@]" o#patt p o#ctyp t - | Ast.PaNativeInt (_, s) -> o#numeric f s "n" - | Ast.PaInt64 (_, s) -> o#numeric f s "L" - | Ast.PaInt32 (_, s) -> o#numeric f s "l" - | Ast.PaInt (_, s) -> o#numeric f s "" - | Ast.PaFlo (_, s) -> o#numeric f s "" - | Ast.PaChr (_, s) -> pp f "'%s'" (ocaml_char s) - | Ast.PaLab (_, s, (Ast.PaNil _)) -> pp f "~%s" s - | Ast.PaVrn (_, s) -> pp f "`%a" o#var s - | Ast.PaTyp (_, i) -> pp f "@[<2>#%a@]" o#ident i - | Ast.PaArr (_, p) -> pp f "@[<2>[|@ %a@]@ |]" o#patt p - | Ast.PaLab (_, s, p) -> - pp f "@[<2>~%s:@ (%a)@]" s o#patt p - | Ast.PaOlb (_, s, (Ast.PaNil _)) -> pp f "?%s" s - | Ast.PaOlb (_, "", p) -> - pp f "@[<2>?(%a)@]" o#patt_tycon p - | Ast.PaOlb (_, s, p) -> - pp f "@[<2>?%s:@,@[<1>(%a)@]@]" s o#patt_tycon p - | Ast.PaOlbi (_, "", p, e) -> - pp f "@[<2>?(%a =@ %a)@]" o#patt_tycon p o#expr e - | Ast.PaOlbi (_, s, p, e) -> - pp f "@[<2>?%s:@,@[<1>(%a =@ %a)@]@]" s - o#patt_tycon p o#expr e - | (Ast.PaApp (_, _, _) | Ast.PaAli (_, _, _) | - Ast.PaOrp (_, _, _) | Ast.PaRng (_, _, _) | - Ast.PaCom (_, _, _) | Ast.PaSem (_, _, _) | - Ast.PaEq (_, _, _) | Ast.PaLaz (_, _) - as p) -> pp f "@[<1>(%a)@]" o#patt p - method patt_tycon = - fun f -> - function - | Ast.PaTyc (_, p, t) -> - pp f "%a :@ %a" o#patt p o#ctyp t - | p -> o#patt f p - method simple_ctyp = - fun f t -> - let () = o#node f t Ast.loc_of_ctyp - in - match t with - | Ast.TyId (_, i) -> o#ident f i - | Ast.TyAnt (_, s) -> o#anti f s - | Ast.TyAny _ -> pp f "_" - | Ast.TyAnP _ -> pp f "+_" - | Ast.TyAnM _ -> pp f "-_" - | Ast.TyLab (_, s, t) -> - pp f "@[<2>%s:@ %a@]" s o#simple_ctyp t - | Ast.TyOlb (_, s, t) -> - pp f "@[<2>?%s:@ %a@]" s o#simple_ctyp t - | Ast.TyObj (_, (Ast.TyNil _), Ast.RvNil) -> pp f "< >" - | Ast.TyObj (_, (Ast.TyNil _), Ast.RvRowVar) -> - pp f "< .. >" - | Ast.TyObj (_, t, Ast.RvRowVar) -> - pp f "@[<0>@[<2><@ %a;@ ..@]@ >@]" o#ctyp t - | Ast.TyObj (_, t, Ast.RvNil) -> - pp f "@[<0>@[<2><@ %a@]@ >@]" o#ctyp t - | Ast.TyQuo (_, s) -> pp f "'%a" o#var s - | Ast.TyRec (_, t) -> pp f "@[<2>{@ %a@]@ }" o#ctyp t - | Ast.TySum (_, t) -> pp f "@[<0>%a@]" o#sum_type t - | Ast.TyTup (_, t) -> pp f "@[<1>(%a)@]" o#ctyp t - | Ast.TyPkg (_, mt) -> - pp f "@[<2>(module@ %a@])" o#module_type mt - | Ast.TyVrnEq (_, t) -> - pp f "@[<2>[@ %a@]@ ]" o#sum_type t - | Ast.TyVrnInf (_, t) -> - pp f "@[<2>[<@ %a@]@,]" o#sum_type t - | Ast.TyVrnInfSup (_, t1, t2) -> - let (a, al) = get_ctyp_args t2 [] - in - pp f "@[<2>[<@ %a@ >@ %a@]@ ]" o#sum_type t1 - (list o#simple_ctyp "@ ") (a :: al) - | Ast.TyVrnSup (_, t) -> - pp f "@[<2>[>@ %a@]@,]" o#sum_type t - | Ast.TyCls (_, i) -> pp f "@[<2>#%a@]" o#ident i - | Ast.TyVrn (_, s) -> pp f "`%a" o#var s - | Ast.TySta (_, t1, t2) -> - pp f "%a *@ %a" o#simple_ctyp t1 o#simple_ctyp t2 - | Ast.TyNil _ -> assert false - | t -> pp f "@[<1>(%a)@]" o#ctyp t - method ctyp = - fun f t -> - let () = o#node f t Ast.loc_of_ctyp - in - match t with - | Ast.TyAli (_, t1, t2) -> - pp f "@[<2>%a@ as@ %a@]" o#simple_ctyp t1 - o#simple_ctyp t2 - | Ast.TyArr (_, t1, t2) -> - pp f "@[<2>%a@ ->@ %a@]" o#ctyp1 t1 o#ctyp t2 - | Ast.TyQuP (_, s) -> pp f "+'%a" o#var s - | Ast.TyQuM (_, s) -> pp f "-'%a" o#var s - | Ast.TyOr (_, t1, t2) -> - pp f "%a@ | %a" o#ctyp t1 o#ctyp t2 - | Ast.TyCol (_, t1, (Ast.TyMut (_, t2))) -> - pp f "@[mutable@ %a :@ %a@]" o#ctyp t1 o#ctyp t2 - | Ast.TyCol (_, t1, t2) -> - pp f "@[<2>%a :@ %a@]" o#ctyp t1 o#ctyp t2 - | Ast.TySem (_, t1, t2) -> - pp f "%a;@ %a" o#ctyp t1 o#ctyp t2 - | Ast.TyOf (_, t, (Ast.TyNil _)) -> o#ctyp f t - | Ast.TyOf (_, t1, t2) -> - pp f "@[%a@ @[<3>of@ %a@]@]" o#ctyp t1 - o#constructor_type t2 - | Ast.TyOfAmp (_, t1, t2) -> - pp f "@[%a@ @[<3>of &@ %a@]@]" o#ctyp t1 - o#constructor_type t2 - | Ast.TyAnd (_, t1, t2) -> - pp f "%a@ and %a" o#ctyp t1 o#ctyp t2 - | Ast.TyMut (_, t) -> - pp f "@[<2>mutable@ %a@]" o#ctyp t - | Ast.TyAmp (_, t1, t2) -> - pp f "%a@ &@ %a" o#ctyp t1 o#ctyp t2 - | Ast.TyMan (_, t1, t2) -> - pp f "@[<2>%a =@ %a@]" o#simple_ctyp t1 o#ctyp t2 - | Ast.TyDcl (_, tn, tp, te, cl) -> - (pp f "@[<2>%a%a@]" o#type_params tp o#var tn; - (match te with - | Ast.TyNil _ -> () - | _ -> pp f " =@ %a" o#ctyp te); - if cl <> [] - then pp f "@ %a" (list o#constrain "@ ") cl - else ()) - | t -> o#ctyp1 f t - method ctyp1 = - fun f -> - function - | Ast.TyApp (_, t1, t2) -> - (match get_ctyp_args t1 [ t2 ] with - | (_, [ _ ]) -> - pp f "@[<2>%a@ %a@]" o#simple_ctyp t2 - o#simple_ctyp t1 - | (a, al) -> - pp f "@[<2>(%a)@ %a@]" (list o#ctyp ",@ ") al - o#simple_ctyp a) - | Ast.TyPol (_, t1, t2) -> - let (a, al) = get_ctyp_args t1 [] - in - pp f "@[<2>%a.@ %a@]" (list o#ctyp "@ ") (a :: al) - o#ctyp t2 - | Ast.TyTypePol ((_, t1, t2)) -> - let (a, al) = get_ctyp_args t1 [] - in - pp f "@[<2>type %a.@ %a@]" (list o#ctyp "@ ") - (a :: al) o#ctyp t2 - | Ast.TyPrv (_, t) -> - pp f "@[private@ %a@]" o#simple_ctyp t - | t -> o#simple_ctyp f t - method constructor_type = - fun f t -> - match t with - | Ast.TyAnd (loc, t1, t2) -> - let () = o#node f t (fun _ -> loc) - in - pp f "%a@ * %a" o#constructor_type t1 - o#constructor_type t2 - | Ast.TyArr (_, _, _) -> pp f "(%a)" o#ctyp t - | t -> o#ctyp f t - method sig_item = - fun f sg -> - let () = o#node f sg Ast.loc_of_sig_item - in - match sg with - | Ast.SgNil _ -> () - | Ast.SgSem (_, sg, (Ast.SgNil _)) | - Ast.SgSem (_, (Ast.SgNil _), sg) -> o#sig_item f sg - | Ast.SgSem (_, sg1, sg2) -> - (o#sig_item f sg1; cut f; o#sig_item f sg2) - | Ast.SgExc (_, t) -> - pp f "@[<2>exception@ %a%(%)@]" o#ctyp t semisep - | Ast.SgExt (_, s, t, sl) -> - pp f "@[<2>external@ %a :@ %a =@ %a%(%)@]" - o#var s o#ctyp t (meta_list o#quoted_string "@ ") - sl semisep - | Ast.SgMod (_, s1, (Ast.MtFun (_, s2, mt1, mt2))) -> - let rec loop accu = - (function - | Ast.MtFun (_, s, mt1, mt2) -> - 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%(%)@]" - o#var s1 o#functor_args al o#module_type mt - semisep - | Ast.SgMod (_, s, mt) -> - pp f "@[<2>module %a :@ %a%(%)@]" o#var s - o#module_type mt semisep - | Ast.SgMty (_, s, (Ast.MtNil _)) -> - pp f "@[<2>module type %a%(%)@]" o#var s semisep - | Ast.SgMty (_, s, mt) -> - pp f "@[<2>module type %a =@ %a%(%)@]" o#var s - o#module_type mt semisep - | Ast.SgOpn (_, sl) -> - pp f "@[<2>open@ %a%(%)@]" o#ident sl semisep - | Ast.SgTyp (_, t) -> - pp f "@[@[type %a@]%(%)@]" o#ctyp t - semisep - | Ast.SgVal (_, s, t) -> - pp f "@[<2>%s %a :@ %a%(%)@]" o#value_val o#var s - o#ctyp t semisep - | Ast.SgInc (_, mt) -> - pp f "@[<2>include@ %a%(%)@]" o#module_type mt - semisep - | Ast.SgClt (_, ct) -> - pp f "@[<2>class type %a%(%)@]" o#class_type ct - semisep - | Ast.SgCls (_, ce) -> - pp f "@[<2>class %a%(%)@]" o#class_type ce semisep - | Ast.SgRecMod (_, mb) -> - pp f "@[<2>module rec %a%(%)@]" - o#module_rec_binding mb semisep - | Ast.SgDir (_, _, _) -> () - | Ast.SgAnt (_, s) -> pp f "%a%(%)" o#anti s semisep - method str_item = - fun f st -> - let () = o#node f st Ast.loc_of_str_item - in - match st with - | Ast.StNil _ -> () - | Ast.StSem (_, st, (Ast.StNil _)) | - Ast.StSem (_, (Ast.StNil _), st) -> o#str_item f st - | Ast.StSem (_, st1, st2) -> - (o#str_item f st1; cut f; o#str_item f st2) - | Ast.StExc (_, t, Ast.ONone) -> - pp f "@[<2>exception@ %a%(%)@]" o#ctyp t semisep - | Ast.StExc (_, t, (Ast.OSome sl)) -> - pp f "@[<2>exception@ %a =@ %a%(%)@]" o#ctyp t - o#ident sl semisep - | Ast.StExt (_, s, t, sl) -> - pp f "@[<2>external@ %a :@ %a =@ %a%(%)@]" - o#var s o#ctyp t (meta_list o#quoted_string "@ ") - sl semisep - | Ast.StMod (_, s1, (Ast.MeFun (_, 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%(%)@]" - 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%(%)@]" - o#var s1 o#functor_args al o#module_expr me - semisep) - | Ast.StMod (_, s, (Ast.MeTyc (_, me, mt))) -> - pp f "@[<2>module %a :@ %a =@ %a%(%)@]" o#var s - o#module_type mt o#module_expr me semisep - | Ast.StMod (_, s, me) -> - pp f "@[<2>module %a =@ %a%(%)@]" o#var s - o#module_expr me semisep - | Ast.StMty (_, s, mt) -> - pp f "@[<2>module type %a =@ %a%(%)@]" o#var s - o#module_type mt semisep - | Ast.StOpn (_, sl) -> - pp f "@[<2>open@ %a%(%)@]" o#ident sl semisep - | Ast.StTyp (_, t) -> - pp f "@[@[type %a@]%(%)@]" o#ctyp t - semisep - | Ast.StVal (_, r, bi) -> - pp f "@[<2>%s %a%a%(%)@]" o#value_let o#rec_flag r - o#binding bi semisep - | Ast.StExp (_, e) -> - pp f "@[<2>let _ =@ %a%(%)@]" o#expr e semisep - | Ast.StInc (_, me) -> - pp f "@[<2>include@ %a%(%)@]" o#simple_module_expr - me semisep - | Ast.StClt (_, ct) -> - pp f "@[<2>class type %a%(%)@]" o#class_type ct - semisep - | Ast.StCls (_, ce) -> - pp f "@[class %a%(%)@]" o#class_declaration ce - semisep - | Ast.StRecMod (_, mb) -> - pp f "@[<2>module rec %a%(%)@]" - o#module_rec_binding mb semisep - | Ast.StDir (_, _, _) -> () - | Ast.StAnt (_, s) -> pp f "%a%(%)" o#anti s semisep - | Ast.StExc (_, _, (Ast.OAnt _)) -> assert false - method module_type = - fun f mt -> - let () = o#node f mt Ast.loc_of_module_type - in - match mt with - | Ast.MtNil _ -> assert false - | Ast.MtOf (_, me) -> - pp f "@[<2>module type of@ %a@]" o#module_expr me - | Ast.MtId (_, i) -> o#ident f i - | Ast.MtAnt (_, s) -> o#anti f s - | Ast.MtFun (_, s, mt1, mt2) -> - pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" - o#var s o#module_type mt1 o#module_type mt2 - | Ast.MtQuo (_, s) -> pp f "'%a" o#var s - | Ast.MtSig (_, sg) -> - pp f "@[@[sig@ %a@]@ end@]" o#sig_item sg - | Ast.MtWit (_, mt, wc) -> - pp f "@[<2>%a@ with@ %a@]" o#module_type mt - o#with_constraint wc - method with_constraint = - fun f wc -> - let () = o#node f wc Ast.loc_of_with_constr - in - match wc with - | Ast.WcNil _ -> () - | Ast.WcTyp (_, t1, t2) -> - pp f "@[<2>type@ %a =@ %a@]" o#ctyp t1 o#ctyp t2 - | Ast.WcMod (_, i1, i2) -> - pp f "@[<2>module@ %a =@ %a@]" o#ident i1 o#ident - i2 - | Ast.WcTyS (_, t1, t2) -> - pp f "@[<2>type@ %a :=@ %a@]" o#ctyp t1 o#ctyp t2 - | Ast.WcMoS (_, i1, i2) -> - pp f "@[<2>module@ %a :=@ %a@]" o#ident i1 - o#ident i2 - | Ast.WcAnd (_, wc1, wc2) -> - (o#with_constraint f wc1; - pp f o#andsep; - o#with_constraint f wc2) - | Ast.WcAnt (_, s) -> o#anti f s - method module_expr = - fun f me -> - let () = o#node f me Ast.loc_of_module_expr - in - match me with - | Ast.MeNil _ -> assert false - | Ast.MeTyc (_, (Ast.MeStr (_, st)), - (Ast.MtSig (_, sg))) -> - pp f - "@[<2>@[struct@ %a@]@ end :@ @[sig@ %a@]@ end@]" - o#str_item st o#sig_item sg - | _ -> o#simple_module_expr f me - method simple_module_expr = - fun f me -> - let () = o#node f me Ast.loc_of_module_expr - in - match me with - | Ast.MeNil _ -> assert false - | Ast.MeId (_, i) -> o#ident f i - | Ast.MeAnt (_, s) -> o#anti f s - | Ast.MeApp (_, me1, me2) -> - pp f "@[<2>%a@,(%a)@]" o#module_expr me1 - o#module_expr me2 - | Ast.MeFun (_, s, mt, me) -> - pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" - o#var s o#module_type mt o#module_expr me - | Ast.MeStr (_, st) -> - pp f "@[@[struct@ %a@]@ end@]" o#str_item - st - | Ast.MeTyc (_, me, mt) -> - pp f "@[<1>(%a :@ %a)@]" o#module_expr me - o#module_type mt - | Ast.MePkg (_, - (Ast.ExTyc (_, e, (Ast.TyPkg (_, mt))))) -> - pp f "@[<1>(%s %a :@ %a)@]" o#value_val o#expr e - o#module_type mt - | Ast.MePkg (_, e) -> - pp f "@[<1>(%s %a)@]" o#value_val o#expr e - method class_expr = - fun f ce -> - let () = o#node f ce Ast.loc_of_class_expr - in - match ce with - | Ast.CeApp (_, ce, e) -> - pp f "@[<2>%a@ %a@]" o#class_expr ce o#apply_expr e - | Ast.CeCon (_, Ast.ViNil, i, (Ast.TyNil _)) -> - pp f "@[<2>%a@]" o#ident i - | Ast.CeCon (_, Ast.ViNil, i, t) -> - pp f "@[<2>@[<1>[%a]@]@ %a@]" o#class_params t - o#ident i - | Ast.CeCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), - (Ast.TyNil _)) -> pp f "@[<2>virtual@ %a@]" o#var i - | Ast.CeCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), t) - -> - pp f "@[<2>virtual@ @[<1>[%a]@]@ %a@]" - o#class_params t o#var i - | Ast.CeFun (_, p, ce) -> - pp f "@[<2>fun@ %a@ ->@ %a@]" o#simple_patt p - o#class_expr ce - | Ast.CeLet (_, r, bi, ce) -> - pp f "@[<2>let %a%a@]@ @[<2>in@ %a@]" o#rec_flag r - o#binding bi o#class_expr ce - | Ast.CeStr (_, (Ast.PaNil _), cst) -> - pp f "@[@[object %a@]@ end@]" - o#class_str_item cst - | Ast.CeStr (_, p, cst) -> - pp f - "@[@[object @[<1>(%a)@]@ %a@]@ end@]" - o#patt p o#class_str_item cst - | Ast.CeTyc (_, ce, ct) -> - pp f "@[<1>(%a :@ %a)@]" o#class_expr ce - o#class_type ct - | Ast.CeAnt (_, s) -> o#anti f s - | Ast.CeAnd (_, ce1, ce2) -> - (o#class_expr f ce1; - pp f o#andsep; - o#class_expr f ce2) - | Ast.CeEq (_, ce1, (Ast.CeFun (_, p, ce2))) when - is_irrefut_patt p -> - pp f "@[<2>%a@ %a" o#class_expr ce1 - o#patt_class_expr_fun_args (p, ce2) - | Ast.CeEq (_, ce1, ce2) -> - pp f "@[<2>%a =@]@ %a" o#class_expr ce1 - o#class_expr ce2 - | _ -> assert false - method class_type = - fun f ct -> - let () = o#node f ct Ast.loc_of_class_type - in - match ct with - | Ast.CtCon (_, Ast.ViNil, i, (Ast.TyNil _)) -> - pp f "@[<2>%a@]" o#ident i - | Ast.CtCon (_, Ast.ViNil, i, t) -> - pp f "@[<2>[@,%a@]@,]@ %a" o#class_params t - o#ident i - | Ast.CtCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), - (Ast.TyNil _)) -> pp f "@[<2>virtual@ %a@]" o#var i - | Ast.CtCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), t) - -> - pp f "@[<2>virtual@ [@,%a@]@,]@ %a" o#class_params - t o#var i - | Ast.CtFun (_, t, ct) -> - pp f "@[<2>%a@ ->@ %a@]" o#simple_ctyp t - o#class_type ct - | Ast.CtSig (_, (Ast.TyNil _), csg) -> - pp f "@[@[object@ %a@]@ end@]" - o#class_sig_item csg - | Ast.CtSig (_, t, csg) -> - pp f - "@[@[object @[<1>(%a)@]@ %a@]@ end@]" - o#ctyp t o#class_sig_item csg - | Ast.CtAnt (_, s) -> o#anti f s - | Ast.CtAnd (_, ct1, ct2) -> - (o#class_type f ct1; - pp f o#andsep; - o#class_type f ct2) - | Ast.CtCol (_, ct1, ct2) -> - pp f "%a :@ %a" o#class_type ct1 o#class_type ct2 - | Ast.CtEq (_, ct1, ct2) -> - pp f "%a =@ %a" o#class_type ct1 o#class_type ct2 - | _ -> assert false - method class_sig_item = - fun f csg -> - let () = o#node f csg Ast.loc_of_class_sig_item - in - match csg with - | Ast.CgNil _ -> () - | Ast.CgSem (_, csg, (Ast.CgNil _)) | - Ast.CgSem (_, (Ast.CgNil _), csg) -> - o#class_sig_item f csg - | Ast.CgSem (_, csg1, csg2) -> - (o#class_sig_item f csg1; - cut f; - o#class_sig_item f csg2) - | Ast.CgCtr (_, t1, t2) -> - pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1 - o#ctyp t2 no_semisep - | Ast.CgInh (_, ct) -> - pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct - no_semisep - | Ast.CgMth (_, s, pr, t) -> - pp f "@[<2>method %a%a :@ %a%(%)@]" o#private_flag - pr o#var s o#ctyp t no_semisep - | Ast.CgVir (_, s, pr, t) -> - pp f "@[<2>method virtual %a%a :@ %a%(%)@]" - o#private_flag pr o#var s o#ctyp t no_semisep - | Ast.CgVal (_, s, mu, vi, t) -> - pp f "@[<2>%s %a%a%a :@ %a%(%)@]" o#value_val - o#mutable_flag mu o#virtual_flag vi o#var s - o#ctyp t no_semisep - | Ast.CgAnt (_, s) -> pp f "%a%(%)" o#anti s no_semisep - method class_str_item = - fun f cst -> - let () = o#node f cst Ast.loc_of_class_str_item - in - match cst with - | Ast.CrNil _ -> () - | Ast.CrSem (_, cst, (Ast.CrNil _)) | - Ast.CrSem (_, (Ast.CrNil _), cst) -> - o#class_str_item f cst - | Ast.CrSem (_, cst1, cst2) -> - (o#class_str_item f cst1; - cut f; - o#class_str_item f cst2) - | Ast.CrCtr (_, t1, t2) -> - pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 - o#ctyp t2 no_semisep - | Ast.CrInh (_, ov, ce, "") -> - pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov - o#class_expr ce no_semisep - | Ast.CrInh (_, ov, ce, s) -> - pp f "@[<2>inherit%a@ %a as@ %a%(%)@]" - o#override_flag ov o#class_expr ce o#var s - no_semisep - | Ast.CrIni (_, e) -> - pp f "@[<2>initializer@ %a%(%)@]" o#expr e - no_semisep - | Ast.CrMth (_, s, ov, pr, e, (Ast.TyNil _)) -> - pp f "@[<2>method%a %a%a =@ %a%(%)@]" - o#override_flag ov o#private_flag pr o#var s - o#expr e no_semisep - | Ast.CrMth (_, s, ov, pr, e, t) -> - pp f "@[<2>method%a %a%a :@ %a =@ %a%(%)@]" - o#override_flag ov o#private_flag pr o#var s - o#ctyp t o#expr e no_semisep - | Ast.CrVir (_, s, pr, t) -> - pp f "@[<2>method virtual@ %a%a :@ %a%(%)@]" - o#private_flag pr o#var s o#ctyp t no_semisep - | Ast.CrVvr (_, s, mu, t) -> - pp f "@[<2>%s virtual %a%a :@ %a%(%)@]" o#value_val - o#mutable_flag mu o#var s o#ctyp t no_semisep - | Ast.CrVal (_, s, ov, mu, e) -> - pp f "@[<2>%s%a %a%a =@ %a%(%)@]" o#value_val - o#override_flag ov o#mutable_flag mu o#var s - o#expr e no_semisep - | Ast.CrAnt (_, s) -> pp f "%a%(%)" o#anti s no_semisep - method implem = - fun f st -> - match st with - | Ast.StExp (_, e) -> - pp f "@[<0>%a%(%)@]@." o#expr e semisep - | st -> pp f "@[%a@]@." o#str_item st - method interf = fun f sg -> pp f "@[%a@]@." o#sig_item sg - end - - let with_outfile output_file fct arg = - let call close f = - ((try fct f arg with | exn -> (close (); raise exn)); - close ()) - in - match output_file with - | None -> call (fun () -> ()) std_formatter - | Some s -> - let oc = open_out s in - let f = formatter_of_out_channel oc - in call (fun () -> close_out oc) f - - let print output_file fct = - let o = new printer () in with_outfile output_file (fct o) - - let print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg - - let print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st - - end - - module MakeMore (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax. - Ast).S = - struct - include Make(Syntax) - - let semisep : sep ref = ref ("@\n" : sep) - - let margin = ref 78 - - let comments = ref true - - let locations = ref false - - let curry_constr = ref false - - let print output_file fct = - let o = - new printer ~comments: !comments ~curry_constr: !curry_constr - () in - let o = o#set_semisep !semisep in - let o = if !locations then o#set_loc_and_comments else o - in - with_outfile output_file - (fun f -> - let () = Format.pp_set_margin f !margin - in Format.fprintf f "@[%a@]@." (fct o)) - - let print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg - - let print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st - - let 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) - - let _ = - Options.add "-l" (Arg.Int (fun i -> margin := i)) - " line length for pretty printing." - - let _ = - Options.add "-ss" (Arg.Unit (fun () -> semisep := ";;")) - " Print double semicolons." - - let _ = - Options.add "-no_ss" (Arg.Unit (fun () -> semisep := "")) - " Do not print double semicolons (default)." - - let _ = - Options.add "-sep" - (Arg.String (fun s -> semisep := check_sep s)) - " Use this string between phrases." - - let _ = - Options.add "-curry-constr" (Arg.Set curry_constr) - "Use currified constructors." - - let _ = - Options.add "-no_comments" (Arg.Clear comments) - "Do not add comments." - - let _ = - Options.add "-add_locations" (Arg.Set locations) - "Add locations as comment." - - end - - end - - module OCamlr : - sig - module Id : Sig.Id - - module Make (Syntax : Sig.Camlp4Syntax) : - sig - open Format - - include Sig.Camlp4Syntax with module Loc = Syntax.Loc - and module Token = Syntax.Token and module Ast = Syntax.Ast - and module Gram = Syntax.Gram - - class printer : - ?curry_constr: bool -> - ?comments: bool -> - unit -> object ('a) inherit OCaml.Make(Syntax).printer end - - val with_outfile : - string option -> (formatter -> 'a -> unit) -> 'a -> unit - - val print : - string option -> - (printer -> formatter -> 'a -> unit) -> 'a -> unit - - end - - module MakeMore (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax. - Ast).S - - end = - struct - open Format - - module Id = - struct - let name = "Camlp4.Printers.OCamlr" - - let version = Sys.ocaml_version - - end - - module Make (Syntax : Sig.Camlp4Syntax) = - struct - include Syntax - - open Sig - - module PP_o = OCaml.Make(Syntax) - - open PP_o - - let pp = fprintf - - let is_keyword = - let keywords = [ "where" ] - and not_keywords = [ "false"; "function"; "true"; "val" ] - in - fun s -> - (not (List.mem s not_keywords)) && - ((is_keyword s) || (List.mem s keywords)) - - class printer ?curry_constr:(init_curry_constr = true) - ?(comments = true) () = - object (o) - inherit - PP_o.printer ~curry_constr: init_curry_constr ~comments () as - super - val! semisep = (";" : sep) - val! no_semisep = (";" : sep) - val mode = if comments then `comments else `no_comments - val curry_constr = init_curry_constr - val first_match_case = true - method andsep : sep = "@]@ @[<2>and@ " - method value_val = "value" - method value_let = "value" - method under_pipe = o - method under_semi = o - method reset_semi = o - method reset = o - method private unset_first_match_case = - {< first_match_case = false; >} - method private set_first_match_case = - {< first_match_case = true; >} - method seq = - fun f e -> - let rec self right f e = - let go_right = self right - and go_left = self false - in - match e with - | Ast.ExLet (_, r, bi, e1) -> - if right - then - pp f "@[<2>let %a%a@];@ %a" o#rec_flag r - o#binding bi go_right e1 - else pp f "(%a)" o#expr e - | Ast.ExSeq (_, e) -> go_right f e - | Ast.ExSem (_, e1, e2) -> - (pp f "%a;@ " go_left e1; - (match (right, e2) with - | (true, Ast.ExLet (_, r, bi, e3)) -> - pp f "@[<2>let %a%a@];@ %a" o#rec_flag r - o#binding bi go_right e3 - | _ -> go_right f e2)) - | e -> o#expr f e - in self true f e - method var = - fun f -> - function - | "" -> pp f "$lid:\"\"$" - | "[]" -> pp f "[]" - | "()" -> pp f "()" - | " True" -> pp f "True" - | " False" -> pp f "False" - | v -> - (match lex_string v with - | LIDENT s | UIDENT s | ESCAPED_IDENT s when - is_keyword s -> pp f "%s__" s - | SYMBOL s -> pp f "( %s )" s - | LIDENT s | UIDENT s | ESCAPED_IDENT s -> - pp_print_string f s - | tok -> - failwith - (sprintf "Bad token used as an identifier: %s" - (Token.to_string tok))) - method type_params = - fun f -> - function - | [] -> () - | [ x ] -> pp f "@ %a" o#ctyp x - | l -> pp f "@ @[<1>%a@]" (list o#ctyp "@ ") l - method match_case = - fun f -> - function - | Ast.McNil _ -> pp f "@ []" - | m -> - pp f "@ [ %a ]" o#set_first_match_case#match_case_aux - m - method match_case_aux = - fun f -> - function - | Ast.McNil _ -> () - | Ast.McAnt (_, s) -> o#anti f s - | Ast.McOr (_, a1, a2) -> - pp f "%a%a" o#match_case_aux a1 - o#unset_first_match_case#match_case_aux a2 - | Ast.McArr (_, p, (Ast.ExNil _), e) -> - let () = if first_match_case then () else pp f "@ | " - in - pp f "@[<2>%a@ ->@ %a@]" o#patt p o#under_pipe#expr - e - | Ast.McArr (_, p, w, e) -> - let () = if first_match_case then () else pp f "@ | " - in - pp f "@[<2>%a@ when@ %a@ ->@ %a@]" o#patt p - o#under_pipe#expr w o#under_pipe#expr e - method sum_type = - fun f -> - function - | Ast.TyNil _ -> pp f "[]" - | t -> pp f "@[[ %a ]@]" o#ctyp t - method ident = - fun f i -> - let () = o#node f i Ast.loc_of_ident - in - match i with - | Ast.IdApp (_, i1, i2) -> - pp f "%a@ %a" o#dot_ident i1 o#dot_ident i2 - | i -> o#dot_ident f i - method private dot_ident = - fun f i -> - let () = o#node f i Ast.loc_of_ident - in - match i with - | Ast.IdAcc (_, i1, i2) -> - pp f "%a.@,%a" o#dot_ident i1 o#dot_ident i2 - | Ast.IdAnt (_, s) -> o#anti f s - | Ast.IdLid (_, s) | Ast.IdUid (_, s) -> o#var f s - | i -> pp f "(%a)" o#ident i - method patt4 = - fun f -> - function - | (Ast.PaApp (_, - (Ast.PaApp (_, - (Ast.PaId (_, (Ast.IdUid (_, "::")))), _)), - _) - as p) -> - let (pl, c) = o#mk_patt_list p - in - (match c with - | None -> - pp f "@[<2>[@ %a@]@ ]" (list o#patt ";@ ") pl - | Some x -> - pp f "@[<2>[ %a ::@ %a ]@]" - (list o#patt ";@ ") pl o#patt x) - | p -> super#patt4 f p - method expr_list_cons = - fun _ f e -> - let (el, c) = o#mk_expr_list e - in - match c with - | None -> o#expr_list f el - | Some x -> - pp f "@[<2>[ %a ::@ %a ]@]" (list o#expr ";@ ") el - o#expr x - method expr = - fun f e -> - let () = o#node f e Ast.loc_of_expr - in - match e with - | Ast.ExAss (_, e1, e2) -> - pp f "@[<2>%a@ :=@ %a@]" o#dot_expr e1 o#expr e2 - | Ast.ExFun (_, (Ast.McArr (_, p, (Ast.ExNil _), e))) - when Ast.is_irrefut_patt p -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args - ((`patt p), e) - | Ast.ExFUN (_, i, e) -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args - ((`newtype i), e) - | Ast.ExFun (_, a) -> - pp f "@[fun%a@]" o#match_case a - | Ast.ExAsf _ -> pp f "@[<2>assert@ False@]" - | e -> super#expr f e - method dot_expr = - fun f e -> - let () = o#node f e Ast.loc_of_expr - in - match e with - | Ast.ExAcc (_, e, - (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> - pp f "@[<2>%a.@,val@]" o#simple_expr e - | e -> super#dot_expr f e - method ctyp = - fun f t -> - let () = o#node f t Ast.loc_of_ctyp - in - match t with - | Ast.TyDcl (_, tn, tp, te, cl) -> - (pp f "@[<2>%a%a@]" o#var tn o#type_params tp; - (match te with - | Ast.TyNil _ -> () - | _ -> pp f " =@ %a" o#ctyp te); - if cl <> [] - then pp f "@ %a" (list o#constrain "@ ") cl - else ()) - | Ast.TyCol (_, t1, (Ast.TyMut (_, t2))) -> - pp f "@[%a :@ mutable %a@]" o#ctyp t1 o#ctyp t2 - | Ast.TyMan (_, t1, t2) -> - pp f "@[<2>%a ==@ %a@]" o#simple_ctyp t1 o#ctyp t2 - | t -> super#ctyp f t - method simple_ctyp = - fun f t -> - let () = o#node f t Ast.loc_of_ctyp - in - match t with - | Ast.TyVrnEq (_, t) -> - pp f "@[<2>[ =@ %a@]@ ]" o#ctyp t - | Ast.TyVrnInf (_, t) -> - pp f "@[<2>[ <@ %a@]@,]" o#ctyp t - | Ast.TyVrnInfSup (_, t1, t2) -> - pp f "@[<2>[ <@ %a@ >@ %a@]@ ]" o#ctyp t1 o#ctyp t2 - | Ast.TyVrnSup (_, t) -> - pp f "@[<2>[ >@ %a@]@,]" o#ctyp t - | Ast.TyMan (_, t1, t2) -> - pp f "@[<2>%a@ ==@ %a@]" o#simple_ctyp t1 - o#simple_ctyp t2 - | Ast.TyLab (_, s, t) -> - pp f "@[<2>~%s:@ %a@]" s o#simple_ctyp t - | t -> super#simple_ctyp f t - method ctyp1 = - fun f -> - function - | Ast.TyApp (_, t1, t2) -> - (match get_ctyp_args t1 [ t2 ] with - | (_, [ _ ]) -> - pp f "@[<2>%a@ %a@]" o#simple_ctyp t1 - o#simple_ctyp t2 - | (a, al) -> - pp f "@[<2>%a@]" (list o#simple_ctyp "@ ") - (a :: al)) - | Ast.TyPol (_, t1, t2) -> - let (a, al) = get_ctyp_args t1 [] - in - pp f "@[<2>! %a.@ %a@]" (list o#ctyp "@ ") - (a :: al) o#ctyp t2 - | t -> super#ctyp1 f t - method constructor_type = - fun f t -> - match t with - | Ast.TyAnd (loc, t1, t2) -> - let () = o#node f t (fun _ -> loc) - in - pp f "%a@ and %a" o#constructor_type t1 - o#constructor_type t2 - | t -> o#ctyp f t - method str_item = - fun f st -> - match st with - | Ast.StExp (_, e) -> - pp f "@[<2>%a%(%)@]" o#expr e semisep - | st -> super#str_item f st - method module_expr = - fun f me -> - let () = o#node f me Ast.loc_of_module_expr - in - match me with - | Ast.MeApp (_, me1, me2) -> - pp f "@[<2>%a@ %a@]" o#module_expr me1 - o#simple_module_expr me2 - | me -> super#module_expr f me - method simple_module_expr = - fun f me -> - let () = o#node f me Ast.loc_of_module_expr - in - match me with - | Ast.MeApp (_, _, _) -> pp f "(%a)" o#module_expr me - | _ -> super#simple_module_expr f me - method implem = fun f st -> pp f "@[%a@]@." o#str_item st - method class_type = - fun f ct -> - let () = o#node f ct Ast.loc_of_class_type - in - match ct with - | Ast.CtFun (_, t, ct) -> - pp f "@[<2>[ %a ] ->@ %a@]" o#simple_ctyp t - o#class_type ct - | Ast.CtCon (_, Ast.ViNil, i, (Ast.TyNil _)) -> - pp f "@[<2>%a@]" o#ident i - | Ast.CtCon (_, Ast.ViNil, i, t) -> - pp f "@[<2>%a [@,%a@]@,]" o#ident i o#class_params - t - | Ast.CtCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), - (Ast.TyNil _)) -> pp f "@[<2>virtual@ %a@]" o#var i - | Ast.CtCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), t) - -> - pp f "@[<2>virtual@ %a@ [@,%a@]@,]" o#var i - o#class_params t - | ct -> super#class_type f ct - method class_expr = - fun f ce -> - let () = o#node f ce Ast.loc_of_class_expr - in - match ce with - | Ast.CeCon (_, Ast.ViNil, i, (Ast.TyNil _)) -> - pp f "@[<2>%a@]" o#ident i - | Ast.CeCon (_, Ast.ViNil, i, t) -> - pp f "@[<2>%a@ @[<1>[%a]@]@]" o#ident i - o#class_params t - | Ast.CeCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), - (Ast.TyNil _)) -> pp f "@[<2>virtual@ %a@]" o#var i - | Ast.CeCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), t) - -> - pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#var i - o#class_params t - | ce -> super#class_expr f ce - end - - let with_outfile = with_outfile - - let print output_file fct = - let o = new printer () in with_outfile output_file (fct o) - - let print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg - - let print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st - - end - - module MakeMore (Syntax : Sig.Camlp4Syntax) : Sig.Printer(Syntax. - Ast).S = - struct - include Make(Syntax) - - let margin = ref 78 - - let comments = ref true - - let locations = ref false - - let curry_constr = ref true - - let print output_file fct = - let o = - new printer ~comments: !comments ~curry_constr: !curry_constr - () in - let o = if !locations then o#set_loc_and_comments else o - in - with_outfile output_file - (fun f -> - let () = Format.pp_set_margin f !margin - in Format.fprintf f "@[%a@]@." (fct o)) - - let print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg - - let print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st - - let _ = - Options.add "-l" (Arg.Int (fun i -> margin := i)) - " line length for pretty printing." - - let _ = - Options.add "-no_comments" (Arg.Clear comments) - "Do not add comments." - - let _ = - Options.add "-add_locations" (Arg.Set locations) - "Add locations as comment." - - end - - end - - end - -module OCamlInitSyntax = - struct - module Make - (Ast : Sig.Camlp4Ast) - (Gram : - Sig.Grammar.Static with module Loc = Ast.Loc with - type Token.t = Sig.camlp4_token) - (Quotation : Sig.Quotation with module Ast = Sig.Camlp4AstToAst(Ast)) : - Sig.Camlp4Syntax with module Loc = Ast.Loc and module Ast = Ast - and module Token = Gram.Token and module Gram = Gram - and module Quotation = Quotation = - struct - module Loc = Ast.Loc - - module Ast = Ast - - module Gram = Gram - - module Token = Gram.Token - - open Sig - - type warning = Loc.t -> string -> unit - - let default_warning loc txt = - Format.eprintf " %a: %s@." Loc.print loc txt - - let current_warning = ref default_warning - - let print_warning loc txt = !current_warning loc txt - - let a_CHAR = Gram.Entry.mk "a_CHAR" - - let a_FLOAT = Gram.Entry.mk "a_FLOAT" - - let a_INT = Gram.Entry.mk "a_INT" - - let a_INT32 = Gram.Entry.mk "a_INT32" - - let a_INT64 = Gram.Entry.mk "a_INT64" - - let a_LABEL = Gram.Entry.mk "a_LABEL" - - let a_LIDENT = Gram.Entry.mk "a_LIDENT" - - let a_NATIVEINT = Gram.Entry.mk "a_NATIVEINT" - - let a_OPTLABEL = Gram.Entry.mk "a_OPTLABEL" - - let a_STRING = Gram.Entry.mk "a_STRING" - - let a_UIDENT = Gram.Entry.mk "a_UIDENT" - - let a_ident = Gram.Entry.mk "a_ident" - - let amp_ctyp = Gram.Entry.mk "amp_ctyp" - - let and_ctyp = Gram.Entry.mk "and_ctyp" - - let match_case = Gram.Entry.mk "match_case" - - let match_case0 = Gram.Entry.mk "match_case0" - - let binding = Gram.Entry.mk "binding" - - let class_declaration = Gram.Entry.mk "class_declaration" - - let class_description = Gram.Entry.mk "class_description" - - let class_expr = Gram.Entry.mk "class_expr" - - let class_fun_binding = Gram.Entry.mk "class_fun_binding" - - let class_fun_def = Gram.Entry.mk "class_fun_def" - - let class_info_for_class_expr = - Gram.Entry.mk "class_info_for_class_expr" - - let class_info_for_class_type = - Gram.Entry.mk "class_info_for_class_type" - - let class_longident = Gram.Entry.mk "class_longident" - - let class_longident_and_param = - Gram.Entry.mk "class_longident_and_param" - - let class_name_and_param = Gram.Entry.mk "class_name_and_param" - - let class_sig_item = Gram.Entry.mk "class_sig_item" - - let class_signature = Gram.Entry.mk "class_signature" - - let class_str_item = Gram.Entry.mk "class_str_item" - - let class_structure = Gram.Entry.mk "class_structure" - - let class_type = Gram.Entry.mk "class_type" - - let class_type_declaration = Gram.Entry.mk "class_type_declaration" - - let class_type_longident = Gram.Entry.mk "class_type_longident" - - let class_type_longident_and_param = - Gram.Entry.mk "class_type_longident_and_param" - - let class_type_plus = Gram.Entry.mk "class_type_plus" - - let comma_ctyp = Gram.Entry.mk "comma_ctyp" - - let comma_expr = Gram.Entry.mk "comma_expr" - - let comma_ipatt = Gram.Entry.mk "comma_ipatt" - - let comma_patt = Gram.Entry.mk "comma_patt" - - let comma_type_parameter = Gram.Entry.mk "comma_type_parameter" - - let constrain = Gram.Entry.mk "constrain" - - let constructor_arg_list = Gram.Entry.mk "constructor_arg_list" - - let constructor_declaration = Gram.Entry.mk "constructor_declaration" - - let constructor_declarations = - Gram.Entry.mk "constructor_declarations" - - let ctyp = Gram.Entry.mk "ctyp" - - let cvalue_binding = Gram.Entry.mk "cvalue_binding" - - let direction_flag = Gram.Entry.mk "direction_flag" - - let direction_flag_quot = Gram.Entry.mk "direction_flag_quot" - - let dummy = Gram.Entry.mk "dummy" - - let entry_eoi = Gram.Entry.mk "entry_eoi" - - let eq_expr = Gram.Entry.mk "eq_expr" - - let expr = Gram.Entry.mk "expr" - - let expr_eoi = Gram.Entry.mk "expr_eoi" - - let field_expr = Gram.Entry.mk "field_expr" - - let field_expr_list = Gram.Entry.mk "field_expr_list" - - let fun_binding = Gram.Entry.mk "fun_binding" - - let fun_def = Gram.Entry.mk "fun_def" - - let ident = Gram.Entry.mk "ident" - - let implem = Gram.Entry.mk "implem" - - let interf = Gram.Entry.mk "interf" - - let ipatt = Gram.Entry.mk "ipatt" - - let ipatt_tcon = Gram.Entry.mk "ipatt_tcon" - - let label = Gram.Entry.mk "label" - - let label_declaration = Gram.Entry.mk "label_declaration" - - let label_declaration_list = Gram.Entry.mk "label_declaration_list" - - let label_expr = Gram.Entry.mk "label_expr" - - let label_expr_list = Gram.Entry.mk "label_expr_list" - - let label_ipatt = Gram.Entry.mk "label_ipatt" - - let label_ipatt_list = Gram.Entry.mk "label_ipatt_list" - - let label_longident = Gram.Entry.mk "label_longident" - - let label_patt = Gram.Entry.mk "label_patt" - - let label_patt_list = Gram.Entry.mk "label_patt_list" - - let labeled_ipatt = Gram.Entry.mk "labeled_ipatt" - - let let_binding = Gram.Entry.mk "let_binding" - - let meth_list = Gram.Entry.mk "meth_list" - - let meth_decl = Gram.Entry.mk "meth_decl" - - let module_binding = Gram.Entry.mk "module_binding" - - let module_binding0 = Gram.Entry.mk "module_binding0" - - let module_declaration = Gram.Entry.mk "module_declaration" - - let module_expr = Gram.Entry.mk "module_expr" - - let module_longident = Gram.Entry.mk "module_longident" - - let module_longident_with_app = - Gram.Entry.mk "module_longident_with_app" - - let module_rec_declaration = Gram.Entry.mk "module_rec_declaration" - - let module_type = Gram.Entry.mk "module_type" - - let package_type = Gram.Entry.mk "package_type" - - let more_ctyp = Gram.Entry.mk "more_ctyp" - - let name_tags = Gram.Entry.mk "name_tags" - - let opt_as_lident = Gram.Entry.mk "opt_as_lident" - - let opt_class_self_patt = Gram.Entry.mk "opt_class_self_patt" - - let opt_class_self_type = Gram.Entry.mk "opt_class_self_type" - - let opt_class_signature = Gram.Entry.mk "opt_class_signature" - - let opt_class_structure = Gram.Entry.mk "opt_class_structure" - - let opt_comma_ctyp = Gram.Entry.mk "opt_comma_ctyp" - - let opt_dot_dot = Gram.Entry.mk "opt_dot_dot" - - let row_var_flag_quot = Gram.Entry.mk "row_var_flag_quot" - - let opt_eq_ctyp = Gram.Entry.mk "opt_eq_ctyp" - - let opt_expr = Gram.Entry.mk "opt_expr" - - let opt_meth_list = Gram.Entry.mk "opt_meth_list" - - let opt_mutable = Gram.Entry.mk "opt_mutable" - - let mutable_flag_quot = Gram.Entry.mk "mutable_flag_quot" - - let opt_polyt = Gram.Entry.mk "opt_polyt" - - let opt_private = Gram.Entry.mk "opt_private" - - let private_flag_quot = Gram.Entry.mk "private_flag_quot" - - let opt_rec = Gram.Entry.mk "opt_rec" - - let rec_flag_quot = Gram.Entry.mk "rec_flag_quot" - - let opt_sig_items = Gram.Entry.mk "opt_sig_items" - - let opt_str_items = Gram.Entry.mk "opt_str_items" - - let opt_virtual = Gram.Entry.mk "opt_virtual" - - let virtual_flag_quot = Gram.Entry.mk "virtual_flag_quot" - - let opt_override = Gram.Entry.mk "opt_override" - - let override_flag_quot = Gram.Entry.mk "override_flag_quot" - - let opt_when_expr = Gram.Entry.mk "opt_when_expr" - - let patt = Gram.Entry.mk "patt" - - let patt_as_patt_opt = Gram.Entry.mk "patt_as_patt_opt" - - let patt_eoi = Gram.Entry.mk "patt_eoi" - - let patt_tcon = Gram.Entry.mk "patt_tcon" - - let phrase = Gram.Entry.mk "phrase" - - let poly_type = Gram.Entry.mk "poly_type" - - let row_field = Gram.Entry.mk "row_field" - - let sem_expr = Gram.Entry.mk "sem_expr" - - let sem_expr_for_list = Gram.Entry.mk "sem_expr_for_list" - - let sem_patt = Gram.Entry.mk "sem_patt" - - let sem_patt_for_list = Gram.Entry.mk "sem_patt_for_list" - - let semi = Gram.Entry.mk "semi" - - let sequence = Gram.Entry.mk "sequence" - - let do_sequence = Gram.Entry.mk "do_sequence" - - let sig_item = Gram.Entry.mk "sig_item" - - let sig_items = Gram.Entry.mk "sig_items" - - let star_ctyp = Gram.Entry.mk "star_ctyp" - - let str_item = Gram.Entry.mk "str_item" - - let str_items = Gram.Entry.mk "str_items" - - let top_phrase = Gram.Entry.mk "top_phrase" - - let type_constraint = Gram.Entry.mk "type_constraint" - - let type_declaration = Gram.Entry.mk "type_declaration" - - let type_ident_and_parameters = - Gram.Entry.mk "type_ident_and_parameters" - - let type_kind = Gram.Entry.mk "type_kind" - - let type_longident = Gram.Entry.mk "type_longident" - - let type_longident_and_parameters = - Gram.Entry.mk "type_longident_and_parameters" - - let type_parameter = Gram.Entry.mk "type_parameter" - - let type_parameters = Gram.Entry.mk "type_parameters" - - let typevars = Gram.Entry.mk "typevars" - - let use_file = Gram.Entry.mk "use_file" - - let val_longident = Gram.Entry.mk "val_longident" - - let value_let = Gram.Entry.mk "value_let" - - let value_val = Gram.Entry.mk "value_val" - - let with_constr = Gram.Entry.mk "with_constr" - - let expr_quot = Gram.Entry.mk "quotation of expression" - - let patt_quot = Gram.Entry.mk "quotation of pattern" - - let ctyp_quot = Gram.Entry.mk "quotation of type" - - let str_item_quot = Gram.Entry.mk "quotation of structure item" - - let sig_item_quot = Gram.Entry.mk "quotation of signature item" - - let class_str_item_quot = - Gram.Entry.mk "quotation of class structure item" - - let class_sig_item_quot = - Gram.Entry.mk "quotation of class signature item" - - let module_expr_quot = Gram.Entry.mk "quotation of module expression" - - let module_type_quot = Gram.Entry.mk "quotation of module type" - - let class_type_quot = Gram.Entry.mk "quotation of class type" - - let class_expr_quot = Gram.Entry.mk "quotation of class expression" - - let with_constr_quot = Gram.Entry.mk "quotation of with constraint" - - let binding_quot = Gram.Entry.mk "quotation of binding" - - let rec_binding_quot = Gram.Entry.mk "quotation of record binding" - - let match_case_quot = - Gram.Entry.mk "quotation of match_case (try/match/function case)" - - let module_binding_quot = - Gram.Entry.mk "quotation of module rec binding" - - let ident_quot = Gram.Entry.mk "quotation of identifier" - - let prefixop = - Gram.Entry.mk "prefix operator (start with '!', '?', '~')" - - let infixop0 = - Gram.Entry.mk - "infix operator (level 0) (comparison operators, and some others)" - - let infixop1 = - Gram.Entry.mk "infix operator (level 1) (start with '^', '@')" - - let infixop2 = - Gram.Entry.mk "infix operator (level 2) (start with '+', '-')" - - let infixop3 = - Gram.Entry.mk "infix operator (level 3) (start with '*', '/', '%')" - - let infixop4 = - Gram.Entry.mk - "infix operator (level 4) (start with \"**\") (right assoc)" - - let _ = - Gram.extend (top_phrase : 'top_phrase Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Stoken - (((function | EOI -> true | _ -> false), "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (None : 'top_phrase) - | _ -> assert false))) ]) ])) - ()) - - module AntiquotSyntax = - struct - module Loc = Ast.Loc - - module Ast = Sig.Camlp4AstToAst(Ast) - - module Gram = Gram - - let antiquot_expr = Gram.Entry.mk "antiquot_expr" - - let antiquot_patt = Gram.Entry.mk "antiquot_patt" - - let _ = - (Gram.extend (antiquot_expr : 'antiquot_expr Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); - Gram.Stoken - (((function | EOI -> true | _ -> false), - "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) (x : 'expr) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (x : 'antiquot_expr) - | _ -> assert false))) ]) ])) - ()); - Gram.extend (antiquot_patt : 'antiquot_patt Gram.Entry.t) - ((fun () -> - (None, - [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); - Gram.Stoken - (((function | EOI -> true | _ -> false), - "EOI")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) (x : 'patt) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | EOI -> (x : 'antiquot_patt) - | _ -> assert false))) ]) ])) - ())) - - let parse_expr loc str = Gram.parse_string antiquot_expr loc str - - let parse_patt loc str = Gram.parse_string antiquot_patt loc str - - end - - module Quotation = Quotation - - let wrap directive_handler pa init_loc cs = - let rec loop loc = - let (pl, stopped_at_directive) = pa loc cs - in - match stopped_at_directive with - | Some new_loc -> - let pl = - (match List.rev pl with - | [] -> assert false - | x :: xs -> - (match directive_handler x with - | None -> xs - | Some x -> x :: xs)) - in (List.rev pl) @ (loop new_loc) - | None -> pl - in loop init_loc - - let parse_implem ?(directive_handler = fun _ -> None) _loc cs = - let l = wrap directive_handler (Gram.parse implem) _loc cs - in Ast.stSem_of_list l - - let parse_interf ?(directive_handler = fun _ -> None) _loc cs = - let l = wrap directive_handler (Gram.parse interf) _loc cs - in Ast.sgSem_of_list l - - let print_interf ?input_file:(_) ?output_file:(_) _ = - failwith "No interface printer" - - let print_implem ?input_file:(_) ?output_file:(_) _ = - failwith "No implementation printer" - - end - - end - -module PreCast : - sig - type camlp4_token = - Sig.camlp4_token = - | KEYWORD of string - | SYMBOL of string - | LIDENT of string - | UIDENT of string - | ESCAPED_IDENT of string - | INT of int * string - | INT32 of int32 * string - | INT64 of int64 * string - | NATIVEINT of nativeint * string - | FLOAT of float * string - | CHAR of char * string - | STRING of string * string - | LABEL of string - | OPTLABEL of string - | QUOTATION of Sig.quotation - | ANTIQUOT of string * string - | COMMENT of string - | BLANKS of string - | NEWLINE - | LINE_DIRECTIVE of int * string option - | EOI - - module Id : Sig.Id - - module Loc : Sig.Loc - - module Ast : Sig.Camlp4Ast with module Loc = Loc - - module Token : Sig.Token with module Loc = Loc and type t = camlp4_token - - module Lexer : Sig.Lexer with module Loc = Loc and module Token = Token - - module Gram : Sig.Grammar.Static with module Loc = Loc - and module Token = Token - - module Quotation : - Sig.Quotation with module Ast = Sig.Camlp4AstToAst(Ast) - - module DynLoader : Sig.DynLoader - - module AstFilters : Sig.AstFilters with module Ast = Ast - - module Syntax : Sig.Camlp4Syntax with module Loc = Loc - and module Token = Token and module Ast = Ast and module Gram = Gram - and module Quotation = Quotation - - module Printers : - sig - module OCaml : Sig.Printer(Ast).S - - module OCamlr : Sig.Printer(Ast).S - - module DumpOCamlAst : Sig.Printer(Ast).S - - module DumpCamlp4Ast : Sig.Printer(Ast).S - - module Null : Sig.Printer(Ast).S - - end - - module MakeGram (Lexer : Sig.Lexer with module Loc = Loc) : - Sig.Grammar.Static with module Loc = Loc and module Token = Lexer.Token - - module MakeSyntax (U : sig end) : Sig.Syntax - - end = - struct - module Id = - struct let name = "Camlp4.PreCast" - let version = Sys.ocaml_version - end - - type camlp4_token = - Sig.camlp4_token = - | KEYWORD of string - | SYMBOL of string - | LIDENT of string - | UIDENT of string - | ESCAPED_IDENT of string - | INT of int * string - | INT32 of int32 * string - | INT64 of int64 * string - | NATIVEINT of nativeint * string - | FLOAT of float * string - | CHAR of char * string - | STRING of string * string - | LABEL of string - | OPTLABEL of string - | QUOTATION of Sig.quotation - | ANTIQUOT of string * string - | COMMENT of string - | BLANKS of string - | NEWLINE - | LINE_DIRECTIVE of int * string option - | EOI - - module Loc = Struct.Loc - - module Ast = Struct.Camlp4Ast.Make(Loc) - - module Token = Struct.Token.Make(Loc) - - module Lexer = Struct.Lexer.Make(Token) - - module Gram = Struct.Grammar.Static.Make(Lexer) - - module DynLoader = Struct.DynLoader - - module Quotation = Struct.Quotation.Make(Ast) - - module MakeSyntax (U : sig end) = - OCamlInitSyntax.Make(Ast)(Gram)(Quotation) - - module Syntax = MakeSyntax(struct end) - - module AstFilters = Struct.AstFilters.Make(Ast) - - module MakeGram = Struct.Grammar.Static.Make - - module Printers = - struct - module OCaml = Printers.OCaml.Make(Syntax) - - module OCamlr = Printers.OCamlr.Make(Syntax) - - module DumpOCamlAst = Printers.DumpOCamlAst.Make(Syntax) - - module DumpCamlp4Ast = Printers.DumpCamlp4Ast.Make(Syntax) - - module Null = Printers.Null.Make(Syntax) - - end - - end - -module Register : - sig - module Plugin - (Id : Sig.Id) (Plugin : functor (Unit : sig end) -> sig end) : - sig end - - module SyntaxPlugin - (Id : Sig.Id) (SyntaxPlugin : functor (Syn : Sig.Syntax) -> sig end) : - sig end - - module SyntaxExtension - (Id : Sig.Id) (SyntaxExtension : Sig.SyntaxExtension) : sig end - - module OCamlSyntaxExtension - (Id : Sig.Id) - (SyntaxExtension : - functor (Syntax : Sig.Camlp4Syntax) -> Sig.Camlp4Syntax) : - sig end - - type 'a parser_fun = - ?directive_handler: ('a -> 'a option) -> - PreCast.Loc.t -> char Stream.t -> 'a - - val register_str_item_parser : PreCast.Ast.str_item parser_fun -> unit - - val register_sig_item_parser : PreCast.Ast.sig_item parser_fun -> unit - - val register_parser : - PreCast.Ast.str_item parser_fun -> - PreCast.Ast.sig_item parser_fun -> unit - - val current_parser : - unit -> - ((PreCast.Ast.str_item parser_fun) * - (PreCast.Ast.sig_item parser_fun)) - - module Parser - (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> Sig.Parser(Ast).S) : - sig end - - module OCamlParser - (Id : Sig.Id) - (Maker : functor (Ast : Sig.Camlp4Ast) -> Sig.Parser(Ast).S) : - sig end - - module OCamlPreCastParser - (Id : Sig.Id) (Parser : Sig.Parser(PreCast.Ast).S) : sig end - - type 'a printer_fun = - ?input_file: string -> ?output_file: string -> 'a -> unit - - val register_str_item_printer : PreCast.Ast.str_item printer_fun -> unit - - val register_sig_item_printer : PreCast.Ast.sig_item printer_fun -> unit - - val register_printer : - PreCast.Ast.str_item printer_fun -> - PreCast.Ast.sig_item printer_fun -> unit - - val current_printer : - unit -> - ((PreCast.Ast.str_item printer_fun) * - (PreCast.Ast.sig_item printer_fun)) - - module Printer - (Id : Sig.Id) - (Maker : functor (Syn : Sig.Syntax) -> Sig.Printer(Syn.Ast).S) : - sig end - - module OCamlPrinter - (Id : Sig.Id) - (Maker : functor (Syn : Sig.Camlp4Syntax) -> Sig.Printer(Syn.Ast).S) : - sig end - - module OCamlPreCastPrinter - (Id : Sig.Id) (Printer : Sig.Printer(PreCast.Ast).S) : sig end - - module AstFilter - (Id : Sig.Id) (Maker : functor (F : Sig.AstFilters) -> sig end) : - sig end - - val declare_dyn_module : string -> (unit -> unit) -> unit - - val iter_and_take_callbacks : ((string * (unit -> unit)) -> unit) -> unit - - val loaded_modules : (string list) ref - - module CurrentParser : Sig.Parser(PreCast.Ast).S - - module CurrentPrinter : Sig.Printer(PreCast.Ast).S - - val enable_ocaml_printer : unit -> unit - - val enable_ocamlr_printer : unit -> unit - - val enable_null_printer : unit -> unit - - val enable_dump_ocaml_ast_printer : unit -> unit - - val enable_dump_camlp4_ast_printer : unit -> unit - - end = - struct - module PP = Printers - - open PreCast - - type 'a parser_fun = - ?directive_handler: ('a -> 'a option) -> - PreCast.Loc.t -> char Stream.t -> 'a - - type 'a printer_fun = - ?input_file: string -> ?output_file: string -> 'a -> unit - - let sig_item_parser = - ref (fun ?directive_handler:(_) _ _ -> failwith "No interface parser") - - let str_item_parser = - ref - (fun ?directive_handler:(_) _ _ -> - failwith "No implementation parser") - - let sig_item_printer = - ref - (fun ?input_file:(_) ?output_file:(_) _ -> - failwith "No interface printer") - - let str_item_printer = - ref - (fun ?input_file:(_) ?output_file:(_) _ -> - failwith "No implementation printer") - - let callbacks = Queue.create () - - let loaded_modules = ref [] - - let iter_and_take_callbacks f = - let rec loop () = loop (f (Queue.take callbacks)) - in try loop () with | Queue.Empty -> () - - let declare_dyn_module m f = - (loaded_modules := m :: !loaded_modules; Queue.add (m, f) callbacks) - - let register_str_item_parser f = str_item_parser := f - - let register_sig_item_parser f = sig_item_parser := f - - let register_parser f g = (str_item_parser := f; sig_item_parser := g) - - let current_parser () = ((!str_item_parser), (!sig_item_parser)) - - let register_str_item_printer f = str_item_printer := f - - let register_sig_item_printer f = sig_item_printer := f - - let register_printer f g = (str_item_printer := f; sig_item_printer := g) - - let current_printer () = ((!str_item_printer), (!sig_item_printer)) - - module Plugin - (Id : Sig.Id) (Maker : functor (Unit : sig end) -> sig end) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(struct end) in ()) - - end - - module SyntaxExtension (Id : Sig.Id) (Maker : Sig.SyntaxExtension) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(Syntax) in ()) - - end - - module OCamlSyntaxExtension - (Id : Sig.Id) - (Maker : functor (Syn : Sig.Camlp4Syntax) -> Sig.Camlp4Syntax) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(Syntax) in ()) - - end - - module SyntaxPlugin - (Id : Sig.Id) (Maker : functor (Syn : Sig.Syntax) -> sig end) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(Syntax) in ()) - - end - - module Printer - (Id : Sig.Id) - (Maker : functor (Syn : Sig.Syntax) -> Sig.Printer(Syn.Ast).S) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(Syntax) - in register_printer M.print_implem M.print_interf) - - end - - module OCamlPrinter - (Id : Sig.Id) - (Maker : functor (Syn : Sig.Camlp4Syntax) -> Sig.Printer(Syn.Ast).S) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(Syntax) - in register_printer M.print_implem M.print_interf) - - end - - module OCamlPreCastPrinter - (Id : Sig.Id) (P : Sig.Printer(PreCast.Ast).S) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> register_printer P.print_implem P.print_interf) - - end - - module Parser - (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> Sig.Parser(Ast).S) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(PreCast.Ast) - in register_parser M.parse_implem M.parse_interf) - - end - - module OCamlParser - (Id : Sig.Id) - (Maker : functor (Ast : Sig.Camlp4Ast) -> Sig.Parser(Ast).S) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(PreCast.Ast) - in register_parser M.parse_implem M.parse_interf) - - end - - module OCamlPreCastParser (Id : Sig.Id) (P : Sig.Parser(PreCast.Ast).S) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> register_parser P.parse_implem P.parse_interf) - - end - - module AstFilter - (Id : Sig.Id) (Maker : functor (F : Sig.AstFilters) -> sig end) = - struct - let _ = - declare_dyn_module Id.name - (fun _ -> let module M = Maker(AstFilters) in ()) - - end - - let _ = sig_item_parser := Syntax.parse_interf - - let _ = str_item_parser := Syntax.parse_implem - - module CurrentParser = - struct - module Ast = Ast - - let parse_interf ?directive_handler loc strm = - !sig_item_parser ?directive_handler loc strm - - let parse_implem ?directive_handler loc strm = - !str_item_parser ?directive_handler loc strm - - end - - module CurrentPrinter = - struct - module Ast = Ast - - let print_interf ?input_file ?output_file ast = - !sig_item_printer ?input_file ?output_file ast - - let print_implem ?input_file ?output_file ast = - !str_item_printer ?input_file ?output_file ast - - end - - let enable_ocaml_printer () = - let module M = OCamlPrinter(PP.OCaml.Id)(PP.OCaml.MakeMore) in () - - let enable_ocamlr_printer () = - let module M = OCamlPrinter(PP.OCamlr.Id)(PP.OCamlr.MakeMore) in () - - let enable_dump_ocaml_ast_printer () = - let module M = OCamlPrinter(PP.DumpOCamlAst.Id)(PP.DumpOCamlAst.Make) - in () - - let enable_dump_camlp4_ast_printer () = - let module M = Printer(PP.DumpCamlp4Ast.Id)(PP.DumpCamlp4Ast.Make) - in () - - let enable_null_printer () = - let module M = Printer(PP.Null.Id)(PP.Null.Make) in () - - end - - diff -Nru ocaml-4.01.0/camlp4/boot/Camlp4.ml4 ocaml-4.02.3/camlp4/boot/Camlp4.ml4 --- ocaml-4.01.0/camlp4/boot/Camlp4.ml4 2012-08-02 10:17:59.000000000 +0200 +++ ocaml-4.02.3/camlp4/boot/Camlp4.ml4 1970-01-01 01:00:00.000000000 +0100 @@ -1,78 +0,0 @@ -module Debug : sig INCLUDE "camlp4/Camlp4/Debug.mli"; end = struct INCLUDE "camlp4/Camlp4/Debug.ml"; end; -module Options : sig INCLUDE "camlp4/Camlp4/Options.mli"; end = struct INCLUDE "camlp4/Camlp4/Options.ml"; end; -module Sig = struct INCLUDE "camlp4/Camlp4/Sig.ml"; end; -module ErrorHandler : sig INCLUDE "camlp4/Camlp4/ErrorHandler.mli"; end = struct INCLUDE "camlp4/Camlp4/ErrorHandler.ml"; end; - -module Struct = struct - module Loc : - sig INCLUDE "camlp4/Camlp4/Struct/Loc.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/Loc.ml"; end; - module Token : - sig INCLUDE "camlp4/Camlp4/Struct/Token.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/Token.ml"; end; - module Lexer = struct INCLUDE "camlp4/boot/Lexer.ml"; end; - module Camlp4Ast = struct INCLUDE "camlp4/Camlp4/Struct/Camlp4Ast.ml"; end; - module DynAst = struct INCLUDE "camlp4/Camlp4/Struct/DynAst.ml"; end; - module Quotation = struct INCLUDE "camlp4/Camlp4/Struct/Quotation.ml"; end; - module AstFilters = struct INCLUDE "camlp4/Camlp4/Struct/AstFilters.ml"; end; - module Camlp4Ast2OCamlAst : - sig INCLUDE "camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml"; end; - module CleanAst = struct INCLUDE "camlp4/Camlp4/Struct/CleanAst.ml"; end; - module CommentFilter : - sig INCLUDE "camlp4/Camlp4/Struct/CommentFilter.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/CommentFilter.ml"; end; - module DynLoader : - sig INCLUDE "camlp4/Camlp4/Struct/DynLoader.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/DynLoader.ml"; end; - module EmptyError : - sig INCLUDE "camlp4/Camlp4/Struct/EmptyError.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/EmptyError.ml"; end; - module EmptyPrinter : - sig INCLUDE "camlp4/Camlp4/Struct/EmptyPrinter.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/EmptyPrinter.ml"; end; - module FreeVars : - sig INCLUDE "camlp4/Camlp4/Struct/FreeVars.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/FreeVars.ml"; end; - module Grammar = struct - module Structure = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Structure.ml"; end; - module Search = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Search.ml"; end; - (* module Find = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Find.ml"; end; *) - module Tools = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Tools.ml"; end; - module Print : - sig INCLUDE "camlp4/Camlp4/Struct/Grammar/Print.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Print.ml"; end; - module Failed = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Failed.ml"; end; - module Parser = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Parser.ml"; end; - module Insert = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Insert.ml"; end; - module Delete = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Delete.ml"; end; - module Fold : - sig INCLUDE "camlp4/Camlp4/Struct/Grammar/Fold.mli"; end = - struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Fold.ml"; end; - module Entry = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Entry.ml"; end; - module Static = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Static.ml"; end; - module Dynamic = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Dynamic.ml"; end; - end; -end; - -module Printers = struct - module DumpCamlp4Ast : - sig INCLUDE "camlp4/Camlp4/Printers/DumpCamlp4Ast.mli"; end = - struct INCLUDE "camlp4/Camlp4/Printers/DumpCamlp4Ast.ml"; end; - module DumpOCamlAst : - sig INCLUDE "camlp4/Camlp4/Printers/DumpOCamlAst.mli"; end = - struct INCLUDE "camlp4/Camlp4/Printers/DumpOCamlAst.ml"; end; - module Null : - sig INCLUDE "camlp4/Camlp4/Printers/Null.mli"; end = - struct INCLUDE "camlp4/Camlp4/Printers/Null.ml"; end; - module OCaml : - sig INCLUDE "camlp4/Camlp4/Printers/OCaml.mli"; end = - struct INCLUDE "camlp4/Camlp4/Printers/OCaml.ml"; end; - module OCamlr : - sig INCLUDE "camlp4/Camlp4/Printers/OCamlr.mli"; end = - struct INCLUDE "camlp4/Camlp4/Printers/OCamlr.ml"; end; -end; - -module OCamlInitSyntax = struct INCLUDE "camlp4/Camlp4/OCamlInitSyntax.ml"; end; -module PreCast : sig INCLUDE "camlp4/Camlp4/PreCast.mli"; end = struct INCLUDE "camlp4/Camlp4/PreCast.ml"; end; -module Register : sig INCLUDE "camlp4/Camlp4/Register.mli"; end = struct INCLUDE "camlp4/Camlp4/Register.ml"; end; diff -Nru ocaml-4.01.0/camlp4/boot/.ignore ocaml-4.02.3/camlp4/boot/.ignore --- ocaml-4.01.0/camlp4/boot/.ignore 2012-07-26 21:21:54.000000000 +0200 +++ ocaml-4.02.3/camlp4/boot/.ignore 1970-01-01 01:00:00.000000000 +0100 @@ -1,5 +0,0 @@ -camlp4 -camlp4o -camlp4r -SAVED -*.old diff -Nru ocaml-4.01.0/camlp4/build/.ignore ocaml-4.02.3/camlp4/build/.ignore --- ocaml-4.01.0/camlp4/build/.ignore 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/build/.ignore 1970-01-01 01:00:00.000000000 +0100 @@ -1,5 +0,0 @@ -camlp4_config.ml -location.ml -location.mli -terminfo.ml -terminfo.mli diff -Nru ocaml-4.01.0/camlp4/Camlp4/Camlp4Ast.partial.ml ocaml-4.02.3/camlp4/Camlp4/Camlp4Ast.partial.ml --- ocaml-4.01.0/camlp4/Camlp4/Camlp4Ast.partial.ml 2013-08-30 13:39:33.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Camlp4Ast.partial.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,412 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Note: when you modify these types you must increment - ast magic numbers defined in Camlp4_config.ml. *) - - type loc = Loc.t - and meta_bool = - [ BTrue - | BFalse - | BAnt of string ] - and rec_flag = - [ ReRecursive - | ReNil - | ReAnt of string ] - and direction_flag = - [ DiTo - | DiDownto - | DiAnt of string ] - and mutable_flag = - [ MuMutable - | MuNil - | MuAnt of string ] - and private_flag = - [ PrPrivate - | PrNil - | PrAnt of string ] - and virtual_flag = - [ ViVirtual - | ViNil - | ViAnt of string ] - and override_flag = - [ OvOverride - | OvNil - | OvAnt of string ] - and row_var_flag = - [ RvRowVar - | RvNil - | RvAnt of string ] - and meta_option 'a = - [ ONone - | OSome of 'a - | OAnt of string ] - and meta_list 'a = - [ LNil - | LCons of 'a and meta_list 'a - | 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 and string and list ctyp and ctyp and list (ctyp * ctyp) - (* < (t)? (..)? > *) (* < move : int -> 'a .. > as 'a *) - | TyObj of loc and ctyp and row_var_flag - | TyOlb of loc and string and ctyp (* ?s:t *) - | TyPol of loc and ctyp and ctyp (* ! t . t *) (* ! 'a . list 'a -> 'a *) - | TyTypePol of loc and ctyp and ctyp (* type t . t *) (* type a . list a -> a *) - | TyQuo of loc and string (* 's *) - | TyQuP of loc and string (* +'s *) - | TyQuM of loc and string (* -'s *) - | TyAnP of loc (* +_ *) - | TyAnM of loc (* -_ *) - | 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 *) - | TyPkg of loc and module_type (* (module S) *) - | TyAnt of loc and string (* $s$ *) - ] - 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 and string and patt - (* ?s:(p = e) or ?(p = e) *) - | 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 *) - | PaLaz of loc and patt (* lazy p *) - | PaMod of loc and string (* (module M) *) ] - and expr = - [ 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 and string and expr and expr and direction_flag 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 and rec_flag and binding and expr - (* let module s = me in e *) - | 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 and ident - (* object ((p))? (cst)? end *) - | ExObj of loc and patt and class_str_item - (* ?s or ?s:e *) - | 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 and expr - (* e#s *) - | ExSnd of loc and expr and string - (* e.[e] *) - | ExSte of loc and expr and expr - (* s *) (* "foo" *) - | ExStr of loc and string - (* try e with [ mc ] *) - | ExTry of loc and expr and match_case - (* (e) *) - | ExTup of loc and expr - (* e, e *) - | ExCom of loc and expr and expr - (* (e : t) *) - | ExTyc of loc and expr and ctyp - (* `s *) - | ExVrn of loc and string - (* while e do { e } *) - | ExWhi of loc and expr and expr - (* let open i in e *) - | ExOpI of loc and ident and expr - (* fun (type t) -> e *) - (* let f x (type t) y z = e *) - | ExFUN of loc and string and expr - (* (module ME : S) which is represented as (module (ME : S)) *) - | ExPkg of loc and module_expr ] - and module_type = - [ MtNil of loc - (* i *) (* A.B.C *) - | MtId of loc and ident - (* functor (s : mt) -> mt *) - | MtFun of loc and string and module_type and module_type - (* 's *) - | MtQuo of loc and string - (* sig sg end *) - | MtSig of loc and sig_item - (* mt with wc *) - | MtWit of loc and module_type and with_constr - (* module type of m *) - | MtOf of loc and module_expr - | MtAnt of loc and string (* $s$ *) ] - and sig_item = - [ SgNil of loc - (* class cict *) - | SgCls of loc and class_type - (* class type cict *) - | SgClt of loc and class_type - (* sg ; sg *) - | SgSem of loc and sig_item and sig_item - (* # s or # s e *) - | SgDir of loc and string and expr - (* exception t *) - | SgExc of loc and ctyp - (* external s : t = s ... s *) - | SgExt of loc and string and ctyp and meta_list string - (* include mt *) - | SgInc of loc and module_type - (* module s : mt *) - | SgMod of loc and string and module_type - (* module rec mb *) - | SgRecMod of loc and module_binding - (* module type s = mt *) - | SgMty of loc and string and module_type - (* open i *) - | SgOpn of loc and ident - (* type t *) - | SgTyp of loc and ctyp - (* value s : t *) - | SgVal of loc and string and ctyp - | SgAnt of loc and string (* $s$ *) ] - and with_constr = - [ WcNil of loc - (* type t = t *) - | WcTyp of loc and ctyp and ctyp - (* module i = i *) - | WcMod of loc and ident and ident - (* type t := t *) - | WcTyS of loc and ctyp and ctyp - (* module i := i *) - | WcMoS of loc and ident and ident - (* wc and wc *) - | WcAnd of loc and with_constr and with_constr - | WcAnt of loc and string (* $s$ *) ] - 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 and patt and expr - | BiAnt of loc and string (* $s$ *) ] - and rec_binding = - [ RbNil of loc - (* rb ; rb *) - | RbSem of loc and rec_binding and rec_binding - (* i = e *) - | RbEq of loc and ident and expr - | RbAnt of loc and string (* $s$ *) ] - and module_binding = - [ MbNil of loc - (* mb and mb *) (* module rec (s : mt) = me and (s : mt) = me *) - | MbAnd of loc and module_binding and module_binding - (* s : mt = me *) - | MbColEq of loc and string and module_type and module_expr - (* s : mt *) - | MbCol of loc and string and module_type - | MbAnt of loc and string (* $s$ *) ] - and match_case = - [ McNil of loc - (* a | a *) - | McOr of loc and match_case and match_case - (* p (when e)? -> e *) - | McArr of loc and patt and expr and expr - | McAnt of loc and string (* $s$ *) ] - and module_expr = - [ MeNil of loc - (* i *) - | MeId of loc and ident - (* me me *) - | MeApp of loc and module_expr and module_expr - (* functor (s : mt) -> me *) - | 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 and module_expr and module_type - (* (value e) *) - (* (value e : S) which is represented as (value (e : S)) *) - | MePkg of loc and expr - | MeAnt of loc and string (* $s$ *) ] - and str_item = - [ StNil of loc - (* class cice *) - | StCls of loc and class_expr - (* class type cict *) - | StClt of loc and class_type - (* st ; st *) - | StSem of loc and str_item and str_item - (* # s or # s e *) - | StDir of loc and string and expr - (* exception t or exception t = i *) - | StExc of loc and ctyp and meta_option(*FIXME*) ident - (* e *) - | StExp of loc and expr - (* external s : t = s ... s *) - | StExt of loc and string and ctyp and meta_list string - (* include me *) - | StInc of loc and module_expr - (* module s = me *) - | StMod of loc and string and module_expr - (* module rec mb *) - | StRecMod of loc and module_binding - (* module type s = mt *) - | StMty of loc and string and module_type - (* open i *) - | StOpn of loc and ident - (* type t *) - | StTyp of loc and ctyp - (* value (rec)? bi *) - | StVal of loc and rec_flag and binding - | StAnt of loc and string (* $s$ *) ] - and class_type = - [ CtNil of loc - (* (virtual)? i ([ t ])? *) - | CtCon of loc and virtual_flag and ident and ctyp - (* [t] -> ct *) - | CtFun of loc and ctyp and class_type - (* object ((t))? (csg)? end *) - | CtSig of loc and ctyp and class_sig_item - (* ct and ct *) - | CtAnd of loc and class_type and class_type - (* ct : ct *) - | CtCol of loc and class_type and class_type - (* ct = ct *) - | CtEq of loc and class_type and class_type - (* $s$ *) - | CtAnt of loc and string ] - and class_sig_item = - [ CgNil of loc - (* type t = t *) - | CgCtr of loc and ctyp and ctyp - (* csg ; csg *) - | CgSem of loc and class_sig_item and class_sig_item - (* inherit ct *) - | CgInh of loc and class_type - (* method s : t or method private s : t *) - | CgMth of loc and string and private_flag and ctyp - (* value (virtual)? (mutable)? s : t *) - | CgVal of loc and string and mutable_flag and virtual_flag and ctyp - (* method virtual (private)? s : t *) - | CgVir of loc and string and private_flag and ctyp - | CgAnt of loc and string (* $s$ *) ] - and class_expr = - [ CeNil of loc - (* ce e *) - | CeApp of loc and class_expr and expr - (* (virtual)? i ([ t ])? *) - | CeCon of loc and virtual_flag and ident and ctyp - (* fun p -> ce *) - | CeFun of loc and patt and class_expr - (* let (rec)? bi in ce *) - | CeLet of loc and rec_flag and binding and class_expr - (* object ((p))? (cst)? end *) - | CeStr of loc and patt and class_str_item - (* ce : ct *) - | CeTyc of loc and class_expr and class_type - (* ce and ce *) - | CeAnd of loc and class_expr and class_expr - (* ce = ce *) - | CeEq of loc and class_expr and class_expr - (* $s$ *) - | CeAnt of loc and string ] - and class_str_item = - [ CrNil of loc - (* cst ; cst *) - | CrSem of loc and class_str_item and class_str_item - (* type t = t *) - | CrCtr of loc and ctyp and ctyp - (* inherit(!)? ce (as s)? *) - | CrInh of loc and override_flag and class_expr and string - (* initializer e *) - | CrIni of loc and expr - (* method(!)? (private)? s : t = e or method(!)? (private)? s = e *) - | CrMth of loc and string and override_flag and private_flag and expr and ctyp - (* value(!)? (mutable)? s = e *) - | CrVal of loc and string and override_flag and mutable_flag and expr - (* method virtual (private)? s : t *) - | CrVir of loc and string and private_flag and ctyp - (* value virtual (mutable)? s : t *) - | CrVvr of loc and string and mutable_flag and ctyp - | CrAnt of loc and string (* $s$ *) ]; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Debug.ml ocaml-4.02.3/camlp4/Camlp4/Debug.ml --- ocaml-4.01.0/camlp4/Camlp4/Debug.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Debug.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,64 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -(* camlp4r *) -open Format; - -module Debug = struct value mode _ = False; end; - -type section = string; - -value out_channel = - try - let f = Sys.getenv "CAMLP4_DEBUG_FILE" in - open_out_gen [Open_wronly; Open_creat; Open_append; Open_text] - 0o666 f - with - [ Not_found -> Pervasives.stderr ]; - -module StringSet = Set.Make String; - -value mode = - try - let str = Sys.getenv "CAMLP4_DEBUG" in - let rec loop acc i = - try - let pos = String.index_from str i ':' in - loop (StringSet.add (String.sub str i (pos - i)) acc) (pos + 1) - with - [ Not_found -> - StringSet.add (String.sub str i (String.length str - i)) acc ] in - let sections = loop StringSet.empty 0 in - if StringSet.mem "*" sections then fun _ -> True - else fun x -> StringSet.mem x sections - with [ Not_found -> fun _ -> False ]; - -value formatter = - let header = "camlp4-debug: " in - let at_bol = ref True in - (make_formatter - (fun buf pos len -> - for i = pos to pos + len - 1 do - if at_bol.val then output_string out_channel header else (); - let ch = buf.[i]; - output_char out_channel ch; - at_bol.val := ch = '\n'; - done) - (fun () -> flush out_channel)); - -value printf section fmt = fprintf formatter ("%s: " ^^ fmt) section; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Debug.mli ocaml-4.02.3/camlp4/Camlp4/Debug.mli --- ocaml-4.01.0/camlp4/Camlp4/Debug.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Debug.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,22 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -(* camlp4r *) -type section = string; -value mode : section -> bool; -value printf : section -> format 'a Format.formatter unit -> 'a; diff -Nru ocaml-4.01.0/camlp4/Camlp4/ErrorHandler.ml ocaml-4.02.3/camlp4/Camlp4/ErrorHandler.ml --- ocaml-4.01.0/camlp4/Camlp4/ErrorHandler.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/ErrorHandler.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,171 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -(* camlp4r *) - -open Format; - -module ObjTools = struct - - value desc obj = - if Obj.is_block obj then - "tag = " ^ string_of_int (Obj.tag obj) - else "int_val = " ^ string_of_int (Obj.obj obj); - - (*Imported from the extlib*) - value rec to_string r = - if Obj.is_int r then - let i = (Obj.magic r : int) - in string_of_int i ^ " | CstTag" ^ string_of_int (i + 1) - else (* Block. *) - let rec get_fields acc = - fun - [ 0 -> acc - | n -> let n = n-1 in get_fields [Obj.field r n :: acc] n ] - in - let rec is_list r = - if Obj.is_int r then - r = Obj.repr 0 (* [] *) - else - let s = Obj.size r and t = Obj.tag r in - t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *) - in - let rec get_list r = - if Obj.is_int r then [] - else let h = Obj.field r 0 and t = get_list (Obj.field r 1) in [h :: t] - in - let opaque name = - (* XXX In future, print the address of value 'r'. Not possible in - * pure OCaml at the moment. - *) - "<" ^ name ^ ">" - in - let s = Obj.size r and t = Obj.tag r in - (* From the tag, determine the type of block. *) - match t with - [ _ when is_list r -> - let fields = get_list r in - "[" ^ String.concat "; " (List.map to_string fields) ^ "]" - | 0 -> - let fields = get_fields [] s in - "(" ^ String.concat ", " (List.map to_string fields) ^ ")" - | x when x = Obj.lazy_tag -> - (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not - * clear if very large constructed values could have the same - * tag. XXX *) - opaque "lazy" - | x when x = Obj.closure_tag -> - opaque "closure" - | x when x = Obj.object_tag -> - let fields = get_fields [] s in - let (_class, id, slots) = - match fields with - [ [h; h'::t] -> (h, h', t) - | _ -> assert False ] - in - (* No information on decoding the class (first field). So just print - * out the ID and the slots. *) - "Object #" ^ to_string id ^ " (" ^ String.concat ", " (List.map to_string slots) ^ ")" - | x when x = Obj.infix_tag -> - opaque "infix" - | x when x = Obj.forward_tag -> - opaque "forward" - | x when x < Obj.no_scan_tag -> - let fields = get_fields [] s in - "Tag" ^ string_of_int t ^ - " (" ^ String.concat ", " (List.map to_string fields) ^ ")" - | x when x = Obj.string_tag -> - "\"" ^ String.escaped (Obj.magic r : string) ^ "\"" - | x when x = Obj.double_tag -> - Camlp4_import.Oprint.float_repres (Obj.magic r : float) - | x when x = Obj.abstract_tag -> - opaque "abstract" - | x when x = Obj.custom_tag -> - opaque "custom" - | x when x = Obj.final_tag -> - opaque "final" - | _ -> - failwith ("ObjTools.to_string: unknown tag (" ^ string_of_int t ^ ")") ]; - - value print ppf x = fprintf ppf "%s" (to_string x); - value print_desc ppf x = fprintf ppf "%s" (desc x); - -end; - -value default_handler ppf x = do { - let x = Obj.repr x; - fprintf ppf "Camlp4: Uncaught exception: %s" - (Obj.obj (Obj.field (Obj.field x 0) 0) : string); - if Obj.size x > 1 then do { - pp_print_string ppf " ("; - for i = 1 to Obj.size x - 1 do - if i > 1 then pp_print_string ppf ", " else (); - ObjTools.print ppf (Obj.field x i); - done; - pp_print_char ppf ')' - } - else (); - fprintf ppf "@." -}; - -value handler = ref (fun ppf default_handler exn -> default_handler ppf exn); - -value register f = - let current_handler = handler.val in - handler.val := - fun ppf default_handler exn -> - try f ppf exn with exn -> current_handler ppf default_handler exn; - -module Register (Error : Sig.Error) = struct - let current_handler = handler.val in - handler.val := - fun ppf default_handler -> - fun [ Error.E x -> Error.print ppf x - | x -> current_handler ppf default_handler x ]; -end; - - -value gen_print ppf default_handler = - fun - [ Out_of_memory -> fprintf ppf "Out of memory" - | Assert_failure (file, line, char) -> - fprintf ppf "Assertion failed, file %S, line %d, char %d" - file line char - | Match_failure (file, line, char) -> - fprintf ppf "Pattern matching failed, file %S, line %d, char %d" - file line char - | Failure str -> fprintf ppf "Failure: %S" str - | Invalid_argument str -> fprintf ppf "Invalid argument: %S" str - | Sys_error str -> fprintf ppf "I/O error: %S" str - | Stream.Failure -> fprintf ppf "Parse failure" - | Stream.Error str -> fprintf ppf "Parse error: %s" str - | x -> handler.val ppf default_handler x ]; - -value print ppf = gen_print ppf default_handler; - -value try_print ppf = gen_print ppf (fun _ -> raise); - -value to_string exn = - let buf = Buffer.create 128 in - let () = bprintf buf "%a" print exn in - Buffer.contents buf; - -value try_to_string exn = - let buf = Buffer.create 128 in - let () = bprintf buf "%a" try_print exn in - Buffer.contents buf; diff -Nru ocaml-4.01.0/camlp4/Camlp4/ErrorHandler.mli ocaml-4.02.3/camlp4/Camlp4/ErrorHandler.mli --- ocaml-4.01.0/camlp4/Camlp4/ErrorHandler.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/ErrorHandler.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,36 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) -value print : Format.formatter -> exn -> unit; - -value try_print : Format.formatter -> exn -> unit; - -value to_string : exn -> string; - -value try_to_string : exn -> string; - -value register : (Format.formatter -> exn -> unit) -> unit; - -module Register (Error : Sig.Error) : sig end; - -module ObjTools : sig - value print : Format.formatter -> Obj.t -> unit; - value print_desc : Format.formatter -> Obj.t -> unit; - (*Imported from the extlib*) - value to_string : Obj.t -> string; - value desc : Obj.t -> string; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/OCamlInitSyntax.ml ocaml-4.02.3/camlp4/Camlp4/OCamlInitSyntax.ml --- ocaml-4.01.0/camlp4/Camlp4/OCamlInitSyntax.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/OCamlInitSyntax.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,265 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Camlp4Ast) - (Gram : Sig.Grammar.Static with module Loc = Ast.Loc - with type Token.t = Sig.camlp4_token) - (Quotation : Sig.Quotation with module Ast = Sig.Camlp4AstToAst Ast) -: Sig.Camlp4Syntax with module Loc = Ast.Loc - and module Ast = Ast - and module Token = Gram.Token - and module Gram = Gram - and module Quotation = Quotation -= struct - - module Loc = Ast.Loc; - module Ast = Ast; - module Gram = Gram; - module Token = Gram.Token; - open Sig; - - (* Warnings *) - type warning = Loc.t -> string -> unit; - value default_warning loc txt = Format.eprintf " %a: %s@." Loc.print loc txt; - value current_warning = ref default_warning; - value print_warning loc txt = current_warning.val loc txt; - - value a_CHAR = Gram.Entry.mk "a_CHAR"; - value a_FLOAT = Gram.Entry.mk "a_FLOAT"; - value a_INT = Gram.Entry.mk "a_INT"; - value a_INT32 = Gram.Entry.mk "a_INT32"; - value a_INT64 = Gram.Entry.mk "a_INT64"; - value a_LABEL = Gram.Entry.mk "a_LABEL"; - value a_LIDENT = Gram.Entry.mk "a_LIDENT"; - value a_NATIVEINT = Gram.Entry.mk "a_NATIVEINT"; - value a_OPTLABEL = Gram.Entry.mk "a_OPTLABEL"; - value a_STRING = Gram.Entry.mk "a_STRING"; - value a_UIDENT = Gram.Entry.mk "a_UIDENT"; - value a_ident = Gram.Entry.mk "a_ident"; - value amp_ctyp = Gram.Entry.mk "amp_ctyp"; - value and_ctyp = Gram.Entry.mk "and_ctyp"; - value match_case = Gram.Entry.mk "match_case"; - value match_case0 = Gram.Entry.mk "match_case0"; - value binding = Gram.Entry.mk "binding"; - value class_declaration = Gram.Entry.mk "class_declaration"; - value class_description = Gram.Entry.mk "class_description"; - value class_expr = Gram.Entry.mk "class_expr"; - value class_fun_binding = Gram.Entry.mk "class_fun_binding"; - value class_fun_def = Gram.Entry.mk "class_fun_def"; - value class_info_for_class_expr = Gram.Entry.mk "class_info_for_class_expr"; - value class_info_for_class_type = Gram.Entry.mk "class_info_for_class_type"; - value class_longident = Gram.Entry.mk "class_longident"; - value class_longident_and_param = Gram.Entry.mk "class_longident_and_param"; - value class_name_and_param = Gram.Entry.mk "class_name_and_param"; - value class_sig_item = Gram.Entry.mk "class_sig_item"; - value class_signature = Gram.Entry.mk "class_signature"; - value class_str_item = Gram.Entry.mk "class_str_item"; - value class_structure = Gram.Entry.mk "class_structure"; - value class_type = Gram.Entry.mk "class_type"; - value class_type_declaration = Gram.Entry.mk "class_type_declaration"; - value class_type_longident = Gram.Entry.mk "class_type_longident"; - value class_type_longident_and_param = Gram.Entry.mk "class_type_longident_and_param"; - value class_type_plus = Gram.Entry.mk "class_type_plus"; - value comma_ctyp = Gram.Entry.mk "comma_ctyp"; - value comma_expr = Gram.Entry.mk "comma_expr"; - value comma_ipatt = Gram.Entry.mk "comma_ipatt"; - value comma_patt = Gram.Entry.mk "comma_patt"; - value comma_type_parameter = Gram.Entry.mk "comma_type_parameter"; - value constrain = Gram.Entry.mk "constrain"; - value constructor_arg_list = Gram.Entry.mk "constructor_arg_list"; - value constructor_declaration = Gram.Entry.mk "constructor_declaration"; - value constructor_declarations = Gram.Entry.mk "constructor_declarations"; - value ctyp = Gram.Entry.mk "ctyp"; - value cvalue_binding = Gram.Entry.mk "cvalue_binding"; - value direction_flag = Gram.Entry.mk "direction_flag"; - value direction_flag_quot = Gram.Entry.mk "direction_flag_quot"; - value dummy = Gram.Entry.mk "dummy"; - value entry_eoi = Gram.Entry.mk "entry_eoi"; - value eq_expr = Gram.Entry.mk "eq_expr"; - value expr = Gram.Entry.mk "expr"; - value expr_eoi = Gram.Entry.mk "expr_eoi"; - value field_expr = Gram.Entry.mk "field_expr"; - value field_expr_list = Gram.Entry.mk "field_expr_list"; - value fun_binding = Gram.Entry.mk "fun_binding"; - value fun_def = Gram.Entry.mk "fun_def"; - value ident = Gram.Entry.mk "ident"; - value implem = Gram.Entry.mk "implem"; - value interf = Gram.Entry.mk "interf"; - value ipatt = Gram.Entry.mk "ipatt"; - value ipatt_tcon = Gram.Entry.mk "ipatt_tcon"; - value label = Gram.Entry.mk "label"; - value label_declaration = Gram.Entry.mk "label_declaration"; - value label_declaration_list = Gram.Entry.mk "label_declaration_list"; - value label_expr = Gram.Entry.mk "label_expr"; - value label_expr_list = Gram.Entry.mk "label_expr_list"; - value label_ipatt = Gram.Entry.mk "label_ipatt"; - value label_ipatt_list = Gram.Entry.mk "label_ipatt_list"; - value label_longident = Gram.Entry.mk "label_longident"; - value label_patt = Gram.Entry.mk "label_patt"; - value label_patt_list = Gram.Entry.mk "label_patt_list"; - value labeled_ipatt = Gram.Entry.mk "labeled_ipatt"; - value let_binding = Gram.Entry.mk "let_binding"; - value meth_list = Gram.Entry.mk "meth_list"; - value meth_decl = Gram.Entry.mk "meth_decl"; - value module_binding = Gram.Entry.mk "module_binding"; - value module_binding0 = Gram.Entry.mk "module_binding0"; - value module_declaration = Gram.Entry.mk "module_declaration"; - value module_expr = Gram.Entry.mk "module_expr"; - value module_longident = Gram.Entry.mk "module_longident"; - value module_longident_with_app = Gram.Entry.mk "module_longident_with_app"; - value module_rec_declaration = Gram.Entry.mk "module_rec_declaration"; - value module_type = Gram.Entry.mk "module_type"; - value package_type = Gram.Entry.mk "package_type"; - value more_ctyp = Gram.Entry.mk "more_ctyp"; - value name_tags = Gram.Entry.mk "name_tags"; - value opt_as_lident = Gram.Entry.mk "opt_as_lident"; - value opt_class_self_patt = Gram.Entry.mk "opt_class_self_patt"; - value opt_class_self_type = Gram.Entry.mk "opt_class_self_type"; - value opt_class_signature = Gram.Entry.mk "opt_class_signature"; - value opt_class_structure = Gram.Entry.mk "opt_class_structure"; - value opt_comma_ctyp = Gram.Entry.mk "opt_comma_ctyp"; - value opt_dot_dot = Gram.Entry.mk "opt_dot_dot"; - value row_var_flag_quot = Gram.Entry.mk "row_var_flag_quot"; - value opt_eq_ctyp = Gram.Entry.mk "opt_eq_ctyp"; - value opt_expr = Gram.Entry.mk "opt_expr"; - value opt_meth_list = Gram.Entry.mk "opt_meth_list"; - value opt_mutable = Gram.Entry.mk "opt_mutable"; - value mutable_flag_quot = Gram.Entry.mk "mutable_flag_quot"; - value opt_polyt = Gram.Entry.mk "opt_polyt"; - value opt_private = Gram.Entry.mk "opt_private"; - value private_flag_quot = Gram.Entry.mk "private_flag_quot"; - value opt_rec = Gram.Entry.mk "opt_rec"; - value rec_flag_quot = Gram.Entry.mk "rec_flag_quot"; - value opt_sig_items = Gram.Entry.mk "opt_sig_items"; - value opt_str_items = Gram.Entry.mk "opt_str_items"; - value opt_virtual = Gram.Entry.mk "opt_virtual"; - value virtual_flag_quot = Gram.Entry.mk "virtual_flag_quot"; - value opt_override = Gram.Entry.mk "opt_override"; - value override_flag_quot = Gram.Entry.mk "override_flag_quot"; - value opt_when_expr = Gram.Entry.mk "opt_when_expr"; - value patt = Gram.Entry.mk "patt"; - value patt_as_patt_opt = Gram.Entry.mk "patt_as_patt_opt"; - value patt_eoi = Gram.Entry.mk "patt_eoi"; - value patt_tcon = Gram.Entry.mk "patt_tcon"; - value phrase = Gram.Entry.mk "phrase"; - value poly_type = Gram.Entry.mk "poly_type"; - value row_field = Gram.Entry.mk "row_field"; - value sem_expr = Gram.Entry.mk "sem_expr"; - value sem_expr_for_list = Gram.Entry.mk "sem_expr_for_list"; - value sem_patt = Gram.Entry.mk "sem_patt"; - value sem_patt_for_list = Gram.Entry.mk "sem_patt_for_list"; - value semi = Gram.Entry.mk "semi"; - value sequence = Gram.Entry.mk "sequence"; - value do_sequence = Gram.Entry.mk "do_sequence"; - value sig_item = Gram.Entry.mk "sig_item"; - value sig_items = Gram.Entry.mk "sig_items"; - value star_ctyp = Gram.Entry.mk "star_ctyp"; - value str_item = Gram.Entry.mk "str_item"; - value str_items = Gram.Entry.mk "str_items"; - value top_phrase = Gram.Entry.mk "top_phrase"; - value type_constraint = Gram.Entry.mk "type_constraint"; - value type_declaration = Gram.Entry.mk "type_declaration"; - value type_ident_and_parameters = Gram.Entry.mk "type_ident_and_parameters"; - value type_kind = Gram.Entry.mk "type_kind"; - value type_longident = Gram.Entry.mk "type_longident"; - value type_longident_and_parameters = Gram.Entry.mk "type_longident_and_parameters"; - value type_parameter = Gram.Entry.mk "type_parameter"; - value type_parameters = Gram.Entry.mk "type_parameters"; - value typevars = Gram.Entry.mk "typevars"; - value use_file = Gram.Entry.mk "use_file"; - value val_longident = Gram.Entry.mk "val_longident"; - value value_let = Gram.Entry.mk "value_let"; - value value_val = Gram.Entry.mk "value_val"; - value with_constr = Gram.Entry.mk "with_constr"; - value expr_quot = Gram.Entry.mk "quotation of expression"; - value patt_quot = Gram.Entry.mk "quotation of pattern"; - value ctyp_quot = Gram.Entry.mk "quotation of type"; - value str_item_quot = Gram.Entry.mk "quotation of structure item"; - value sig_item_quot = Gram.Entry.mk "quotation of signature item"; - value class_str_item_quot = Gram.Entry.mk "quotation of class structure item"; - value class_sig_item_quot = Gram.Entry.mk "quotation of class signature item"; - value module_expr_quot = Gram.Entry.mk "quotation of module expression"; - value module_type_quot = Gram.Entry.mk "quotation of module type"; - value class_type_quot = Gram.Entry.mk "quotation of class type"; - value class_expr_quot = Gram.Entry.mk "quotation of class expression"; - value with_constr_quot = Gram.Entry.mk "quotation of with constraint"; - value binding_quot = Gram.Entry.mk "quotation of binding"; - value rec_binding_quot = Gram.Entry.mk "quotation of record binding"; - value match_case_quot = Gram.Entry.mk "quotation of match_case (try/match/function case)"; - value module_binding_quot = Gram.Entry.mk "quotation of module rec binding"; - value ident_quot = Gram.Entry.mk "quotation of identifier"; - value prefixop = Gram.Entry.mk "prefix operator (start with '!', '?', '~')"; - value infixop0 = Gram.Entry.mk "infix operator (level 0) (comparison operators, and some others)"; - value infixop1 = Gram.Entry.mk "infix operator (level 1) (start with '^', '@')"; - value infixop2 = Gram.Entry.mk "infix operator (level 2) (start with '+', '-')"; - value infixop3 = Gram.Entry.mk "infix operator (level 3) (start with '*', '/', '%')"; - value infixop4 = Gram.Entry.mk "infix operator (level 4) (start with \"**\") (right assoc)"; - - EXTEND Gram - top_phrase: - [ [ `EOI -> None ] ] - ; - END; - - module AntiquotSyntax = struct - module Loc = Ast.Loc; - module Ast = Sig.Camlp4AstToAst Ast; - module Gram = Gram; - value antiquot_expr = Gram.Entry.mk "antiquot_expr"; - value antiquot_patt = Gram.Entry.mk "antiquot_patt"; - EXTEND Gram - antiquot_expr: - [ [ x = expr; `EOI -> x ] ] - ; - antiquot_patt: - [ [ x = patt; `EOI -> x ] ] - ; - END; - value parse_expr loc str = Gram.parse_string antiquot_expr loc str; - value parse_patt loc str = Gram.parse_string antiquot_patt loc str; - end; - - module Quotation = Quotation; - - value wrap directive_handler pa init_loc cs = - let rec loop loc = - let (pl, stopped_at_directive) = pa loc cs in - match stopped_at_directive with - [ Some new_loc -> - let pl = - match List.rev pl with - [ [] -> assert False - | [x :: xs] -> - match directive_handler x with - [ None -> xs - | Some x -> [x :: xs] ] ] - in (List.rev pl) @ (loop new_loc) - | None -> pl ] - in loop init_loc; - - value parse_implem ?(directive_handler = fun _ -> None) _loc cs = - let l = wrap directive_handler (Gram.parse implem) _loc cs in - <:str_item< $list:l$ >>; - - value parse_interf ?(directive_handler = fun _ -> None) _loc cs = - let l = wrap directive_handler (Gram.parse interf) _loc cs in - <:sig_item< $list:l$ >>; - - value print_interf ?input_file:(_) ?output_file:(_) _ = failwith "No interface printer"; - value print_implem ?input_file:(_) ?output_file:(_) _ = failwith "No implementation printer"; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Options.ml ocaml-4.02.3/camlp4/Camlp4/Options.ml --- ocaml-4.01.0/camlp4/Camlp4/Options.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Options.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,191 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -type spec_list = list (string * Arg.spec * string); -open Format; - -value rec action_arg s sl = - fun - [ Arg.Unit f -> if s = "" then do { f (); Some sl } else None - | Arg.Bool f -> - if s = "" then - match sl with - [ [s :: sl] -> - try do { f (bool_of_string s); Some sl } with - [ Invalid_argument "bool_of_string" -> None ] - | [] -> None ] - else - try do { f (bool_of_string s); Some sl } with - [ Invalid_argument "bool_of_string" -> None ] - | Arg.Set r -> if s = "" then do { r.val := True; Some sl } else None - | Arg.Clear r -> if s = "" then do { r.val := False; Some sl } else None - | Arg.Rest f -> do { List.iter f [s :: sl]; Some [] } - | Arg.String f -> - if s = "" then - match sl with - [ [s :: sl] -> do { f s; Some sl } - | [] -> None ] - else do { f s; Some sl } - | Arg.Set_string r -> - if s = "" then - match sl with - [ [s :: sl] -> do { r.val := s; Some sl } - | [] -> None ] - else do { r.val := s; Some sl } - | Arg.Int f -> - if s = "" then - match sl with - [ [s :: sl] -> - try do { f (int_of_string s); Some sl } with - [ Failure "int_of_string" -> None ] - | [] -> None ] - else - try do { f (int_of_string s); Some sl } with - [ Failure "int_of_string" -> None ] - | Arg.Set_int r -> - if s = "" then - match sl with - [ [s :: sl] -> - try do { r.val := (int_of_string s); Some sl } with - [ Failure "int_of_string" -> None ] - | [] -> None ] - else - try do { r.val := (int_of_string s); Some sl } with - [ Failure "int_of_string" -> None ] - | Arg.Float f -> - if s = "" then - match sl with - [ [s :: sl] -> do { f (float_of_string s); Some sl } - | [] -> None ] - else do { f (float_of_string s); Some sl } - | Arg.Set_float r -> - if s = "" then - match sl with - [ [s :: sl] -> do { r.val := (float_of_string s); Some sl } - | [] -> None ] - else do { r.val := (float_of_string s); Some sl } - | Arg.Tuple specs -> - let rec action_args s sl = - fun - [ [] -> Some sl - | [spec :: spec_list] -> - match action_arg s sl spec with - [ None -> action_args "" [] spec_list - | Some [s :: sl] -> action_args s sl spec_list - | Some sl -> action_args "" sl spec_list - ] - ] in - action_args s sl specs - | Arg.Symbol syms f -> - match (if s = "" then sl else [s :: sl]) with - [ [s :: sl] when List.mem s syms -> do { f s; Some sl } - | _ -> None ] - ]; - -value common_start s1 s2 = - loop 0 where rec loop i = - if i == String.length s1 || i == String.length s2 then i - else if s1.[i] == s2.[i] then loop (i + 1) - else i; - -value parse_arg fold s sl = - fold - (fun (name, action, _) acu -> - let i = common_start s name in - if i == String.length name then - try action_arg (String.sub s i (String.length s - i)) sl action with - [ Arg.Bad _ -> acu ] - else acu) None; - -value rec parse_aux fold anon_fun = - fun - [ [] -> [] - | [s :: sl] -> - if String.length s > 1 && s.[0] = '-' then - match parse_arg fold s sl with - [ Some sl -> parse_aux fold anon_fun sl - | None -> [s :: parse_aux fold anon_fun sl] ] - else do { (anon_fun s : unit); parse_aux fold anon_fun sl } ]; - -value align_doc key s = - let s = - loop 0 where rec loop i = - if i = String.length s then "" - else if s.[i] = ' ' then loop (i + 1) - else String.sub s i (String.length s - i) - in - let (p, s) = - if String.length s > 0 then - if s.[0] = '<' then - loop 0 where rec loop i = - if i = String.length s then ("", s) - else if s.[i] <> '>' then loop (i + 1) - else - let p = String.sub s 0 (i + 1) in - loop (i + 1) where rec loop i = - if i >= String.length s then (p, "") - else if s.[i] = ' ' then loop (i + 1) - else (p, String.sub s i (String.length s - i)) - else ("", s) - else ("", "") - in - let tab = - String.make (max 1 (16 - String.length key - String.length p)) ' ' - in - p ^ tab ^ s; - -value make_symlist l = - match l with - [ [] -> "" - | [h::t] -> (List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t) ^ "}" ]; - -value print_usage_list l = - List.iter - (fun (key, spec, doc) -> - match spec with - [ Arg.Symbol symbs _ -> - let s = make_symlist symbs in - let synt = key ^ " " ^ s in - eprintf " %s %s\n" synt (align_doc synt doc) - | _ -> eprintf " %s %s\n" key (align_doc key doc) ] ) - l; - -value remaining_args argv = - let rec loop l i = - if i == Array.length argv then l else loop [argv.(i) :: l] (i + 1) - in - List.rev (loop [] (Arg.current.val + 1)); - -value init_spec_list = ref []; -value ext_spec_list = ref []; - -value init spec_list = init_spec_list.val := spec_list; - -value add name spec descr = - ext_spec_list.val := [(name, spec, descr) :: ext_spec_list.val]; - -value fold f init = - let spec_list = init_spec_list.val @ ext_spec_list.val in - let specs = Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) spec_list in - List.fold_right f specs init; - -value parse anon_fun argv = - let remaining_args = remaining_args argv in - parse_aux fold anon_fun remaining_args; - -value ext_spec_list () = ext_spec_list.val; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Options.mli ocaml-4.02.3/camlp4/Camlp4/Options.mli --- ocaml-4.01.0/camlp4/Camlp4/Options.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Options.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,26 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -type spec_list = list (string * Arg.spec * string); -value init : spec_list -> unit; -value add : string -> Arg.spec -> string -> unit; - (** Add an option to the command line options. *) -value print_usage_list : spec_list -> unit; -value ext_spec_list : unit -> spec_list; -value parse : (string -> unit) -> array string -> list string; diff -Nru ocaml-4.01.0/camlp4/Camlp4/PreCast.ml ocaml-4.02.3/camlp4/Camlp4/PreCast.ml --- ocaml-4.01.0/camlp4/Camlp4/PreCast.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/PreCast.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,67 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Id = struct - value name = "Camlp4.PreCast"; - value version = Sys.ocaml_version; -end; - -type camlp4_token = Sig.camlp4_token == - [ KEYWORD of string - | SYMBOL of string - | LIDENT of string - | UIDENT of string - | ESCAPED_IDENT of string - | INT of int and string - | INT32 of int32 and string - | INT64 of int64 and string - | NATIVEINT of nativeint and string - | FLOAT of float and string - | CHAR of char and string - | STRING of string and string - | LABEL of string - | OPTLABEL of string - | QUOTATION of Sig.quotation - | ANTIQUOT of string and string - | COMMENT of string - | BLANKS of string - | NEWLINE - | LINE_DIRECTIVE of int and option string - | EOI ]; - -module Loc = Struct.Loc; -module Ast = Struct.Camlp4Ast.Make Loc; -module Token = Struct.Token.Make Loc; -module Lexer = Struct.Lexer.Make Token; -module Gram = Struct.Grammar.Static.Make Lexer; -module DynLoader = Struct.DynLoader; -module Quotation = Struct.Quotation.Make Ast; -module MakeSyntax (U : sig end) = OCamlInitSyntax.Make Ast Gram Quotation; -module Syntax = MakeSyntax (struct end); -module AstFilters = Struct.AstFilters.Make Ast; -module MakeGram = Struct.Grammar.Static.Make; - -module Printers = struct - module OCaml = Printers.OCaml.Make Syntax; - module OCamlr = Printers.OCamlr.Make Syntax; - (* module OCamlrr = Printers.OCamlrr.Make Syntax; *) - module DumpOCamlAst = Printers.DumpOCamlAst.Make Syntax; - module DumpCamlp4Ast = Printers.DumpCamlp4Ast.Make Syntax; - module Null = Printers.Null.Make Syntax; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/PreCast.mli ocaml-4.02.3/camlp4/Camlp4/PreCast.mli --- ocaml-4.01.0/camlp4/Camlp4/PreCast.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/PreCast.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,76 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -type camlp4_token = Sig.camlp4_token == - [ KEYWORD of string - | SYMBOL of string - | LIDENT of string - | UIDENT of string - | ESCAPED_IDENT of string - | INT of int and string - | INT32 of int32 and string - | INT64 of int64 and string - | NATIVEINT of nativeint and string - | FLOAT of float and string - | CHAR of char and string - | STRING of string and string - | LABEL of string - | OPTLABEL of string - | QUOTATION of Sig.quotation - | ANTIQUOT of string and string - | COMMENT of string - | BLANKS of string - | NEWLINE - | LINE_DIRECTIVE of int and option string - | EOI ]; - -module Id : Sig.Id; -module Loc : Sig.Loc; -module Ast : Sig.Camlp4Ast with module Loc = Loc; -module Token : Sig.Token - with module Loc = Loc - and type t = camlp4_token; -module Lexer : Sig.Lexer - with module Loc = Loc - and module Token = Token; -module Gram : Sig.Grammar.Static - with module Loc = Loc - and module Token = Token; -module Quotation : Sig.Quotation with module Ast = Sig.Camlp4AstToAst Ast; -module DynLoader : Sig.DynLoader; -module AstFilters : Sig.AstFilters with module Ast = Ast; -module Syntax : Sig.Camlp4Syntax - with module Loc = Loc - and module Token = Token - and module Ast = Ast - and module Gram = Gram - and module Quotation = Quotation; - -module Printers : sig - module OCaml : (Sig.Printer Ast).S; - module OCamlr : (Sig.Printer Ast).S; - module DumpOCamlAst : (Sig.Printer Ast).S; - module DumpCamlp4Ast : (Sig.Printer Ast).S; - module Null : (Sig.Printer Ast).S; -end; - -module MakeGram (Lexer : Sig.Lexer with module Loc = Loc) - : Sig.Grammar.Static with module Loc = Loc and module Token = Lexer.Token; - -module MakeSyntax (U : sig end) : Sig.Syntax; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml ocaml-4.02.3/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml --- ocaml-4.01.0/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,51 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Id = struct - value name = "Camlp4Printers.DumpCamlp4Ast"; - value version = Sys.ocaml_version; -end; - -module Make (Syntax : Sig.Syntax) -: (Sig.Printer Syntax.Ast).S -= struct - include Syntax; - - value with_open_out_file x f = - match x with - [ 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 } ]; - - value dump_ast magic ast oc = do { - output_string oc magic; - output_value oc ast; - }; - - value print_interf ?input_file:(_) ?output_file ast = - with_open_out_file output_file - (dump_ast Camlp4_config.camlp4_ast_intf_magic_number ast); - - value print_implem ?input_file:(_) ?output_file ast = - with_open_out_file output_file - (dump_ast Camlp4_config.camlp4_ast_impl_magic_number ast); - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli ocaml-4.02.3/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli --- ocaml-4.01.0/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,21 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Id : Sig.Id; - -module Make (Syntax : Sig.Syntax) : (Sig.Printer Syntax.Ast).S; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/DumpOCamlAst.ml ocaml-4.02.3/camlp4/Camlp4/Printers/DumpOCamlAst.ml --- ocaml-4.01.0/camlp4/Camlp4/Printers/DumpOCamlAst.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Printers/DumpOCamlAst.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,53 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Id : Sig.Id = struct - value name = "Camlp4Printers.DumpOCamlAst"; - value version = Sys.ocaml_version; -end; - -module Make (Syntax : Sig.Camlp4Syntax) -: (Sig.Printer Syntax.Ast).S -= struct - include Syntax; - module Ast2pt = Struct.Camlp4Ast2OCamlAst.Make Ast; - - value with_open_out_file x f = - match x with - [ 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 } ]; - - value dump_pt magic fname pt oc = do { - output_string oc magic; - output_value oc (if fname = "-" then "" else fname); - output_value oc pt; - }; - - value print_interf ?(input_file = "-") ?output_file ast = - let pt = Ast2pt.sig_item ast in - with_open_out_file output_file (dump_pt Camlp4_config.ocaml_ast_intf_magic_number input_file pt); - - value print_implem ?(input_file = "-") ?output_file ast = - let pt = Ast2pt.str_item ast in - with_open_out_file output_file (dump_pt Camlp4_config.ocaml_ast_impl_magic_number input_file pt); - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/DumpOCamlAst.mli ocaml-4.02.3/camlp4/Camlp4/Printers/DumpOCamlAst.mli --- ocaml-4.01.0/camlp4/Camlp4/Printers/DumpOCamlAst.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Printers/DumpOCamlAst.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,21 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Id : Sig.Id; - -module Make (Syntax : Sig.Camlp4Syntax) : (Sig.Printer Syntax.Ast).S; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/Null.ml ocaml-4.02.3/camlp4/Camlp4/Printers/Null.ml --- ocaml-4.01.0/camlp4/Camlp4/Printers/Null.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Printers/Null.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,30 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Id = struct - value name = "Camlp4.Printers.Null"; - value version = Sys.ocaml_version; -end; - -module Make (Syntax : Sig.Syntax) = struct - include Syntax; - - value print_interf ?input_file:(_) ?output_file:(_) _ = (); - value print_implem ?input_file:(_) ?output_file:(_) _ = (); -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/Null.mli ocaml-4.02.3/camlp4/Camlp4/Printers/Null.mli --- ocaml-4.01.0/camlp4/Camlp4/Printers/Null.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Printers/Null.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,22 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Id : Sig.Id; - -module Make (Syntax : Sig.Syntax) : (Sig.Printer Syntax.Ast).S; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/OCaml.ml ocaml-4.02.3/camlp4/Camlp4/Printers/OCaml.ml --- ocaml-4.01.0/camlp4/Camlp4/Printers/OCaml.ml 2013-08-30 13:39:33.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Printers/OCaml.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,1156 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -open Format; - -module Id = struct - value name = "Camlp4.Printers.OCaml"; - value version = Sys.ocaml_version; -end; - -module Make (Syntax : Sig.Camlp4Syntax) = struct - include Syntax; - - type sep = format unit formatter unit; - type fun_binding = [= `patt of Ast.patt | `newtype of string ]; - - value pp = fprintf; - value cut f = fprintf f "@ "; - - value list' elt sep sep' f = - let rec loop = - fun - [ [] -> () - | [x::xs] -> do { pp f sep ; elt f x; pp f sep'; loop xs } ] in - fun - [ [] -> () - | [x] -> do { elt f x; pp f sep' } - | [x::xs] -> do { elt f x; pp f sep'; loop xs } ]; - - value list elt sep f = - let rec loop = - fun - [ [] -> () - | [x::xs] -> do { pp f sep ; elt f x; loop xs } ] in - fun - [ [] -> () - | [x] -> elt f x - | [x::xs] -> do { elt f x; loop xs } ]; - - value rec list_of_meta_list = - fun - [ Ast.LNil -> [] - | Ast.LCons x xs -> [x :: list_of_meta_list xs] - | Ast.LAnt _ -> assert False ]; - - value meta_list elt sep f mxs = - let xs = list_of_meta_list mxs in - list elt sep f xs; - - module CommentFilter = Struct.CommentFilter.Make Token; - value comment_filter = CommentFilter.mk (); - CommentFilter.define (Gram.get_filter ()) comment_filter; - - 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 infix_lidents StringSet.empty - in fun s -> (StringSet.mem s infixes - || (s <> "" && List.mem s.[0] first_chars)); - - value is_keyword = - let keywords = (* without infix_lidents *) - List.fold_right StringSet.add - ["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; - - module Lexer = Struct.Lexer.Make Token; - let module M = ErrorHandler.Register Lexer.Error in (); - open Sig; - value lexer s = - Lexer.from_string ~quotations:Camlp4_config.quotations.val Loc.ghost s; - value lex_string str = - try match lexer str with parser - [: `(tok, _); `(EOI, _) :] -> tok - with - [ Stream.Failure | Stream.Error _ -> - failwith (sprintf - "Cannot print %S this string contains more than one token" str) - | Lexer.Error.E exn -> - failwith (sprintf - "Cannot print %S this identifier does not respect OCaml lexing rules (%s)" - str (Lexer.Error.to_string exn)) ]; - - (* This is to be sure character literals are always escaped. *) - value ocaml_char x = Char.escaped (Struct.Token.Eval.char x); - - value rec get_expr_args a al = - match a with - [ <:expr< $a1$ $a2$ >> -> get_expr_args a1 [a2 :: al] - | _ -> (a, al) ]; - - value rec get_patt_args a al = - match a with - [ <:patt< $a1$ $a2$ >> -> get_patt_args a1 [a2 :: al] - | _ -> (a, al) ]; - - value rec get_ctyp_args a al = - match a with - [ <:ctyp< $a1$ $a2$ >> -> get_ctyp_args a1 [a2 :: al] - | _ -> (a, al) ]; - - value is_irrefut_patt = Ast.is_irrefut_patt; - - value rec expr_fun_args = - fun - [ <:expr< fun $p$ -> $e$ >> as ge -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - ([`patt p :: pl], e) - else ([], ge) - | <:expr< fun (type $i$) -> $e$ >> -> - let (pl, e) = expr_fun_args e in - ([`newtype i :: pl], e) - | ge -> ([], ge) ]; - - value rec class_expr_fun_args = - fun - [ <:class_expr< fun $p$ -> $ce$ >> as ge -> - if is_irrefut_patt p then - let (pl, ce) = class_expr_fun_args ce in - ([p :: pl], ce) - else ([], ge) - | ge -> ([], ge) ]; - - value rec do_print_comments_before loc f = - parser - [ [: ` (comm, comm_loc) when Loc.strictly_before comm_loc loc; s :] -> - let () = f comm comm_loc in - do_print_comments_before loc f s - | [: :] -> () ]; - - class printer ?curry_constr:(init_curry_constr = False) ?(comments = True) () = - object (o) - - (** pipe means we are under a match case (try, function) *) - value pipe = False; - value semi = False; - - method under_pipe = {< pipe = True >}; - method under_semi = {< semi = True >}; - method reset_semi = {< semi = False >}; - method reset = {< pipe = False; semi = False >}; - - value semisep : sep = ";;"; - value no_semisep : sep = ""; (* used to mark where ";;" should not occur *) - value mode = if comments then `comments else `no_comments; - value curry_constr = init_curry_constr; - value var_conversion = False; - - method andsep : sep = "@]@ @[<2>and@ "; - method value_val = "val"; - method value_let = "let"; - - method semisep = semisep; - method set_semisep s = {< semisep = s >}; - method set_comments b = {< mode = if b then `comments else `no_comments >}; - method set_loc_and_comments = {< mode = `loc_and_comments >}; - method set_curry_constr b = {< curry_constr = b >}; - - method print_comments_before loc f = - match mode with - [ `comments -> - do_print_comments_before loc (fun c _ -> pp f "%s@ " c) - (CommentFilter.take_stream comment_filter) - | `loc_and_comments -> - let () = pp f "(*loc: %a*)@ " Loc.dump loc in - do_print_comments_before loc - (fun s -> pp f "%s(*comm_loc: %a*)@ " s Loc.dump) - (CommentFilter.take_stream comment_filter) - | _ -> () ]; - - method var f = - fun - [ "" -> pp f "$lid:\"\"$" - | "[]" -> pp f "[]" - | "()" -> pp f "()" - | " True" -> pp f "True" - | " False" -> pp f "False" - | v -> - match (var_conversion, v) with - [ (True, "val") -> pp f "contents" - | (True, "True") -> pp f "true" - | (True, "False") -> pp f "false" - | _ -> - match lex_string v with - [ (LIDENT s | UIDENT s | ESCAPED_IDENT s) when is_keyword 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 -> - pp_print_string f s - | tok -> failwith (sprintf - "Bad token used as an identifier: %s" - (Token.to_string tok)) ] ] ]; - - method type_params f = - fun - [ [] -> () - | [x] -> pp f "%a@ " o#ctyp x - | l -> pp f "@[<1>(%a)@]@ " (list o#ctyp ",@ ") l ]; - - method class_params f = - fun - [ <:ctyp< $t1$, $t2$ >> -> - pp f "@[<1>%a,@ %a@]" o#class_params t1 o#class_params t2 - | x -> o#ctyp f x ]; - - method override_flag f = - fun - [ Ast.OvOverride -> pp f "!" - | Ast.OvNil -> () - | Ast.OvAnt s -> o#anti f s ]; - - method mutable_flag f = fun - [ Ast.MuMutable -> pp f "mutable@ " - | Ast.MuNil -> () - | Ast.MuAnt s -> o#anti f s ]; - - method rec_flag f = fun - [ Ast.ReRecursive -> pp f "rec@ " - | Ast.ReNil -> () - | Ast.ReAnt s -> o#anti f s ]; - - method virtual_flag f = fun - [ Ast.ViVirtual -> pp f "virtual@ " - | Ast.ViNil -> () - | Ast.ViAnt s -> o#anti f s ]; - - method private_flag f = fun - [ Ast.PrPrivate -> pp f "private@ " - | Ast.PrNil -> () - | Ast.PrAnt s -> o#anti f s ]; - - method anti f s = pp f "$%s$" s; - - method seq f = - fun - [ <:expr< $e1$; $e2$ >> -> - pp f "%a;@ %a" o#under_semi#seq e1 o#seq e2 - | <:expr< do { $e$ } >> -> - o#seq f e - | e -> o#expr f e ]; - - (* FIXME when the Format module will fixed. - pp_print_if_newline f (); - pp_print_string f "| "; *) - method match_case f = - fun - [ <:match_case@_loc<>> -> - pp f "@[<2>@ _ ->@ %a@]" o#raise_match_failure _loc - | a -> o#match_case_aux f a ]; - - method match_case_aux f = - fun - [ <:match_case<>> -> () - | <:match_case< $anti:s$ >> -> o#anti f s - | <:match_case< $a1$ | $a2$ >> -> - pp f "%a%a" o#match_case_aux a1 o#match_case_aux a2 - | <:match_case< $p$ -> $e$ >> -> - pp f "@ | @[<2>%a@ ->@ %a@]" o#patt p o#under_pipe#expr e - | <:match_case< $p$ when $w$ -> $e$ >> -> - pp f "@ | @[<2>%a@ when@ %a@ ->@ %a@]" - o#patt p o#under_pipe#expr w o#under_pipe#expr e ]; - - method fun_binding f = - fun - [ `patt p -> o#simple_patt f p - | `newtype i -> pp f "(type %s)" i ]; - - method binding f bi = - let () = o#node f bi Ast.loc_of_binding in - match bi with - [ <:binding<>> -> () - | <:binding< $b1$ and $b2$ >> -> - do { o#binding f b1; pp f o#andsep; o#binding f b2 } - | <:binding< $p$ = $e$ >> -> - let (pl, e') = - match p with - [ <:patt< ($_$ : $_$) >> -> ([], e) - | _ -> expr_fun_args e ] in - match (p, e') with - [ (<:patt< $lid:_$ >>, <:expr< ($e'$ : $t$) >>) -> - pp f "%a :@ %a =@ %a" - (list o#fun_binding "@ ") [`patt p::pl] o#ctyp t o#expr e' - | (<:patt< $lid:_$ >>, _) -> - pp f "%a @[<0>%a=@]@ %a" o#simple_patt - p (list' o#fun_binding "" "@ ") pl o#expr e' - | _ -> - pp f "%a =@ %a" o#simple_patt p o#expr e ] - | <:binding< $anti:s$ >> -> o#anti f s ]; - - method record_binding f bi = - let () = o#node f bi Ast.loc_of_rec_binding in - match bi with - [ <:rec_binding<>> -> () - | <:rec_binding< $i$ = $e$ >> -> - pp f "@ @[<2>%a =@ %a@];" o#var_ident i o#expr e - | <:rec_binding< $b1$ ; $b2$ >> -> - do { o#under_semi#record_binding f b1; - o#under_semi#record_binding f b2 } - | <:rec_binding< $anti:s$ >> -> o#anti f s ]; - - method mk_patt_list = - fun - [ <:patt< [$p1$ :: $p2$] >> -> - let (pl, c) = o#mk_patt_list p2 in - ([p1 :: pl], c) - | <:patt< [] >> -> ([], None) - | p -> ([], Some p) ]; - - method mk_expr_list = - fun - [ <:expr< [$e1$ :: $e2$] >> -> - let (el, c) = o#mk_expr_list e2 in - ([e1 :: el], c) - | <:expr< [] >> -> ([], None) - | e -> ([], Some e) ]; - - method expr_list f = - fun - [ [] -> pp f "[]" - | [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 - match c with - [ None -> o#expr_list f el - | Some x -> - (if simple then pp f "@[<2>(%a)@]" else pp f "@[<2>%a@]") - (list o#under_semi#dot_expr " ::@ ") (el @ [x]) ]; - - method patt_expr_fun_args f (p, e) = - let (pl, e) = expr_fun_args e - in pp f "%a@ ->@ %a" (list o#fun_binding "@ ") [p::pl] o#expr e; - - method patt_class_expr_fun_args f (p, ce) = - let (pl, ce) = class_expr_fun_args ce - in pp f "%a =@]@ %a" (list o#simple_patt "@ ") [p::pl] o#class_expr ce; - - method constrain f (t1, t2) = - pp f "@[<2>constraint@ %a =@ %a@]" o#ctyp t1 o#ctyp t2; - - method sum_type f t = - match Ast.list_of_ctyp t [] with - [ [] -> () - | ts -> - pp f "@[| %a@]" (list o#constructor_declaration "@ | ") ts ]; - - method private constructor_declaration f t = - match t with - [ <:ctyp< $t1$ : $t2$ -> $t3$ >> -> pp f "@[<2>%a :@ @[<2>%a@ ->@ %a@]@]" o#ctyp t1 o#constructor_type t2 o#ctyp t3 - | t -> o#ctyp f t ]; - - method string f = pp f "%s"; - method quoted_string f = pp f "%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 - [ <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> - o#module_expr_get_functor_args [(s, mt)::accu] me - | <:module_expr< ($me$ : $mt$) >> -> (List.rev accu, me, Some mt) - | me -> (List.rev accu, me, None) ]; - - method functor_args f = list o#functor_arg "@ " f; - - method functor_arg f (s, mt) = - pp f "@[<2>(%a :@ %a)@]" o#var s o#module_type mt; - - method module_rec_binding f = - fun - [ <:module_binding<>> -> () - | <:module_binding< $s$ : $mt$ = $me$ >> -> - pp f "@[<2>%a :@ %a =@ %a@]" - o#var s o#module_type mt o#module_expr me - | <:module_binding< $s$ : $mt$ >> -> - pp f "@[<2>%a :@ %a@]" o#var s o#module_type mt - | <:module_binding< $mb1$ and $mb2$ >> -> - do { o#module_rec_binding f mb1; - pp f o#andsep; - o#module_rec_binding f mb2 } - | <:module_binding< $anti:s$ >> -> o#anti f s ]; - - method class_declaration f = - fun - [ <:class_expr< ( $ce$ : $ct$ ) >> -> - pp f "%a :@ %a" o#class_expr ce o#class_type ct - | ce -> o#class_expr f ce ]; - - method raise_match_failure f _loc = - let n = Loc.file_name _loc in - let l = Loc.start_line _loc in - let c = Loc.start_off _loc - Loc.start_bol _loc in - o#expr f <:expr< raise (Match_failure $`str:n$ $`int:l$ $`int:c$) >>; - - method node : ! 'a . formatter -> 'a -> ('a -> Loc.t) -> unit = - fun f node loc_of_node -> - o#print_comments_before (loc_of_node node) f; - - method ident f i = - let () = o#node f i Ast.loc_of_ident in - match i with - [ <:ident< $i1$.$i2$ >> -> pp f "%a.@,%a" o#ident i1 o#ident i2 - | <:ident< $i1$ $i2$ >> -> pp f "%a@,(%a)" o#ident i1 o#ident i2 - | <:ident< $anti:s$ >> -> o#anti f s - | <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> o#var f s ]; - - method private var_ident = {< var_conversion = True >}#ident; - - method expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ ((<:expr< let $rec:_$ $_$ in $_$ >> | - <:expr< let module $_$ = $_$ in $_$ >>) as e) when semi -> - pp f "(%a)" o#reset#expr e - | ((<:expr< match $_$ with [ $_$ ] >> | - <:expr< try $_$ with [ $_$ ] >> | - <:expr< fun [ $_$ ] >>) as e) when pipe || semi -> - pp f "(%a)" o#reset#expr e - - | <: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#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 - | <:expr< $x$ $y$ >> -> - let (a, al) = get_expr_args x [y] in - if (not curry_constr) && Ast.is_expr_constructor a then - match al with - [ [ <:expr< ($tup:_$) >> ] -> - pp f "@[<2>%a@ (%a)@]" o#apply_expr x o#expr y - | [_] -> pp f "@[<2>%a@ %a@]" o#apply_expr x o#apply_expr y - | al -> - pp f "@[<2>%a@ (%a)@]" o#apply_expr a - (* The #apply_expr below may put too much parens. - However using #expr would be wrong: PR#5056. *) - (list o#under_pipe#apply_expr ",@ ") al ] - else pp f "@[<2>%a@]" (list o#apply_expr "@ ") [a::al] - | <:expr< $e1$.val := $e2$ >> -> - pp f "@[<2>%a :=@ %a@]" o#dot_expr e1 o#expr e2 - | <:expr< $e1$ := $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 -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`patt p, e) - | <:expr< fun (type $i$) -> $e$ >> -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`newtype i, e) - | <:expr< fun [ $a$ ] >> -> - pp f "@[function%a@]" o#match_case a - | <:expr< if $e1$ then $e2$ else $e3$ >> -> - pp f "@[@[<2>if@ %a@]@ @[<2>then@ %a@]@ @[<2>else@ %a@]@]" - o#expr e1 o#under_semi#expr e2 o#under_semi#expr e3 - | <:expr< lazy $e$ >> -> pp f "@[<2>lazy@ %a@]" o#simple_expr e - | <:expr< let $rec:r$ $bi$ in $e$ >> -> - match e with - [ <:expr< let $rec:_$ $_$ in $_$ >> -> - pp f "@[<0>@[<2>let %a%a in@]@ %a@]" - o#rec_flag r o#binding bi o#reset_semi#expr e - | _ -> - pp f "@[@[<2>let %a%a@]@ @[in@ %a@]@]" - o#rec_flag r o#binding bi o#reset_semi#expr e ] - | <:expr< let open $i$ in $e$ >> -> - pp f "@[<2>let open %a@]@ @[<2>in@ %a@]" - o#ident i o#reset_semi#expr e - | <:expr< match $e$ with [ $a$ ] >> -> - pp f "@[@[@[<2>match %a@]@ with@]%a@]" - o#expr e o#match_case a - | <:expr< try $e$ with [ $a$ ] >> -> - pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" - o#expr e o#match_case a - | <: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#reset_semi#expr e - | <:expr< object $cst$ end >> -> - pp f "@[@[object@ %a@]@ end@]" o#class_str_item cst - | <:expr< object ($p$ : $t$) $cst$ end >> -> - pp f "@[@[object @[<1>(%a :@ %a)@]@ %a@]@ end@]" - o#patt p o#ctyp t o#class_str_item cst - | <:expr< object ($p$) $cst$ end >> -> - pp f "@[@[object @[<2>(%a)@]@ %a@]@ end@]" - o#patt p o#class_str_item cst - | e -> o#apply_expr f e ]; - - method apply_expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ <:expr< new $i$ >> -> pp f "@[<2>new@ %a@]" o#ident i - | e -> o#dot_expr f e ]; - - method dot_expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ <:expr< $e$.val >> -> pp f "@[<2>!@,%a@]" o#simple_expr e - | <:expr< $e1$ . $e2$ >> -> pp f "@[<2>%a.@,%a@]" o#dot_expr e1 o#dot_expr e2 - | <:expr< $e1$ .( $e2$ ) >> -> - pp f "@[<2>%a.@,(%a)@]" o#dot_expr e1 o#expr e2 - | <:expr< $e1$ .[ $e2$ ] >> -> - pp f "%a.@[<1>[@,%a@]@,]" o#dot_expr e1 o#expr e2 - | <:expr< $e$ # $s$ >> -> pp f "@[<2>%a#@,%s@]" o#dot_expr e s - | e -> o#simple_expr f e ]; - - method simple_expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ <:expr<>> -> () - | <:expr< do { $e$ } >> -> - pp f "@[(%a)@]" o#seq e - | <:expr< [$_$ :: $_$] >> -> o#expr_list_cons True f e - | <:expr< ( $tup:e$ ) >> -> - pp f "@[<1>(%a)@]" o#expr e - | <:expr< [| $e$ |] >> -> - pp f "@[<0>@[<2>[|@ %a@]@ |]@]" o#under_semi#expr e - | <:expr< ($e$ :> $t$) >> -> - pp f "@[<2>(%a :>@ %a)@]" o#expr e o#ctyp t - | <:expr< ($e$ : $t1$ :> $t2$) >> -> - pp f "@[<2>(%a :@ %a :>@ %a)@]" o#expr e o#ctyp t1 o#ctyp t2 - | <:expr< ($e$ : $t$) >> -> - pp f "@[<2>(%a :@ %a)@]" o#expr e o#ctyp t - | <:expr< $anti:s$ >> -> o#anti f s - | <: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$ >> -> 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$ } >> -> - pp f "@[@[{%a@]@ }@]" o#record_binding b - | <:expr< { ($e$) with $b$ } >> -> - pp f "@[@[{@ (%a)@ with%a@]@ }@]" - o#expr e o#record_binding b - | <:expr< $str:s$ >> -> pp f "\"%s\"" s - | <:expr< while $e1$ do { $e2$ } >> -> - pp f "@[<2>while@ %a@ do@ %a@ done@]" o#expr e1 o#seq e2 - | <:expr< ~ $s$ >> -> pp f "~%s" s - | <:expr< ~ $s$ : $e$ >> -> pp f "@[<2>~%s:@ %a@]" s o#dot_expr e - | <:expr< ? $s$ >> -> pp f "?%s" s - | <:expr< ? $s$ : $e$ >> -> pp f "@[<2>?%s:@ %a@]" s o#dot_expr e - | <:expr< ` $lid:s$ >> -> pp f "`%a" o#var s - | <:expr< {< $b$ >} >> -> - pp f "@[@[{<%a@]@ >}@]" o#record_binding b - | <:expr< $e1$, $e2$ >> -> - pp f "%a,@ %a" o#simple_expr e1 o#simple_expr e2 - | <:expr< $e1$; $e2$ >> -> - pp f "%a;@ %a" o#under_semi#expr e1 o#expr e2 - | <:expr< (module $me$ : $mt$) >> -> - pp f "@[@[(module %a : %a@])@]" - o#module_expr me o#module_type mt - | <:expr< (module $me$) >> -> - pp f "@[@[(module %a@])@]" o#module_expr me - | <:expr< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> | - <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> | - <:expr< $_$ # $_$ >> | - <:expr< fun [ $_$ ] >> | <:expr< fun (type $_$) -> $_$ >> | <:expr< match $_$ with [ $_$ ] >> | - <:expr< try $_$ with [ $_$ ] >> | - <:expr< if $_$ then $_$ else $_$ >> | - <:expr< let $rec:_$ $_$ in $_$ >> | - <:expr< let module $_$ = $_$ in $_$ >> | - <:expr< let open $_$ in $_$ >> | - <:expr< assert $_$ >> | <:expr< assert False >> | - <:expr< lazy $_$ >> | <:expr< new $_$ >> | - <:expr< object ($_$) $_$ end >> -> - pp f "(%a)" o#reset#expr e ]; - - method direction_flag f b = - match b with - [ Ast.DiTo -> pp_print_string f "to" - | Ast.DiDownto -> pp_print_string f "downto" - | Ast.DiAnt s -> o#anti f s ]; - - method patt f p = - let () = o#node f p Ast.loc_of_patt in match p with - [ <:patt< ( $p1$ as $p2$ ) >> -> pp f "@[<1>(%a@ as@ %a)@]" o#patt p1 o#patt p2 - | <:patt< $i$ = $p$ >> -> pp f "@[<2>%a =@ %a@]" o#var_ident i o#patt p - | <:patt< $p1$; $p2$ >> -> pp f "%a;@ %a" o#patt p1 o#patt p2 - | p -> o#patt1 f p ]; - - method patt1 f = fun - [ <:patt< $p1$ | $p2$ >> -> pp f "@[<2>%a@ |@ %a@]" o#patt1 p1 o#patt2 p2 - | p -> o#patt2 f p ]; - - method patt2 f = fun - [ (* <:patt< ( $tup:p$ ) >> -> pp f "@[<1>(%a)@]" o#patt3 p - | *) p -> o#patt3 f p ]; - - method patt3 f = fun - [ <:patt< $p1$ .. $p2$ >> -> pp f "@[<2>%a@ ..@ %a@]" o#patt3 p1 o#patt4 p2 - | <:patt< $p1$, $p2$ >> -> pp f "%a,@ %a" o#patt3 p1 o#patt3 p2 - | p -> o#patt4 f p ]; - - method patt4 f = fun - [ <:patt< [$_$ :: $_$] >> as p -> - let (pl, c) = o#mk_patt_list p in - match c with - [ None -> pp f "@[<2>[@ %a@]@ ]" (list o#patt ";@ ") pl - | Some x -> pp f "@[<2>%a@]" (list o#patt5 " ::@ ") (pl @ [x]) ] - | p -> o#patt5 f p ]; - - method patt5 f = fun - [ <:patt< [$_$ :: $_$] >> as p -> o#simple_patt f p - | <:patt< lazy $p$ >> -> - pp f "@[<2>lazy %a@]" o#simple_patt p - | <:patt< $x$ $y$ >> -> - let (a, al) = get_patt_args x [y] in - 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 ] - | p -> o#simple_patt f p ]; - - method simple_patt f p = - let () = o#node f p Ast.loc_of_patt in - match p with - [ <:patt<>> -> () - | <:patt< $id:i$ >> -> o#var_ident f i - | <:patt< $anti:s$ >> -> o#anti f s - | <:patt< _ >> -> pp f "_" - | <:patt< ( module $m$ ) >> -> pp f "(module %s)" m - | <:patt< ( $tup:p$ ) >> -> pp f "@[<1>(%a)@]" o#patt3 p - | <: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$ >> -> 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 - | <:patt< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i - | <:patt< [| $p$ |] >> -> pp f "@[<2>[|@ %a@]@ |]" o#patt p - | <: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_tycon p - | <:patt< ? $s$ : ($p$) >> -> - pp f "@[<2>?%s:@,@[<1>(%a)@]@]" s o#patt_tycon p - | <:patt< ?($p$ = $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_tycon p o#expr e - | <:patt< $_$ $_$ >> | <:patt< ($_$ as $_$) >> | <:patt< $_$ | $_$ >> | - <:patt< $_$ .. $_$ >> | <:patt< $_$, $_$ >> | - <:patt< $_$; $_$ >> | <:patt< $_$ = $_$ >> | <:patt< lazy $_$ >> 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 - [ <:ctyp< $id:i$ >> -> o#ident f i - | <:ctyp< $anti:s$ >> -> o#anti f s - | <:ctyp< _ >> -> pp f "_" - | Ast.TyAnP _ -> pp f "+_" - | Ast.TyAnM _ -> pp f "-_" - | <:ctyp< ~ $s$ : $t$ >> -> pp f "@[<2>%s:@ %a@]" s o#simple_ctyp t - | <:ctyp< ? $s$ : $t$ >> -> pp f "@[<2>?%s:@ %a@]" s o#simple_ctyp t - | <:ctyp< < > >> -> pp f "< >" - | <:ctyp< < .. > >> -> pp f "< .. >" - | <:ctyp< < $t$ .. > >> -> pp f "@[<0>@[<2><@ %a;@ ..@]@ >@]" o#ctyp t - | <:ctyp< < $t$ > >> -> pp f "@[<0>@[<2><@ %a@]@ >@]" o#ctyp t - | <:ctyp< '$s$ >> -> pp f "'%a" o#var s - | <: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< (module $mt$) >> -> pp f "@[<2>(module@ %a@])" o#module_type mt - | <:ctyp< [ = $t$ ] >> -> pp f "@[<2>[@ %a@]@ ]" o#sum_type t - | <:ctyp< [ < $t$ ] >> -> pp f "@[<2>[<@ %a@]@,]" o#sum_type t - | <:ctyp< [ < $t1$ > $t2$ ] >> -> - 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< `$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 = - let () = o#node f t Ast.loc_of_ctyp in - match t with - [ <:ctyp< $t1$ as $t2$ >> -> pp f "@[<2>%a@ as@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2 - | <:ctyp< $t1$ -> $t2$ >> -> pp f "@[<2>%a@ ->@ %a@]" o#ctyp1 t1 o#ctyp t2 - | <:ctyp< +'$s$ >> -> pp f "+'%a" o#var s - | <:ctyp< -'$s$ >> -> pp f "-'%a" o#var s - | <:ctyp< $t1$ | $t2$ >> -> pp f "%a@ | %a" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t1$ : mutable $t2$ >> -> - pp f "@[mutable@ %a :@ %a@]" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t1$ : $t2$ >> -> pp f "@[<2>%a :@ %a@]" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t1$; $t2$ >> -> pp f "%a;@ %a" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t$ of $<:ctyp<>>$ >> -> o#ctyp f t - | <:ctyp< $t1$ of $t2$ >> -> - pp f "@[%a@ @[<3>of@ %a@]@]" o#ctyp t1 o#constructor_type t2 - | <:ctyp< $t1$ of & $t2$ >> -> - pp f "@[%a@ @[<3>of &@ %a@]@]" o#ctyp t1 o#constructor_type t2 - | <:ctyp< $t1$ and $t2$ >> -> pp f "%a@ and %a" o#ctyp t1 o#ctyp t2 - | <:ctyp< mutable $t$ >> -> pp f "@[<2>mutable@ %a@]" o#ctyp t - | <:ctyp< $t1$ & $t2$ >> -> pp f "%a@ &@ %a" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t1$ == $t2$ >> -> - pp f "@[<2>%a =@ %a@]" o#simple_ctyp t1 o#ctyp t2 - | Ast.TyDcl _ tn tp te cl -> do { - pp f "@[<2>%a%a@]" o#type_params tp o#var tn; - match te with - [ <:ctyp<>> -> () - | _ -> pp f " =@ %a" o#ctyp te ]; - if cl <> [] then pp f "@ %a" (list o#constrain "@ ") cl else (); - } - | t -> o#ctyp1 f t ]; - - method ctyp1 f = fun - [ <:ctyp< $t1$ $t2$ >> -> - match get_ctyp_args t1 [t2] with - [ (_, [_]) -> pp f "@[<2>%a@ %a@]" o#simple_ctyp t2 o#simple_ctyp t1 - | (a, al) -> pp f "@[<2>(%a)@ %a@]" (list o#ctyp ",@ ") al o#simple_ctyp a ] - | <:ctyp< ! $t1$ . $t2$ >> -> - let (a, al) = get_ctyp_args t1 [] in - pp f "@[<2>%a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2 - | Ast.TyTypePol (_,t1,t2) -> - let (a, al) = get_ctyp_args t1 [] in - pp f "@[<2>type %a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2 - | <:ctyp< private $t$ >> -> pp f "@[private@ %a@]" o#simple_ctyp t - | t -> o#simple_ctyp f t ]; - - method constructor_type f t = - match t with - [ <:ctyp@loc< $t1$ and $t2$ >> -> - let () = o#node f t (fun _ -> loc) in - pp f "%a@ * %a" o#constructor_type t1 o#constructor_type t2 - | <:ctyp< $_$ -> $_$ >> -> pp f "(%a)" o#ctyp t - | t -> o#ctyp f t ]; - - - method sig_item f sg = - let () = o#node f sg Ast.loc_of_sig_item in - match sg with - [ <:sig_item<>> -> () - | <:sig_item< $sg$; $<:sig_item<>>$ >> | - <:sig_item< $<:sig_item<>>$; $sg$ >> -> - o#sig_item f sg - | <: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%(%)@]" o#ctyp t semisep - | <:sig_item< external $s$ : $t$ = $sl$ >> -> - 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 = - fun - [ <:module_type< functor ($s$ : $mt1$) -> $mt2$ >> -> - 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%(%)@]" - o#var s1 o#functor_args al o#module_type mt semisep - | <:sig_item< module $s$ : $mt$ >> -> - 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%(%)@]" o#var s semisep - | <:sig_item< module type $s$ = $mt$ >> -> - pp f "@[<2>module type %a =@ %a%(%)@]" - o#var s o#module_type mt semisep - | <:sig_item< open $sl$ >> -> - pp f "@[<2>open@ %a%(%)@]" o#ident sl semisep - | <:sig_item< type $t$ >> -> - pp f "@[@[type %a@]%(%)@]" o#ctyp t semisep - | <:sig_item< value $s$ : $t$ >> -> - pp f "@[<2>%s %a :@ %a%(%)@]" - o#value_val o#var s o#ctyp t semisep - | <:sig_item< include $mt$ >> -> - pp f "@[<2>include@ %a%(%)@]" o#module_type mt semisep - | <:sig_item< class type $ct$ >> -> - pp f "@[<2>class type %a%(%)@]" o#class_type ct semisep - | <:sig_item< class $ce$ >> -> - pp f "@[<2>class %a%(%)@]" o#class_type ce semisep - | <:sig_item< module rec $mb$ >> -> - pp f "@[<2>module rec %a%(%)@]" - o#module_rec_binding mb semisep - | <:sig_item< # $_$ $_$ >> -> () - | <:sig_item< $anti:s$ >> -> - pp f "%a%(%)" o#anti s semisep ]; - - method str_item f st = - let () = o#node f st Ast.loc_of_str_item in - match st with - [ <:str_item<>> -> () - | <:str_item< $st$; $<:str_item<>>$ >> | - <:str_item< $<:str_item<>>$; $st$ >> -> - o#str_item f st - | <: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%(%)@]" o#ctyp t semisep - | <:str_item< exception $t$ = $sl$ >> -> - 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%(%)@]" - 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%(%)@]" - 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%(%)@]" - 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%(%)@]" - o#var s o#module_type mt o#module_expr me semisep - | <:str_item< module $s$ = $me$ >> -> - 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%(%)@]" - o#var s o#module_type mt semisep - | <:str_item< open $sl$ >> -> - pp f "@[<2>open@ %a%(%)@]" o#ident sl semisep - | <:str_item< type $t$ >> -> - pp f "@[@[type %a@]%(%)@]" o#ctyp t semisep - | <:str_item< value $rec:r$ $bi$ >> -> - pp f "@[<2>%s %a%a%(%)@]" o#value_let o#rec_flag r o#binding bi semisep - | <:str_item< $exp:e$ >> -> - pp f "@[<2>let _ =@ %a%(%)@]" o#expr e semisep - | <:str_item< include $me$ >> -> - pp f "@[<2>include@ %a%(%)@]" o#simple_module_expr me semisep - | <:str_item< class type $ct$ >> -> - pp f "@[<2>class type %a%(%)@]" o#class_type ct semisep - | <:str_item< class $ce$ >> -> - pp f "@[class %a%(%)@]" o#class_declaration ce semisep - | <:str_item< module rec $mb$ >> -> - pp f "@[<2>module rec %a%(%)@]" o#module_rec_binding mb semisep - | <:str_item< # $_$ $_$ >> -> () - | <:str_item< $anti:s$ >> -> pp f "%a%(%)" o#anti s semisep - | Ast.StExc _ _ (Ast.OAnt _) -> assert False ]; - - method module_type f mt = - let () = o#node f mt Ast.loc_of_module_type in - match mt with - [ <:module_type<>> -> assert False - | <:module_type< module type of $me$ >> -> - pp f "@[<2>module type of@ %a@]" o#module_expr me - | <:module_type< $id:i$ >> -> o#ident f i - | <:module_type< $anti:s$ >> -> o#anti f s - | <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> -> - pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" - o#var s o#module_type mt1 o#module_type mt2 - | <:module_type< '$s$ >> -> pp f "'%a" o#var s - | <:module_type< sig $sg$ end >> -> - pp f "@[@[sig@ %a@]@ end@]" o#sig_item sg - | <:module_type< $mt$ with $wc$ >> -> - pp f "@[<2>%a@ with@ %a@]" o#module_type mt o#with_constraint wc ]; - - method with_constraint f wc = - let () = o#node f wc Ast.loc_of_with_constr in - match wc with - [ <:with_constr<>> -> () - | <:with_constr< type $t1$ = $t2$ >> -> - pp f "@[<2>type@ %a =@ %a@]" o#ctyp t1 o#ctyp t2 - | <:with_constr< module $i1$ = $i2$ >> -> - pp f "@[<2>module@ %a =@ %a@]" o#ident i1 o#ident i2 - | <:with_constr< type $t1$ := $t2$ >> -> - pp f "@[<2>type@ %a :=@ %a@]" o#ctyp t1 o#ctyp t2 - | <:with_constr< module $i1$ := $i2$ >> -> - pp f "@[<2>module@ %a :=@ %a@]" o#ident i1 o#ident i2 - | <:with_constr< $wc1$ and $wc2$ >> -> - do { o#with_constraint f wc1; pp f o#andsep; o#with_constraint f wc2 } - | <:with_constr< $anti:s$ >> -> o#anti f s ]; - - method module_expr f me = - let () = o#node f me Ast.loc_of_module_expr in - match me with - [ <:module_expr<>> -> assert False - | <:module_expr< ( struct $st$ end : sig $sg$ end ) >> -> - pp f "@[<2>@[struct@ %a@]@ end :@ @[sig@ %a@]@ end@]" - o#str_item st o#sig_item sg - | _ -> o#simple_module_expr f me ]; - - method simple_module_expr f me = - let () = o#node f me Ast.loc_of_module_expr in - match me with - [ <:module_expr<>> -> assert False - | <:module_expr< $id:i$ >> -> o#ident f i - | <:module_expr< $anti:s$ >> -> o#anti f s - | <:module_expr< $me1$ $me2$ >> -> - pp f "@[<2>%a@,(%a)@]" o#module_expr me1 o#module_expr me2 - | <:module_expr< functor ( $s$ : $mt$ ) -> $me$ >> -> - pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" o#var s o#module_type mt o#module_expr me - | <:module_expr< struct $st$ end >> -> - pp f "@[@[struct@ %a@]@ end@]" o#str_item st - | <:module_expr< ( $me$ : $mt$ ) >> -> - pp f "@[<1>(%a :@ %a)@]" o#module_expr me o#module_type mt - | <:module_expr< (value $e$ : $mt$ ) >> -> - pp f "@[<1>(%s %a :@ %a)@]" o#value_val o#expr e o#module_type mt - | <:module_expr< (value $e$ ) >> -> - pp f "@[<1>(%s %a)@]" o#value_val o#expr e - ]; - - method class_expr f ce = - let () = o#node f ce Ast.loc_of_class_expr in - match ce with - [ <:class_expr< $ce$ $e$ >> -> - pp f "@[<2>%a@ %a@]" o#class_expr ce o#apply_expr e - | <:class_expr< $id:i$ >> -> - pp f "@[<2>%a@]" o#ident i - | <:class_expr< $id:i$ [ $t$ ] >> -> - pp f "@[<2>@[<1>[%a]@]@ %a@]" o#class_params t o#ident i - | <:class_expr< virtual $lid:i$ >> -> - pp f "@[<2>virtual@ %a@]" o#var i - | <:class_expr< virtual $lid:i$ [ $t$ ] >> -> - pp f "@[<2>virtual@ @[<1>[%a]@]@ %a@]" o#class_params t o#var i - | <:class_expr< fun $p$ -> $ce$ >> -> - pp f "@[<2>fun@ %a@ ->@ %a@]" o#simple_patt p o#class_expr ce - | <:class_expr< let $rec:r$ $bi$ in $ce$ >> -> - pp f "@[<2>let %a%a@]@ @[<2>in@ %a@]" - o#rec_flag r o#binding bi o#class_expr ce - | <:class_expr< object $cst$ end >> -> - pp f "@[@[object %a@]@ end@]" o#class_str_item cst - | <:class_expr< object ($p$) $cst$ end >> -> - pp f "@[@[object @[<1>(%a)@]@ %a@]@ end@]" - o#patt p o#class_str_item cst - | <:class_expr< ( $ce$ : $ct$ ) >> -> - pp f "@[<1>(%a :@ %a)@]" o#class_expr ce o#class_type ct - | <:class_expr< $anti:s$ >> -> o#anti f s - | <:class_expr< $ce1$ and $ce2$ >> -> - do { o#class_expr f ce1; pp f o#andsep; o#class_expr f ce2 } - | <:class_expr< $ce1$ = fun $p$ -> $ce2$ >> when is_irrefut_patt p -> - pp f "@[<2>%a@ %a" o#class_expr ce1 - o#patt_class_expr_fun_args (p, ce2) - | <:class_expr< $ce1$ = $ce2$ >> -> - pp f "@[<2>%a =@]@ %a" o#class_expr ce1 o#class_expr ce2 - | _ -> assert False ]; - - method class_type f ct = - let () = o#node f ct Ast.loc_of_class_type in - match ct with - [ <:class_type< $id:i$ >> -> - pp f "@[<2>%a@]" o#ident i - | <:class_type< $id:i$ [ $t$ ] >> -> - pp f "@[<2>[@,%a@]@,]@ %a" o#class_params t o#ident i - | <:class_type< virtual $lid:i$ >> -> - pp f "@[<2>virtual@ %a@]" o#var i - | <:class_type< virtual $lid:i$ [ $t$ ] >> -> - pp f "@[<2>virtual@ [@,%a@]@,]@ %a" o#class_params t o#var i - | <:class_type< [ $t$ ] -> $ct$ >> -> - pp f "@[<2>%a@ ->@ %a@]" o#simple_ctyp t o#class_type ct - | <:class_type< object $csg$ end >> -> - pp f "@[@[object@ %a@]@ end@]" o#class_sig_item csg - | <:class_type< object ($t$) $csg$ end >> -> - pp f "@[@[object @[<1>(%a)@]@ %a@]@ end@]" - o#ctyp t o#class_sig_item csg - | <:class_type< $anti:s$ >> -> o#anti f s - | <:class_type< $ct1$ and $ct2$ >> -> - do { o#class_type f ct1; pp f o#andsep; o#class_type f ct2 } - | <:class_type< $ct1$ : $ct2$ >> -> - pp f "%a :@ %a" o#class_type ct1 o#class_type ct2 - | <:class_type< $ct1$ = $ct2$ >> -> - pp f "%a =@ %a" o#class_type ct1 o#class_type ct2 - | _ -> assert False ]; - - method class_sig_item f csg = - let () = o#node f csg Ast.loc_of_class_sig_item in - match csg with - [ <:class_sig_item<>> -> () - | <:class_sig_item< $csg$; $<:class_sig_item<>>$ >> | - <:class_sig_item< $<:class_sig_item<>>$; $csg$ >> -> - 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< constraint $t1$ = $t2$ >> -> - pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep - | <:class_sig_item< inherit $ct$ >> -> - pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct no_semisep - | <:class_sig_item< method $private:pr$ $s$ : $t$ >> -> - pp f "@[<2>method %a%a :@ %a%(%)@]" o#private_flag pr o#var s - o#ctyp t no_semisep - | <:class_sig_item< method virtual $private:pr$ $s$ : $t$ >> -> - pp f "@[<2>method virtual %a%a :@ %a%(%)@]" - o#private_flag pr o#var s o#ctyp t no_semisep - | <:class_sig_item< value $mutable:mu$ $virtual:vi$ $s$ : $t$ >> -> - pp f "@[<2>%s %a%a%a :@ %a%(%)@]" - o#value_val o#mutable_flag mu o#virtual_flag vi o#var s o#ctyp t - no_semisep - | <:class_sig_item< $anti:s$ >> -> - pp f "%a%(%)" o#anti s no_semisep ]; - - method class_str_item f cst = - let () = o#node f cst Ast.loc_of_class_str_item in - match cst with - [ <:class_str_item<>> -> () - | <:class_str_item< $cst$; $<:class_str_item<>>$ >> | - <:class_str_item< $<:class_str_item<>>$; $cst$ >> -> - 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< constraint $t1$ = $t2$ >> -> - pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep - | <:class_str_item< inherit $override:ov$ $ce$ >> -> - pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov o#class_expr ce no_semisep - | <:class_str_item< inherit $override:ov$ $ce$ as $lid:s$ >> -> - pp f "@[<2>inherit%a@ %a as@ %a%(%)@]" o#override_flag ov o#class_expr ce o#var s no_semisep - | <:class_str_item< initializer $e$ >> -> - pp f "@[<2>initializer@ %a%(%)@]" o#expr e no_semisep - | <:class_str_item< method $override:ov$ $private:pr$ $s$ = $e$ >> -> - pp f "@[<2>method%a %a%a =@ %a%(%)@]" - o#override_flag ov o#private_flag pr o#var s o#expr e no_semisep - | <:class_str_item< method $override:ov$ $private:pr$ $s$ : $t$ = $e$ >> -> - pp f "@[<2>method%a %a%a :@ %a =@ %a%(%)@]" - o#override_flag ov o#private_flag pr o#var s o#ctyp t o#expr e no_semisep - | <:class_str_item< method virtual $private:pr$ $s$ : $t$ >> -> - pp f "@[<2>method virtual@ %a%a :@ %a%(%)@]" - o#private_flag pr o#var s o#ctyp t no_semisep - | <:class_str_item< value virtual $mutable:mu$ $s$ : $t$ >> -> - pp f "@[<2>%s virtual %a%a :@ %a%(%)@]" - o#value_val o#mutable_flag mu o#var s o#ctyp t no_semisep - | <:class_str_item< value $override:ov$ $mutable:mu$ $s$ = $e$ >> -> - pp f "@[<2>%s%a %a%a =@ %a%(%)@]" - o#value_val o#override_flag ov o#mutable_flag mu o#var s o#expr e no_semisep - | <:class_str_item< $anti:s$ >> -> - pp f "%a%(%)" o#anti s no_semisep ]; - - method implem f st = - match st with - [ <: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; - end; - - value with_outfile output_file fct arg = - let call close f = do { - try fct f arg with [ exn -> do { close (); raise exn } ]; - close () - } in - match output_file with - [ None -> call (fun () -> ()) std_formatter - | Some s -> - let oc = open_out s in - let f = formatter_of_out_channel oc in - call (fun () -> close_out oc) f ]; - - value print output_file fct = - let o = new printer () in - with_outfile output_file (fct o); - - value print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg; - - value print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st; - -end; - -module MakeMore (Syntax : Sig.Camlp4Syntax) -: (Sig.Printer Syntax.Ast).S -= struct - - include Make Syntax; - - value semisep : ref sep = ref ("@\n" : sep); - value margin = ref 78; - value comments = ref True; - value locations = ref False; - value curry_constr = ref False; - - value print output_file fct = - let o = new printer ~comments:comments.val - ~curry_constr:curry_constr.val () 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 -> - let () = Format.pp_set_margin f margin.val in - Format.fprintf f "@[%a@]@." (fct o)); - - value print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg; - - 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.Unit (fun () -> semisep.val := ";;")) - " Print double semicolons."; - - Options.add "-no_ss" (Arg.Unit (fun () -> semisep.val := "")) - " 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."; - - Options.add "-add_locations" (Arg.Set locations) "Add locations as comment."; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/OCaml.mli ocaml-4.02.3/camlp4/Camlp4/Printers/OCaml.mli --- ocaml-4.01.0/camlp4/Camlp4/Printers/OCaml.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Printers/OCaml.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,167 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Id : Sig.Id; - -module Make (Syntax : Sig.Camlp4Syntax) : sig - open Format; - include Sig.Camlp4Syntax - with module Loc = Syntax.Loc - and module Token = Syntax.Token - and module Ast = Syntax.Ast - and module Gram = Syntax.Gram; - - type sep = format unit formatter unit; - type fun_binding = [= `patt of Ast.patt | `newtype of string ]; - - value list' : - (formatter -> 'a -> unit) -> - format 'b formatter unit -> - format unit formatter unit -> - formatter -> list 'a -> unit; - - value list : - (formatter -> 'a -> unit) -> - format 'b formatter unit -> - formatter -> list 'a -> unit; - - value lex_string : string -> Token.t; - value is_infix : string -> bool; - value is_keyword : string -> bool; - value ocaml_char : string -> string; - value get_expr_args : - Ast.expr -> list Ast.expr -> (Ast.expr * list Ast.expr); - value get_patt_args : - Ast.patt -> list Ast.patt -> (Ast.patt * list Ast.patt); - value get_ctyp_args : - Ast.ctyp -> list Ast.ctyp -> (Ast.ctyp * list Ast.ctyp); - value expr_fun_args : Ast.expr -> (list fun_binding * Ast.expr); - - (** - [new printer ~curry_constr:True ~comments:False] - Default values: curry_constr = False - comments = True - *) - class printer : - [?curry_constr: bool] -> [?comments: bool] -> [unit] -> - object ('a) - method interf : formatter -> Ast.sig_item -> unit; - method implem : formatter -> Ast.str_item -> unit; - method sig_item : formatter -> Ast.sig_item -> unit; - method str_item : formatter -> Ast.str_item -> unit; - - value pipe : bool; - value semi : bool; - value semisep : sep; - value no_semisep : sep; - method value_val : string; - method value_let : string; - method andsep : sep; - method anti : formatter -> string -> unit; - method class_declaration : - formatter -> Ast.class_expr -> unit; - method class_expr : formatter -> Ast.class_expr -> unit; - method class_sig_item : - formatter -> Ast.class_sig_item -> unit; - method class_str_item : - formatter -> Ast.class_str_item -> unit; - method class_type : formatter -> Ast.class_type -> unit; - method constrain : - formatter -> (Ast.ctyp * Ast.ctyp) -> unit; - method ctyp : formatter -> Ast.ctyp -> unit; - method ctyp1 : formatter -> Ast.ctyp -> unit; - method constructor_type : formatter -> Ast.ctyp -> unit; - method dot_expr : formatter -> Ast.expr -> unit; - method apply_expr : formatter -> Ast.expr -> unit; - method expr : formatter -> Ast.expr -> unit; - method expr_list : formatter -> list Ast.expr -> unit; - method expr_list_cons : bool -> formatter -> Ast.expr -> unit; - method fun_binding : formatter -> fun_binding -> unit; - method functor_arg : - formatter -> (string * Ast.module_type) -> unit; - method functor_args : - formatter -> - list (string * Ast.module_type) -> unit; - method ident : formatter -> Ast.ident -> unit; - method numeric : formatter -> string -> string -> unit; - method binding : formatter -> Ast.binding -> unit; - method record_binding : formatter -> Ast.rec_binding -> unit; - method match_case : formatter -> Ast.match_case -> unit; - method match_case_aux : formatter -> Ast.match_case -> unit; - method mk_expr_list : Ast.expr -> (list Ast.expr * option Ast.expr); - method mk_patt_list : Ast.patt -> (list Ast.patt * option Ast.patt); - method simple_module_expr : formatter -> Ast.module_expr -> unit; - method module_expr : formatter -> Ast.module_expr -> unit; - method module_expr_get_functor_args : - list (string * Ast.module_type) -> - Ast.module_expr -> - (list (string * Ast.module_type) * - Ast.module_expr * - option Ast.module_type); - method module_rec_binding : formatter -> Ast.module_binding -> unit; - method module_type : formatter -> Ast.module_type -> unit; - method override_flag : formatter -> Ast.override_flag -> unit; - method mutable_flag : formatter -> Ast.mutable_flag -> unit; - method direction_flag : formatter -> Ast.direction_flag -> unit; - method rec_flag : formatter -> Ast.rec_flag -> unit; - method node : formatter -> 'b -> ('b -> Loc.t) -> unit; - method patt : formatter -> Ast.patt -> unit; - method patt1 : formatter -> Ast.patt -> unit; - method patt2 : formatter -> Ast.patt -> unit; - method patt3 : formatter -> Ast.patt -> unit; - method patt4 : formatter -> Ast.patt -> unit; - method patt5 : formatter -> Ast.patt -> unit; - method patt_tycon : formatter -> Ast.patt -> unit; - method patt_expr_fun_args : - formatter -> (fun_binding * Ast.expr) -> unit; - method patt_class_expr_fun_args : - formatter -> (Ast.patt * Ast.class_expr) -> unit; - method print_comments_before : Loc.t -> formatter -> unit; - method private_flag : formatter -> Ast.private_flag -> unit; - method virtual_flag : formatter -> Ast.virtual_flag -> unit; - method quoted_string : formatter -> string -> unit; - method raise_match_failure : formatter -> Loc.t -> unit; - method reset : 'a; - method reset_semi : 'a; - method semisep : sep; - method set_comments : bool -> 'a; - method set_curry_constr : bool -> 'a; - method set_loc_and_comments : 'a; - method set_semisep : sep -> 'a; - method simple_ctyp : formatter -> Ast.ctyp -> unit; - method simple_expr : formatter -> Ast.expr -> unit; - method simple_patt : formatter -> Ast.patt -> unit; - method seq : formatter -> Ast.expr -> unit; - method string : formatter -> string -> unit; - method sum_type : formatter -> Ast.ctyp -> unit; - method type_params : formatter -> list Ast.ctyp -> unit; - method class_params : formatter -> Ast.ctyp -> unit; - method under_pipe : 'a; - method under_semi : 'a; - method var : formatter -> string -> unit; - method with_constraint : formatter -> Ast.with_constr -> unit; - end; - - value with_outfile : - option string -> (formatter -> 'a -> unit) -> 'a -> unit; - - value print : - option string -> (printer -> formatter -> 'a -> unit) -> 'a -> unit; -end; - -module MakeMore (Syntax : Sig.Camlp4Syntax) : (Sig.Printer Syntax.Ast).S; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/OCamlr.ml ocaml-4.02.3/camlp4/Camlp4/Printers/OCamlr.ml --- ocaml-4.01.0/camlp4/Camlp4/Printers/OCamlr.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Printers/OCamlr.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,324 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -open Format; - -module Id = struct - value name = "Camlp4.Printers.OCamlr"; - value version = Sys.ocaml_version; -end; - -module Make (Syntax : Sig.Camlp4Syntax) = struct - include Syntax; - open Sig; - - module PP_o = OCaml.Make Syntax; - - open PP_o; - - value pp = fprintf; - - value is_keyword = - let keywords = ["where"] - and not_keywords = ["false"; "function"; "true"; "val"] - in fun s -> not (List.mem s not_keywords) - && (is_keyword s || List.mem s keywords); - - class printer ?curry_constr:(init_curry_constr = True) ?(comments = True) () = - object (o) - inherit PP_o.printer ~curry_constr:init_curry_constr ~comments () as super; - - value! semisep : sep = ";"; - value! no_semisep : sep = ";"; - value mode = if comments then `comments else `no_comments; - value curry_constr = init_curry_constr; - value first_match_case = True; - - method andsep : sep = "@]@ @[<2>and@ "; - method value_val = "value"; - method value_let = "value"; - method under_pipe = o; - method under_semi = o; - method reset_semi = o; - method reset = o; - method private unset_first_match_case = {< first_match_case = False >}; - method private set_first_match_case = {< first_match_case = True >}; - - method seq f e = - let rec self right f e = - let go_right = self right and go_left = self False in - match e with - [ <:expr< let $rec:r$ $bi$ in $e1$ >> -> - if right then - pp f "@[<2>let %a%a@];@ %a" - o#rec_flag r o#binding bi go_right e1 - else - pp f "(%a)" o#expr e - | <:expr< do { $e$ } >> -> go_right f e - | <:expr< $e1$; $e2$ >> -> do { - pp f "%a;@ " go_left e1; - match (right, e2) with - [ (True, <:expr< let $rec:r$ $bi$ in $e3$ >>) -> - pp f "@[<2>let %a%a@];@ %a" - o#rec_flag r o#binding bi go_right e3 - | _ -> go_right f e2 ] } - | e -> o#expr f e ] - in self True f e; - - method var f = - fun - [ "" -> pp f "$lid:\"\"$" - | "[]" -> pp f "[]" - | "()" -> pp f "()" - | " True" -> pp f "True" - | " False" -> pp f "False" - | v -> - match lex_string v with - [ (LIDENT s | UIDENT s | ESCAPED_IDENT s) when is_keyword s -> - pp f "%s__" s - | SYMBOL s -> - pp f "( %s )" s - | LIDENT s | UIDENT s | ESCAPED_IDENT s -> - pp_print_string f s - | tok -> failwith (sprintf - "Bad token used as an identifier: %s" - (Token.to_string tok)) ] ]; - - method type_params f = - fun - [ [] -> () - | [x] -> pp f "@ %a" o#ctyp x - | l -> pp f "@ @[<1>%a@]" (list o#ctyp "@ ") l ]; - - method match_case f = - fun - [ <:match_case<>> -> pp f "@ []" - | m -> pp f "@ [ %a ]" o#set_first_match_case#match_case_aux m ]; - - method match_case_aux f = - fun - [ <:match_case<>> -> () - | <:match_case< $anti:s$ >> -> o#anti f s - | <:match_case< $a1$ | $a2$ >> -> - pp f "%a%a" o#match_case_aux a1 o#unset_first_match_case#match_case_aux a2 - | <:match_case< $p$ -> $e$ >> -> - let () = if first_match_case then () else pp f "@ | " in - pp f "@[<2>%a@ ->@ %a@]" o#patt p o#under_pipe#expr e - | <:match_case< $p$ when $w$ -> $e$ >> -> - let () = if first_match_case then () else pp f "@ | " in - pp f "@[<2>%a@ when@ %a@ ->@ %a@]" - o#patt p o#under_pipe#expr w o#under_pipe#expr e ]; - - method sum_type f = - fun - [ <:ctyp<>> -> pp f "[]" - | t -> pp f "@[[ %a ]@]" o#ctyp t - ]; - - method ident f i = - let () = o#node f i Ast.loc_of_ident in - match i with - [ <:ident< $i1$ $i2$ >> -> pp f "%a@ %a" o#dot_ident i1 o#dot_ident i2 - | i -> o#dot_ident f i ]; - - method private dot_ident f i = - let () = o#node f i Ast.loc_of_ident in - match i with - [ <:ident< $i1$.$i2$ >> -> pp f "%a.@,%a" o#dot_ident i1 o#dot_ident i2 - | <:ident< $anti:s$ >> -> o#anti f s - | <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> o#var f s - | i -> pp f "(%a)" o#ident i ]; - - method patt4 f = fun - [ <:patt< [$_$ :: $_$] >> as p -> - let (pl, c) = o#mk_patt_list p in - match c with - [ None -> pp f "@[<2>[@ %a@]@ ]" (list o#patt ";@ ") pl - | Some x -> pp f "@[<2>[ %a ::@ %a ]@]" (list o#patt ";@ ") pl o#patt x ] - | p -> super#patt4 f p ]; - - method expr_list_cons _ f e = - let (el, c) = o#mk_expr_list e in - match c with - [ None -> o#expr_list f el - | Some x -> pp f "@[<2>[ %a ::@ %a ]@]" (list o#expr ";@ ") el o#expr x ]; - - method expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ <:expr< $e1$ := $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 (`patt p, e) - | <:expr< fun (type $i$) -> $e$ >> -> - pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`newtype i, e) - | <:expr< fun [ $a$ ] >> -> - pp f "@[fun%a@]" o#match_case a - | <:expr< assert False >> -> pp f "@[<2>assert@ False@]" - | e -> super#expr f e ]; - - method dot_expr f e = - let () = o#node f e Ast.loc_of_expr in - match e with - [ <:expr< $e$.val >> -> pp f "@[<2>%a.@,val@]" o#simple_expr e - | e -> super#dot_expr f e ]; - - method ctyp f t = - let () = o#node f t Ast.loc_of_ctyp in - match t with - [ Ast.TyDcl _ tn tp te cl -> do { - pp f "@[<2>%a%a@]" o#var tn o#type_params tp; - match te with - [ <:ctyp<>> -> () - | _ -> pp f " =@ %a" o#ctyp te ]; - if cl <> [] then pp f "@ %a" (list o#constrain "@ ") cl else (); - } - | <:ctyp< $t1$ : mutable $t2$ >> -> - pp f "@[%a :@ mutable %a@]" o#ctyp t1 o#ctyp t2 - | <:ctyp< $t1$ == $t2$ >> -> - pp f "@[<2>%a ==@ %a@]" o#simple_ctyp t1 o#ctyp t2 - | t -> super#ctyp f t ]; - - method simple_ctyp f t = - let () = o#node f t Ast.loc_of_ctyp in - match t with - [ <:ctyp< [ = $t$ ] >> -> pp f "@[<2>[ =@ %a@]@ ]" o#ctyp t - | <:ctyp< [ < $t$ ] >> -> pp f "@[<2>[ <@ %a@]@,]" o#ctyp t - | <:ctyp< [ < $t1$ > $t2$ ] >> -> - pp f "@[<2>[ <@ %a@ >@ %a@]@ ]" o#ctyp t1 o#ctyp t2 - | <:ctyp< [ > $t$ ] >> -> pp f "@[<2>[ >@ %a@]@,]" o#ctyp t - | <:ctyp< $t1$ == $t2$ >> -> - pp f "@[<2>%a@ ==@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2 - | <:ctyp< ~ $s$ : $t$ >> -> pp f "@[<2>~%s:@ %a@]" s o#simple_ctyp t - | t -> super#simple_ctyp f t ]; - - method ctyp1 f = fun - [ <:ctyp< $t1$ $t2$ >> -> - match get_ctyp_args t1 [t2] with - [ (_, [_]) -> pp f "@[<2>%a@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2 - | (a, al) -> pp f "@[<2>%a@]" (list o#simple_ctyp "@ ") [a::al] ] - | <:ctyp< ! $t1$ . $t2$ >> -> - let (a, al) = get_ctyp_args t1 [] in - pp f "@[<2>! %a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2 - | t -> super#ctyp1 f t ]; - - method constructor_type f t = - match t with - [ <:ctyp@loc< $t1$ and $t2$ >> -> - let () = o#node f t (fun _ -> loc) in - pp f "%a@ and %a" o#constructor_type t1 o#constructor_type t2 - | t -> o#ctyp f t ]; - - method str_item f st = - match st with - [ <:str_item< $exp:e$ >> -> pp f "@[<2>%a%(%)@]" o#expr e semisep - | st -> super#str_item f st ]; - - method module_expr f me = - let () = o#node f me Ast.loc_of_module_expr in - match me with - [ <:module_expr< $me1$ $me2$ >> -> - pp f "@[<2>%a@ %a@]" o#module_expr me1 o#simple_module_expr me2 - | me -> super#module_expr f me ]; - - method simple_module_expr f me = - let () = o#node f me Ast.loc_of_module_expr in - match me with - [ <:module_expr< $_$ $_$ >> -> - pp f "(%a)" o#module_expr me - | _ -> super#simple_module_expr f me ]; - - method implem f st = pp f "@[%a@]@." o#str_item st; - - method class_type f ct = - let () = o#node f ct Ast.loc_of_class_type in - match ct with - [ <:class_type< [ $t$ ] -> $ct$ >> -> - pp f "@[<2>[ %a ] ->@ %a@]" o#simple_ctyp t o#class_type ct - | <:class_type< $id:i$ >> -> - pp f "@[<2>%a@]" o#ident i - | <:class_type< $id:i$ [ $t$ ] >> -> - pp f "@[<2>%a [@,%a@]@,]" o#ident i o#class_params t - | <:class_type< virtual $lid:i$ >> -> - pp f "@[<2>virtual@ %a@]" o#var i - | <:class_type< virtual $lid:i$ [ $t$ ] >> -> - pp f "@[<2>virtual@ %a@ [@,%a@]@,]" o#var i o#class_params t - | ct -> super#class_type f ct ]; - - method class_expr f ce = - let () = o#node f ce Ast.loc_of_class_expr in - match ce with - [ <:class_expr< $id:i$ >> -> - pp f "@[<2>%a@]" o#ident i - | <:class_expr< $id:i$ [ $t$ ] >> -> - pp f "@[<2>%a@ @[<1>[%a]@]@]" o#ident i o#class_params t - | <:class_expr< virtual $lid:i$ >> -> - pp f "@[<2>virtual@ %a@]" o#var i - | <:class_expr< virtual $lid:i$ [ $t$ ] >> -> - pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#var i o#class_params t - | ce -> super#class_expr f ce ]; - end; - - value with_outfile = with_outfile; - - value print output_file fct = - let o = new printer () in - with_outfile output_file (fct o); - - value print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg; - - value print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st; - -end; - -module MakeMore (Syntax : Sig.Camlp4Syntax) -: (Sig.Printer Syntax.Ast).S -= struct - - include Make Syntax; - - value margin = ref 78; - value comments = ref True; - value locations = ref False; - value curry_constr = ref True; - - value print output_file fct = - let o = new printer ~comments:comments.val - ~curry_constr:curry_constr.val () in - let o = if locations.val then o#set_loc_and_comments else o in - with_outfile output_file - (fun f -> - let () = Format.pp_set_margin f margin.val in - Format.fprintf f "@[%a@]@." (fct o)); - - value print_interf ?input_file:(_) ?output_file sg = - print output_file (fun o -> o#interf) sg; - - value print_implem ?input_file:(_) ?output_file st = - print output_file (fun o -> o#implem) st; - - Options.add "-l" (Arg.Int (fun i -> margin.val := i)) - " line length for pretty printing."; - - Options.add "-no_comments" (Arg.Clear comments) "Do not add comments."; - - Options.add "-add_locations" (Arg.Set locations) "Add locations as comment."; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers/OCamlr.mli ocaml-4.02.3/camlp4/Camlp4/Printers/OCamlr.mli --- ocaml-4.01.0/camlp4/Camlp4/Printers/OCamlr.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Printers/OCamlr.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,47 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Id : Sig.Id; - -module Make (Syntax : Sig.Camlp4Syntax) : sig - open Format; - include Sig.Camlp4Syntax - with module Loc = Syntax.Loc - and module Token = Syntax.Token - and module Ast = Syntax.Ast - and module Gram = Syntax.Gram; - - (** - [new printer ~curry_constr:c ~comments:False] - Default values: curry_constr = True - comments = True - *) - class printer : - [?curry_constr: bool] -> [?comments: bool] -> [unit] -> - object ('a) - inherit (OCaml.Make Syntax).printer; - end; - - value with_outfile : - option string -> (formatter -> 'a -> unit) -> 'a -> unit; - - value print : - option string -> (printer -> formatter -> 'a -> unit) -> 'a -> unit; -end; - -module MakeMore (Syntax : Sig.Camlp4Syntax) : (Sig.Printer Syntax.Ast).S; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Printers.mlpack ocaml-4.02.3/camlp4/Camlp4/Printers.mlpack --- ocaml-4.01.0/camlp4/Camlp4/Printers.mlpack 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Printers.mlpack 1970-01-01 01:00:00.000000000 +0100 @@ -1,5 +0,0 @@ -DumpCamlp4Ast -DumpOCamlAst -Null -OCaml -OCamlr diff -Nru ocaml-4.01.0/camlp4/Camlp4/Register.ml ocaml-4.02.3/camlp4/Camlp4/Register.ml --- ocaml-4.01.0/camlp4/Camlp4/Register.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Register.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,171 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module PP = Printers; -open PreCast; - -type parser_fun 'a = - ?directive_handler:('a -> option 'a) -> PreCast.Loc.t -> Stream.t char -> 'a; - -type printer_fun 'a = - ?input_file:string -> ?output_file:string -> 'a -> unit; - -value sig_item_parser = ref (fun ?directive_handler:(_) _ _ -> failwith "No interface parser"); -value str_item_parser = ref (fun ?directive_handler:(_) _ _ -> failwith "No implementation parser"); - -value sig_item_printer = ref (fun ?input_file:(_) ?output_file:(_) _ -> failwith "No interface printer"); -value str_item_printer = ref (fun ?input_file:(_) ?output_file:(_) _ -> failwith "No implementation printer"); - -value callbacks = Queue.create (); - -value loaded_modules = ref []; - -value iter_and_take_callbacks f = - let rec loop () = loop (f (Queue.take callbacks)) in - try loop () with [ Queue.Empty -> () ]; - -value declare_dyn_module m f = - begin - (* let () = Format.eprintf "declare_dyn_module: %s@." m in *) - loaded_modules.val := [ m :: loaded_modules.val ]; - Queue.add (m, f) callbacks; - end; - -value register_str_item_parser f = str_item_parser.val := f; -value register_sig_item_parser f = sig_item_parser.val := f; -value register_parser f g = - do { str_item_parser.val := f; sig_item_parser.val := g }; -value current_parser () = (str_item_parser.val, sig_item_parser.val); - -value register_str_item_printer f = str_item_printer.val := f; -value register_sig_item_printer f = sig_item_printer.val := f; -value register_printer f g = - do { str_item_printer.val := f; sig_item_printer.val := g }; -value current_printer () = (str_item_printer.val, sig_item_printer.val); - -module Plugin (Id : Sig.Id) (Maker : functor (Unit : sig end) -> sig end) = struct - declare_dyn_module Id.name (fun _ -> let module M = Maker (struct end) in ()); -end; - -module SyntaxExtension (Id : Sig.Id) (Maker : Sig.SyntaxExtension) = struct - declare_dyn_module Id.name (fun _ -> let module M = Maker Syntax in ()); -end; - -module OCamlSyntaxExtension - (Id : Sig.Id) (Maker : functor (Syn : Sig.Camlp4Syntax) -> Sig.Camlp4Syntax) = -struct - declare_dyn_module Id.name (fun _ -> let module M = Maker Syntax in ()); -end; - -module SyntaxPlugin (Id : Sig.Id) (Maker : functor (Syn : Sig.Syntax) -> sig end) = struct - declare_dyn_module Id.name (fun _ -> let module M = Maker Syntax in ()); -end; - -module Printer - (Id : Sig.Id) (Maker : functor (Syn : Sig.Syntax) - -> (Sig.Printer Syn.Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - let module M = Maker Syntax in - register_printer M.print_implem M.print_interf); -end; - -module OCamlPrinter - (Id : Sig.Id) (Maker : functor (Syn : Sig.Camlp4Syntax) - -> (Sig.Printer Syn.Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - let module M = Maker Syntax in - register_printer M.print_implem M.print_interf); -end; - -module OCamlPreCastPrinter - (Id : Sig.Id) (P : (Sig.Printer PreCast.Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - register_printer P.print_implem P.print_interf); -end; - -module Parser - (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) - -> (Sig.Parser Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - let module M = Maker PreCast.Ast in - register_parser M.parse_implem M.parse_interf); -end; - -module OCamlParser - (Id : Sig.Id) (Maker : functor (Ast : Sig.Camlp4Ast) - -> (Sig.Parser Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - let module M = Maker PreCast.Ast in - register_parser M.parse_implem M.parse_interf); -end; - -module OCamlPreCastParser - (Id : Sig.Id) (P : (Sig.Parser PreCast.Ast).S) = -struct - declare_dyn_module Id.name (fun _ -> - register_parser P.parse_implem P.parse_interf); -end; - -module AstFilter - (Id : Sig.Id) (Maker : functor (F : Sig.AstFilters) -> sig end) = -struct - declare_dyn_module Id.name (fun _ -> let module M = Maker AstFilters in ()); -end; - -sig_item_parser.val := Syntax.parse_interf; -str_item_parser.val := Syntax.parse_implem; - -module CurrentParser = struct - module Ast = Ast; - value parse_interf ?directive_handler loc strm = - sig_item_parser.val ?directive_handler loc strm; - value parse_implem ?directive_handler loc strm = - str_item_parser.val ?directive_handler loc strm; -end; - -module CurrentPrinter = struct - module Ast = Ast; - value print_interf ?input_file ?output_file ast = - sig_item_printer.val ?input_file ?output_file ast; - value print_implem ?input_file ?output_file ast = - str_item_printer.val ?input_file ?output_file ast; -end; - -value enable_ocaml_printer () = - let module M = OCamlPrinter PP.OCaml.Id PP.OCaml.MakeMore in (); - -value enable_ocamlr_printer () = - let module M = OCamlPrinter PP.OCamlr.Id PP.OCamlr.MakeMore in (); - -(* value enable_ocamlrr_printer () = - let module M = OCamlPrinter PP.OCamlrr.Id PP.OCamlrr.MakeMore in (); *) - -value enable_dump_ocaml_ast_printer () = - let module M = OCamlPrinter PP.DumpOCamlAst.Id PP.DumpOCamlAst.Make in (); - -value enable_dump_camlp4_ast_printer () = - let module M = Printer PP.DumpCamlp4Ast.Id PP.DumpCamlp4Ast.Make in (); - -value enable_null_printer () = - let module M = Printer PP.Null.Id PP.Null.Make in (); diff -Nru ocaml-4.01.0/camlp4/Camlp4/Register.mli ocaml-4.02.3/camlp4/Camlp4/Register.mli --- ocaml-4.01.0/camlp4/Camlp4/Register.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Register.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,95 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Plugin - (Id : Sig.Id) (Plugin : functor (Unit : sig end) -> sig end) : sig end; - -module SyntaxPlugin - (Id : Sig.Id) (SyntaxPlugin : functor (Syn : Sig.Syntax) -> sig end) : - sig end; - -module SyntaxExtension - (Id : Sig.Id) (SyntaxExtension : Sig.SyntaxExtension) : sig end; - -module OCamlSyntaxExtension - (Id : Sig.Id) - (SyntaxExtension : functor (Syntax : Sig.Camlp4Syntax) -> Sig.Camlp4Syntax) - : sig end; - -(** {6 Registering Parsers} *) - -type parser_fun 'a = - ?directive_handler:('a -> option 'a) -> PreCast.Loc.t -> Stream.t char -> 'a; - -value register_str_item_parser : parser_fun PreCast.Ast.str_item -> unit; -value register_sig_item_parser : parser_fun PreCast.Ast.sig_item -> unit; -value register_parser : parser_fun PreCast.Ast.str_item -> parser_fun PreCast.Ast.sig_item -> unit; -value current_parser : unit -> (parser_fun PreCast.Ast.str_item * parser_fun PreCast.Ast.sig_item); - -module Parser - (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> (Sig.Parser Ast).S) : sig end; - -module OCamlParser - (Id : Sig.Id) (Maker : functor (Ast : Sig.Camlp4Ast) -> (Sig.Parser Ast).S) : sig end; - -module OCamlPreCastParser - (Id : Sig.Id) (Parser : (Sig.Parser PreCast.Ast).S) : sig end; - -(** {6 Registering Printers} *) - -type printer_fun 'a = - ?input_file:string -> ?output_file:string -> 'a -> unit; - -value register_str_item_printer : printer_fun PreCast.Ast.str_item -> unit; -value register_sig_item_printer : printer_fun PreCast.Ast.sig_item -> unit; -value register_printer : printer_fun PreCast.Ast.str_item -> printer_fun PreCast.Ast.sig_item -> unit; -value current_printer : unit -> (printer_fun PreCast.Ast.str_item * printer_fun PreCast.Ast.sig_item); - -module Printer - (Id : Sig.Id) - (Maker : functor (Syn : Sig.Syntax) -> (Sig.Printer Syn.Ast).S) : - sig end; - -module OCamlPrinter - (Id : Sig.Id) - (Maker : functor (Syn : Sig.Camlp4Syntax) -> (Sig.Printer Syn.Ast).S) : - sig end; - -module OCamlPreCastPrinter - (Id : Sig.Id) (Printer : (Sig.Printer PreCast.Ast).S) : - sig end; - -(** {6 Registering Filters} *) - -module AstFilter - (Id : Sig.Id) (Maker : functor (F : Sig.AstFilters) -> sig end) : sig end; - -value declare_dyn_module : string -> (unit -> unit) -> unit; -value iter_and_take_callbacks : ((string * (unit -> unit)) -> unit) -> unit; -value loaded_modules : ref (list string); - -module CurrentParser : (Sig.Parser PreCast.Ast).S; -module CurrentPrinter : (Sig.Printer PreCast.Ast).S; - -value enable_ocaml_printer : unit -> unit; -value enable_ocamlr_printer : unit -> unit; -(* value enable_ocamlrr_printer : unit -> unit; *) -value enable_null_printer : unit -> unit; -value enable_dump_ocaml_ast_printer : unit -> unit; -value enable_dump_camlp4_ast_printer : unit -> unit; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Sig.ml ocaml-4.02.3/camlp4/Camlp4/Sig.ml --- ocaml-4.01.0/camlp4/Camlp4/Sig.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Sig.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,1445 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -(** Camlp4 signature repository *) - -(** {6 Basic signatures} *) - -(** Signature with just a type. *) -module type Type = sig - type t; -end; - -(** Signature for errors modules, an Error modules can be registred with - the {!ErrorHandler.Register} functor in order to be well printed. *) -module type Error = sig - type t; - exception E of t; - value to_string : t -> string; - value print : Format.formatter -> t -> unit; -end; - -(** A signature for extensions identifiers. *) -module type Id = sig - - (** The name of the extension, typically the module name. *) - value name : string; - - (** The version of the extension, typically $ Id$ 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 - - (** The type of locations. Note that, as for OCaml locations, - character numbers in locations refer to character numbers in the - parsed character stream, while line numbers refer to line - numbers in the source file. The source file and the parsed - character stream differ, for instance, when the parsed character - stream contains a line number directive. The line number - directive will only update the file-name field and the - line-number field of the position. It makes therefore no sense - to use character numbers with the source file if the sources - contain line number directives. *) - type t; - - (** Return a start location for the given file name. - This location starts at the begining of the file. *) - value mk : string -> t; - - (** The [ghost] location can be used when no location - information is available. *) - value ghost : t; - - (** {6 Conversion functions} *) - - (** Return a location where both positions are set the given position. *) - value of_lexing_position : Lexing.position -> t; - - (** Return an OCaml location. *) - value to_ocaml_location : t -> Camlp4_import.Location.t; - - (** Return a location from an OCaml location. *) - value of_ocaml_location : Camlp4_import.Location.t -> t; - - (** Return a location from ocamllex buffer. *) - value of_lexbuf : Lexing.lexbuf -> t; - - (** Return a location from [(file_name, start_line, start_bol, start_off, - stop_line, stop_bol, stop_off, ghost)]. *) - value of_tuple : (string * int * int * int * int * int * int * bool) -> t; - - (** Return [(file_name, start_line, start_bol, start_off, - stop_line, stop_bol, stop_off, ghost)]. *) - value to_tuple : t -> (string * int * int * int * int * int * int * bool); - - (** [merge loc1 loc2] Return a location that starts at [loc1] and end at - [loc2]. *) - value merge : t -> t -> t; - - (** The stop pos becomes equal to the start pos. *) - value join : t -> t; - - (** [move selector n loc] - Return the location where positions are moved. - Affected positions are chosen with [selector]. - Returned positions have their character offset plus [n]. *) - value move : [= `start | `stop | `both ] -> int -> t -> t; - - (** [shift n loc] Return the location where the new start position is the old - stop position, and where the new stop position character offset is the - old one plus [n]. *) - value shift : int -> t -> t; - - (** [move_line n loc] Return the location with the old line count plus [n]. - The "begin of line" of both positions become the current offset. *) - value move_line : int -> t -> t; - - (** {6 Accessors} *) - - (** Return the file name *) - value file_name : t -> string; - - (** Return the line number of the begining of this location. *) - value start_line : t -> int; - - (** Return the line number of the ending of this location. *) - value stop_line : t -> int; - - (** Returns the number of characters from the begining of the stream - to the begining of the line of location's begining. *) - value start_bol : t -> int; - - (** Returns the number of characters from the begining of the stream - to the begining of the line of location's ending. *) - value stop_bol : t -> int; - - (** Returns the number of characters from the begining of the stream - of the begining of this location. *) - value start_off : t -> int; - - (** Return the number of characters from the begining of the stream - of the ending of this location. *) - value stop_off : t -> int; - - (** Return the start position as a Lexing.position. *) - value start_pos : t -> Lexing.position; - - (** Return the stop position as a Lexing.position. *) - value stop_pos : t -> Lexing.position; - - (** Generally, return true if this location does not come - from an input stream. *) - value is_ghost : t -> bool; - - (** Return the associated ghost location. *) - value ghostify : t -> t; - - (** Return the location with the give file name *) - value set_file_name : string -> t -> t; - - (** [strictly_before loc1 loc2] True if the stop position of [loc1] is - strictly_before the start position of [loc2]. *) - value strictly_before : t -> t -> bool; - - (** Return the location with an absolute file name. *) - value make_absolute : t -> t; - - (** Print the location into the formatter in a format suitable for error - reporting. *) - value print : Format.formatter -> t -> unit; - - (** Print the location in a short format useful for debugging. *) - value dump : Format.formatter -> t -> unit; - - (** Same as {!print} but return a string instead of printting it. *) - value to_string : t -> string; - - (** [Exc_located loc e] is an encapsulation of the exception [e] with - the input location [loc]. To be used in quotation expanders - and in grammars to specify some input location for an error. - Do not raise this exception directly: rather use the following - function [Loc.raise]. *) - exception Exc_located of t and exn; - - (** [raise loc e], if [e] is already an [Exc_located] exception, - re-raise it, else raise the exception [Exc_located loc e]. *) - value raise : t -> exn -> 'a; - - (** The name of the location variable used in grammars and in - the predefined quotations for OCaml syntax trees. Default: [_loc]. *) - value name : ref string; - -end; - -(** Abstract syntax tree minimal signature. - Types of this signature are abstract. - See the {!Camlp4Ast} signature for a concrete definition. *) -module type Ast = sig - - (** {6 Syntactic categories as abstract types} *) - - type loc; - type meta_bool; - type meta_option 'a; - type meta_list 'a; - type ctyp; - type patt; - type expr; - type module_type; - type sig_item; - type with_constr; - type module_expr; - type str_item; - type class_type; - type class_sig_item; - type class_expr; - type class_str_item; - type match_case; - type ident; - type binding; - type rec_binding; - type module_binding; - type rec_flag; - type direction_flag; - type mutable_flag; - type private_flag; - type virtual_flag; - type row_var_flag; - type override_flag; - - (** {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: - - This example swap pairs expression contents: - open Camlp4.PreCast; - [class swap = object - inherit Ast.map as super; - method expr e = - match super#expr e with - \[ <:expr\@_loc< ($e1$, $e2$) >> -> <:expr< ($e2$, $e1$) >> - | e -> e \]; - end; - value _loc = Loc.ghost; - value map = (new swap)#expr; - assert (map <:expr< fun x -> (x, 42) >> = <:expr< fun x -> (42, x) >>);] - *) - 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 . ('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; - method str_item : str_item -> str_item; - method sig_item : sig_item -> sig_item; - - method module_expr : module_expr -> module_expr; - method module_type : module_type -> module_type; - method class_expr : class_expr -> class_expr; - method class_type : class_type -> class_type; - method class_sig_item : class_sig_item -> class_sig_item; - method class_str_item : class_str_item -> class_str_item; - method with_constr : with_constr -> with_constr; - method binding : binding -> binding; - method rec_binding : rec_binding -> rec_binding; - method module_binding : module_binding -> module_binding; - method match_case : match_case -> match_case; - method ident : ident -> ident; - method override_flag : override_flag -> override_flag; - method mutable_flag : mutable_flag -> mutable_flag; - method private_flag : private_flag -> private_flag; - method virtual_flag : virtual_flag -> virtual_flag; - method direction_flag : direction_flag -> direction_flag; - method rec_flag : rec_flag -> rec_flag; - method row_var_flag : row_var_flag -> row_var_flag; - - method unknown : ! 'a. 'a -> 'a; - end; - - (** Fold style traversal *) - class fold : object ('self_type) - method string : string -> 'self_type; - method list : ! 'a . ('self_type -> 'a -> 'self_type) -> list '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 : loc -> 'self_type; - method expr : expr -> 'self_type; - method patt : patt -> 'self_type; - method ctyp : ctyp -> 'self_type; - method str_item : str_item -> 'self_type; - method sig_item : sig_item -> 'self_type; - method module_expr : module_expr -> 'self_type; - method module_type : module_type -> 'self_type; - method class_expr : class_expr -> 'self_type; - method class_type : class_type -> 'self_type; - method class_sig_item : class_sig_item -> 'self_type; - method class_str_item : class_str_item -> 'self_type; - method with_constr : with_constr -> 'self_type; - method binding : binding -> 'self_type; - method rec_binding : rec_binding -> 'self_type; - method module_binding : module_binding -> 'self_type; - method match_case : match_case -> 'self_type; - method ident : ident -> 'self_type; - method rec_flag : rec_flag -> 'self_type; - method direction_flag : direction_flag -> 'self_type; - method mutable_flag : mutable_flag -> 'self_type; - method private_flag : private_flag -> 'self_type; - method virtual_flag : virtual_flag -> 'self_type; - method row_var_flag : row_var_flag -> 'self_type; - method override_flag : override_flag -> 'self_type; - - method unknown : ! 'a. 'a -> 'self_type; - end; - -end; - - -(** 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 - *) -module type Camlp4Ast = sig - - (** The inner module for locations *) - module Loc : Loc; - - INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml"; - - 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. - Generally it's _loc to match with <:patt< ... >> quotations. - The second location is the one to treat. *) - 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 -> loc -> expr; - end; - module MetaLoc : sig - value meta_loc_patt : loc -> loc -> patt; - value meta_loc_expr : loc -> loc -> expr; - end; - module MetaGhostLoc : sig - value meta_loc_patt : loc -> 'a -> patt; - value meta_loc_expr : loc -> 'a -> expr; - end; - module MetaLocVar : sig - 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 -> 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; - value meta_rec_flag : loc -> rec_flag -> expr; - value meta_mutable_flag : loc -> mutable_flag -> expr; - value meta_virtual_flag : loc -> virtual_flag -> expr; - value meta_private_flag : loc -> private_flag -> expr; - value meta_row_var_flag : loc -> row_var_flag -> expr; - value meta_override_flag : loc -> override_flag -> expr; - value meta_direction_flag : loc -> direction_flag -> expr; - end; - module Patt : sig - 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; - value meta_rec_flag : loc -> rec_flag -> patt; - value meta_mutable_flag : loc -> mutable_flag -> patt; - value meta_virtual_flag : loc -> virtual_flag -> patt; - value meta_private_flag : loc -> private_flag -> patt; - value meta_row_var_flag : loc -> row_var_flag -> patt; - value meta_override_flag : loc -> override_flag -> patt; - value meta_direction_flag : loc -> direction_flag -> patt; - end; - end; - end; - - (** See {!Ast.map}. *) - 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 . ('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; - method str_item : str_item -> str_item; - method sig_item : sig_item -> sig_item; - - method module_expr : module_expr -> module_expr; - method module_type : module_type -> module_type; - method class_expr : class_expr -> class_expr; - method class_type : class_type -> class_type; - method class_sig_item : class_sig_item -> class_sig_item; - method class_str_item : class_str_item -> class_str_item; - method with_constr : with_constr -> with_constr; - method binding : binding -> binding; - method rec_binding : rec_binding -> rec_binding; - method module_binding : module_binding -> module_binding; - method match_case : match_case -> match_case; - method ident : ident -> ident; - method mutable_flag : mutable_flag -> mutable_flag; - method private_flag : private_flag -> private_flag; - method virtual_flag : virtual_flag -> virtual_flag; - method direction_flag : direction_flag -> direction_flag; - method rec_flag : rec_flag -> rec_flag; - method row_var_flag : row_var_flag -> row_var_flag; - method override_flag : override_flag -> override_flag; - - method unknown : ! 'a. 'a -> 'a; - end; - - (** See {!Ast.fold}. *) - class fold : object ('self_type) - method string : string -> 'self_type; - method list : ! 'a . ('self_type -> 'a -> 'self_type) -> list '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 : loc -> 'self_type; - method expr : expr -> 'self_type; - method patt : patt -> 'self_type; - method ctyp : ctyp -> 'self_type; - method str_item : str_item -> 'self_type; - method sig_item : sig_item -> 'self_type; - method module_expr : module_expr -> 'self_type; - method module_type : module_type -> 'self_type; - method class_expr : class_expr -> 'self_type; - method class_type : class_type -> 'self_type; - method class_sig_item : class_sig_item -> 'self_type; - method class_str_item : class_str_item -> 'self_type; - method with_constr : with_constr -> 'self_type; - method binding : binding -> 'self_type; - method rec_binding : rec_binding -> 'self_type; - method module_binding : module_binding -> 'self_type; - method match_case : match_case -> 'self_type; - method ident : ident -> 'self_type; - method rec_flag : rec_flag -> 'self_type; - method direction_flag : direction_flag -> 'self_type; - method mutable_flag : mutable_flag -> 'self_type; - method private_flag : private_flag -> 'self_type; - method virtual_flag : virtual_flag -> 'self_type; - method row_var_flag : row_var_flag -> 'self_type; - method override_flag : override_flag -> 'self_type; - - method unknown : ! 'a. 'a -> 'self_type; - end; - - value map_expr : (expr -> expr) -> map; - value map_patt : (patt -> patt) -> map; - 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 -> loc) -> map; - - value ident_of_expr : expr -> ident; - value ident_of_patt : patt -> ident; - value ident_of_ctyp : ctyp -> ident; - - value biAnd_of_list : list binding -> binding; - value rbSem_of_list : list rec_binding -> rec_binding; - value paSem_of_list : list patt -> patt; - value paCom_of_list : list patt -> patt; - value tyOr_of_list : list ctyp -> ctyp; - value tyAnd_of_list : list ctyp -> ctyp; - value tyAmp_of_list : list ctyp -> ctyp; - value tySem_of_list : list ctyp -> ctyp; - value tyCom_of_list : list ctyp -> ctyp; - value tySta_of_list : list ctyp -> ctyp; - value stSem_of_list : list str_item -> str_item; - value sgSem_of_list : list sig_item -> sig_item; - value crSem_of_list : list class_str_item -> class_str_item; - value cgSem_of_list : list class_sig_item -> class_sig_item; - value ctAnd_of_list : list class_type -> class_type; - value ceAnd_of_list : list class_expr -> class_expr; - value wcAnd_of_list : list with_constr -> with_constr; - value meApp_of_list : list module_expr -> module_expr; - value mbAnd_of_list : list module_binding -> module_binding; - value mcOr_of_list : list match_case -> match_case; - value idAcc_of_list : list ident -> ident; - value idApp_of_list : list ident -> ident; - value exSem_of_list : list expr -> expr; - value exCom_of_list : list expr -> expr; - - value list_of_ctyp : ctyp -> list ctyp -> list ctyp; - value list_of_binding : binding -> list binding -> list binding; - value list_of_rec_binding : rec_binding -> list rec_binding -> list rec_binding; - value list_of_with_constr : with_constr -> list with_constr -> list with_constr; - value list_of_patt : patt -> list patt -> list patt; - value list_of_expr : expr -> list expr -> list expr; - value list_of_str_item : str_item -> list str_item -> list str_item; - value list_of_sig_item : sig_item -> list sig_item -> list sig_item; - value list_of_class_sig_item : class_sig_item -> list class_sig_item -> list class_sig_item; - value list_of_class_str_item : class_str_item -> list class_str_item -> list class_str_item; - value list_of_class_type : class_type -> list class_type -> list class_type; - value list_of_class_expr : class_expr -> list class_expr -> list class_expr; - value list_of_module_expr : module_expr -> list module_expr -> list module_expr; - value list_of_module_binding : module_binding -> list module_binding -> list module_binding; - value list_of_match_case : match_case -> list match_case -> list match_case; - value list_of_ident : ident -> list ident -> list ident; - - (** Like [String.escape] but takes care to not - escape antiquotations strings. *) - value safe_string_escaped : string -> string; - - (** Returns True if the given pattern is irrefutable. *) - value is_irrefut_patt : patt -> bool; - - value is_constructor : ident -> bool; - value is_patt_constructor : patt -> bool; - value is_expr_constructor : expr -> bool; - - value ty_of_stl : (Loc.t * string * list ctyp) -> ctyp; - value ty_of_sbt : (Loc.t * string * bool * ctyp) -> ctyp; - value bi_of_pe : (patt * expr) -> binding; - value pel_of_binding : binding -> list (patt * expr); - value binding_of_pel : list (patt * expr) -> binding; - value sum_type_of_list : list (Loc.t * string * list ctyp) -> ctyp; - value record_type_of_list : list (Loc.t * string * bool * ctyp) -> ctyp; -end; - -(** This functor is a restriction functor. - It takes a Camlp4Ast module and gives the Ast one. - Typical use is for [with] constraints. - Example: ... with module Ast = Camlp4.Sig.Camlp4AstToAst Camlp4Ast *) -module Camlp4AstToAst (M : Camlp4Ast) : Ast - 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 - and type ctyp = M.ctyp - and type patt = M.patt - and type expr = M.expr - and type module_type = M.module_type - and type sig_item = M.sig_item - and type with_constr = M.with_constr - and type module_expr = M.module_expr - and type str_item = M.str_item - and type class_type = M.class_type - and type class_sig_item = M.class_sig_item - and type class_expr = M.class_expr - and type class_str_item = M.class_str_item - and type binding = M.binding - and type rec_binding = M.rec_binding - and type module_binding = M.module_binding - and type match_case = M.match_case - and type ident = M.ident - and type rec_flag = M.rec_flag - and type direction_flag = M.direction_flag - and type mutable_flag = M.mutable_flag - and type private_flag = M.private_flag - and type virtual_flag = M.virtual_flag - and type row_var_flag = M.row_var_flag - and type override_flag = M.override_flag -= M; - -(** 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 - - INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml"; - -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. - - Interface filters: sig_item -> sig_item. *) -module type AstFilters = sig - - module Ast : Camlp4Ast; - - type filter 'a = 'a -> 'a; - - value register_sig_item_filter : (filter Ast.sig_item) -> unit; - value register_str_item_filter : (filter Ast.str_item) -> unit; - value register_topphrase_filter : (filter Ast.str_item) -> unit; - - value fold_interf_filters : ('a -> filter Ast.sig_item -> 'a) -> 'a -> 'a; - value fold_implem_filters : ('a -> filter Ast.str_item -> 'a) -> 'a -> 'a; - value fold_topphrase_filters : ('a -> filter Ast.str_item -> 'a) -> 'a -> 'a; - -end; - -(** ASTs as one single dynamic type *) -module type DynAst = sig - module Ast : Ast; - type tag 'a; - - value ctyp_tag : tag Ast.ctyp; - value patt_tag : tag Ast.patt; - value expr_tag : tag Ast.expr; - value module_type_tag : tag Ast.module_type; - value sig_item_tag : tag Ast.sig_item; - value with_constr_tag : tag Ast.with_constr; - value module_expr_tag : tag Ast.module_expr; - value str_item_tag : tag Ast.str_item; - value class_type_tag : tag Ast.class_type; - value class_sig_item_tag : tag Ast.class_sig_item; - value class_expr_tag : tag Ast.class_expr; - value class_str_item_tag : tag Ast.class_str_item; - value match_case_tag : tag Ast.match_case; - value ident_tag : tag Ast.ident; - value binding_tag : tag Ast.binding; - value rec_binding_tag : tag Ast.rec_binding; - value module_binding_tag : tag Ast.module_binding; - - value string_of_tag : tag 'a -> string; - - module Pack (X : sig type t 'a; end) : sig - type pack; - value pack : tag 'a -> X.t 'a -> pack; - value unpack : tag 'a -> pack -> X.t 'a; - value print_tag : Format.formatter -> pack -> unit; - end; -end; - - -(** {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] 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 -> option string -> string -> 'a; - - (** [add name exp] adds the quotation [name] associated with the - expander [exp]. *) - value add : string -> DynAst.tag 'a -> expand_fun 'a -> unit; - - (** [find name] returns the expander of the given quotation name. *) - value find : string -> DynAst.tag 'a -> expand_fun 'a; - - (** [default] holds the default quotation name. *) - value default : ref string; - - (** [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 -> string -> 'a) -> loc -> quotation -> string -> string -> 'a; - - (** function translating quotation names; default = identity *) - value translate : ref (string -> string); - - 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. - If [None] (default), this result is not dumped. If [Some fname], the - result is dumped in the file [fname]. *) - value dump_file : ref (option string); - - module Error : Error; - -end; - -(** {6 Tokens} *) - -(** A signature for tokens. *) -module type Token = sig - - module Loc : Loc; - - type t; - - value to_string : t -> string; - - value print : Format.formatter -> t -> unit; - - value match_keyword : string -> t -> bool; - - value extract_string : t -> string; - - module Filter : sig - - type token_filter = stream_filter t Loc.t; - - (** The type for this filter chain. - A basic implementation just store the [is_keyword] function given - by [mk] and use it in the [filter] function. *) - type t; - - (** The given predicate function returns true if the given string - is a keyword. This function can be used in filters to translate - identifier tokens to keyword tokens. *) - value mk : (string -> bool) -> t; - - (** This function allows to register a new filter to the token filter chain. - You can choose to not support these and raise an exception. *) - value define_filter : t -> (token_filter -> token_filter) -> unit; - - (** This function filter the given stream and return a filtered stream. - A basic implementation just match identifiers against the [is_keyword] - function to produce token keywords instead. *) - value filter : t -> token_filter; - - (** Called by the grammar system when a keyword is used. - The boolean argument is True when it's the first time that keyword - is used. If you do not care about this information just return [()]. *) - value keyword_added : t -> string -> bool -> unit; - - (** Called by the grammar system when a keyword is no longer used. - If you do not care about this information just return [()]. *) - value keyword_removed : t -> string -> unit; - end; - - module Error : Error; -end; - -(** This signature describes tokens for the OCaml and the Revised - syntax lexing rules. For some tokens the data constructor holds two - representations with the evaluated one and the source one. For example - the INT data constructor holds an integer and a string, this string can - contains more information that's needed for a good pretty-printing - ("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]) - 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, - the backslashes are not interpreted. For example, if the input is ["\n"] - the string is *not* a string with one element containing the character - "return", but a string of two elements: the backslash and the character - ["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 - | LIDENT of string - | UIDENT of string - | ESCAPED_IDENT of string - | INT of int and string - | INT32 of int32 and string - | INT64 of int64 and string - | NATIVEINT of nativeint and string - | FLOAT of float and string - | CHAR of char and string - | STRING of string and string - | LABEL of string - | OPTLABEL of string - | QUOTATION of quotation - | ANTIQUOT of string and string - | COMMENT of string - | BLANKS of string - | NEWLINE - | 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; - - (** [mk ?ocaml_stdlib ?camlp4_stdlib] - The stdlib flag is true by default. - To disable it use: [mk ~ocaml_stdlib:False] *) - value mk : ?ocaml_stdlib: bool -> ?camlp4_stdlib: bool -> unit -> t; - - (** Fold over the current load path list. *) - value fold_load_path : t -> (string -> 'a -> 'a) -> 'a -> 'a; - - (** [load f] Load the file [f]. If [f] is not an absolute path name, - the load path list used to find the directory of [f]. *) - value load : t -> string -> unit; - - (** [include_dir d] Add the directory [d] in the current load path - list (like the common -I option). *) - value include_dir : t -> string -> unit; - - (** [find_in_path f] Returns the full path of the file [f] if - [f] is in the current load path, raises [Not_found] otherwise. *) - value find_in_path : t -> string -> string; - - (** [is_native] [True] if we are in native code, [False] for bytecode. *) - value is_native : bool; -end; - -(** A signature for grammars. *) -module Grammar = struct - - (** Internal signature for sematantic actions of grammars, - not for the casual user. These functions are unsafe. *) - module type Action = sig - type t ; - - value mk : 'a -> t; - value get : t -> 'a; - value getf : t -> ('a -> 'b); - value getf2 : t -> ('a -> 'b -> 'c); - end; - - type assoc = - [ NonA - | RightA - | LeftA ]; - - type position = - [ First - | Last - | Before of string - | After of string - | Level of string ]; - - (** Common signature for {!Sig.Grammar.Static} and {!Sig.Grammar.Dynamic}. *) - module type Structure = sig - module Loc : Loc; - module Action : Action; - module Token : Token with module Loc = Loc; - - type gram; - type internal_entry; - type tree; - - type token_pattern = ((Token.t -> bool) * string); - type token_info; - type token_stream = Stream.t (Token.t * token_info); - - value token_location : token_info -> Loc.t; - - type symbol = - [ Smeta of string and list symbol and Action.t - | Snterm of internal_entry - | Snterml of internal_entry and string - | Slist0 of symbol - | Slist0sep of symbol and symbol - | Slist1 of symbol - | Slist1sep of symbol and symbol - | Sopt of symbol - | Stry of symbol - | Sself - | Snext - | Stoken of token_pattern - | Skeyword of string - | Stree of tree ]; - - type production_rule = (list symbol * Action.t); - type single_extend_statment = - (option string * option assoc * list production_rule); - type extend_statment = - (option position * list single_extend_statment); - type delete_statment = list symbol; - - type fold 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> Stream.t 'a -> 'c; - - type foldsep 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c; - - end; - - (** Signature for Camlp4 grammars. Here the dynamic means that you can produce as - many grammar values as needed with a single grammar module. - If you do not need many grammar values it's preferable to use a static one. *) - module type Dynamic = sig - include Structure; - - (** Make a new grammar. *) - value mk : unit -> gram; - - module Entry : sig - (** The abstract type of grammar entries. The type parameter is the type - of the semantic actions that are associated with this entry. *) - type t 'a; - - (** Make a new entry from the given name. *) - value mk : gram -> string -> t 'a; - - (** Make a new entry from a name and an hand made token parser. *) - value of_parser : - gram -> string -> (token_stream -> 'a) -> t 'a; - - (** Clear the entry and setup this parser instead. *) - value setup_parser : - t 'a -> (token_stream -> 'a) -> unit; - - (** Get the entry name. *) - value name : t 'a -> string; - - (** Print the given entry into the given formatter. *) - value print : Format.formatter -> t 'a -> unit; - - (** 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]. *) - value get_filter : gram -> Token.Filter.t; - - type not_filtered 'a; - - (** This function is called by the EXTEND ... END syntax. *) - value extend : Entry.t 'a -> extend_statment -> unit; - - (** The delete rule. *) - value delete_rule : Entry.t 'a -> delete_statment -> unit; - - value srules : Entry.t 'a -> list (list symbol * Action.t) -> symbol; - value sfold0 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold1 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold0sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; - (* value sfold1sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; *) - - (** Use the lexer to produce a non filtered token stream from a char stream. *) - value lex : gram -> Loc.t -> Stream.t char -> not_filtered (Stream.t (Token.t * Loc.t)); - - (** Token stream from string. *) - value lex_string : gram -> Loc.t -> string -> not_filtered (Stream.t (Token.t * Loc.t)); - - (** Filter a token stream using the {!Token.Filter} module *) - value filter : gram -> not_filtered (Stream.t (Token.t * Loc.t)) -> token_stream; - - (** Lex, filter and parse a stream of character. *) - value parse : Entry.t 'a -> Loc.t -> Stream.t char -> 'a; - - (** Same as {!parse} but from a string. *) - value parse_string : Entry.t 'a -> Loc.t -> string -> 'a; - - (** Parse a token stream that is not filtered yet. *) - value parse_tokens_before_filter : - Entry.t 'a -> not_filtered (Stream.t (Token.t * Loc.t)) -> 'a; - - (** Parse a token stream that is already filtered. *) - value parse_tokens_after_filter : - Entry.t 'a -> token_stream -> 'a; - - end; - - (** Signature for Camlp4 grammars. Here the static means that there is only - one grammar value by grammar module. If you do not need to store the grammar - value it's preferable to use a static one. *) - module type Static = sig - include Structure; - - module Entry : sig - (** The abstract type of grammar entries. The type parameter is the type - of the semantic actions that are associated with this entry. *) - type t 'a; - - (** Make a new entry from the given name. *) - value mk : string -> t 'a; - - (** Make a new entry from a name and an hand made token parser. *) - value of_parser : - string -> (token_stream -> 'a) -> t 'a; - - (** Clear the entry and setup this parser instead. *) - value setup_parser : - t 'a -> (token_stream -> 'a) -> unit; - - (** Get the entry name. *) - value name : t 'a -> string; - - (** Print the given entry into the given formatter. *) - value print : Format.formatter -> t 'a -> unit; - - (** 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. *) - value get_filter : unit -> Token.Filter.t; - - type not_filtered 'a; - - (** This function is called by the EXTEND ... END syntax. *) - value extend : Entry.t 'a -> extend_statment -> unit; - - (** The delete rule. *) - value delete_rule : Entry.t 'a -> delete_statment -> unit; - value srules : Entry.t 'a -> list (list symbol * Action.t) -> symbol; - value sfold0 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold1 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold0sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; - (* value sfold1sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; *) - - (** Use the lexer to produce a non filtered token stream from a char stream. *) - value lex : Loc.t -> Stream.t char -> not_filtered (Stream.t (Token.t * Loc.t)); - - (** Token stream from string. *) - value lex_string : Loc.t -> string -> not_filtered (Stream.t (Token.t * Loc.t)); - - (** Filter a token stream using the {!Token.Filter} module *) - value filter : not_filtered (Stream.t (Token.t * Loc.t)) -> token_stream; - - (** Lex, filter and parse a stream of character. *) - value parse : Entry.t 'a -> Loc.t -> Stream.t char -> 'a; - - (** Same as {!parse} but from a string. *) - value parse_string : Entry.t 'a -> Loc.t -> string -> 'a; - - (** Parse a token stream that is not filtered yet. *) - value parse_tokens_before_filter : - Entry.t 'a -> not_filtered (Stream.t (Token.t * Loc.t)) -> 'a; - - (** Parse a token stream that is already filtered. *) - value parse_tokens_after_filter : - Entry.t 'a -> token_stream -> 'a; - - end; - -end; - -(** A signature for lexers. *) -module type Lexer = sig - module Loc : Loc; - module Token : Token with module Loc = Loc; - module Error : Error; - - (** The constructor for a lexing function. The character stream is the input - stream to be lexed. The result is a stream of pairs of a token and - a location. - The lexer do not use global (mutable) variables: instantiations - of [Lexer.mk ()] do not perturb each other. *) - value mk : unit -> (Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t)); -end; - - -(** 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 - tree; the returned list contains the phrases (structure items) as a - single "declare" node (a list of structure items); if the parser - encounter a directive it stops (since the directive may change the - 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 -> 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 -> Stream.t char -> Ast.sig_item; - end; -end; - -(** A signature for printers abstract from ASTs. *) -module Printer (Ast : Ast) = struct - module type S = sig - - value print_interf : ?input_file:string -> ?output_file:string -> - Ast.sig_item -> unit; - value print_implem : ?input_file:string -> ?output_file:string -> - Ast.str_item -> unit; - - end; -end; - -(** A syntax module is a sort of constistent bunch of modules and values. - In such a module you have a parser, a printer, and also modules for - locations, syntax trees, tokens, grammars, quotations, anti-quotations. - There is also the main grammar entries. *) -module type Syntax = sig - 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 Quotation : Quotation with module Ast = Ast; - - module AntiquotSyntax : (Parser Ast).SIMPLE; - - include (Warning Loc).S; - include (Parser Ast).S; - include (Printer Ast).S; -end; - -(** A syntax module is a sort of constistent bunch of modules and values. - In such a module you have a parser, a printer, and also modules for - locations, syntax trees, tokens, grammars, quotations, anti-quotations. - There is also the main grammar entries. *) -module type Camlp4Syntax = sig - module Loc : Loc; - - module Ast : Camlp4Ast with module Loc = Loc; - module Token : Camlp4Token with module Loc = Loc; - - module Gram : Grammar.Static with module Loc = Loc and module Token = Token; - 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; - - value interf : Gram.Entry.t (list Ast.sig_item * option Loc.t); - value implem : Gram.Entry.t (list Ast.str_item * option Loc.t); - value top_phrase : Gram.Entry.t (option Ast.str_item); - value use_file : Gram.Entry.t (list Ast.str_item * option Loc.t); - value a_CHAR : Gram.Entry.t string; - value a_FLOAT : Gram.Entry.t string; - value a_INT : Gram.Entry.t string; - value a_INT32 : Gram.Entry.t string; - value a_INT64 : Gram.Entry.t string; - value a_LABEL : Gram.Entry.t string; - value a_LIDENT : Gram.Entry.t string; - value a_NATIVEINT : Gram.Entry.t string; - value a_OPTLABEL : Gram.Entry.t string; - value a_STRING : Gram.Entry.t string; - value a_UIDENT : Gram.Entry.t string; - value a_ident : Gram.Entry.t string; - value amp_ctyp : Gram.Entry.t Ast.ctyp; - value and_ctyp : Gram.Entry.t Ast.ctyp; - value match_case : Gram.Entry.t Ast.match_case; - value match_case0 : Gram.Entry.t Ast.match_case; - value match_case_quot : Gram.Entry.t Ast.match_case; - value binding : Gram.Entry.t Ast.binding; - value binding_quot : Gram.Entry.t Ast.binding; - value rec_binding_quot : Gram.Entry.t Ast.rec_binding; - value class_declaration : Gram.Entry.t Ast.class_expr; - value class_description : Gram.Entry.t Ast.class_type; - value class_expr : Gram.Entry.t Ast.class_expr; - value class_expr_quot : Gram.Entry.t Ast.class_expr; - value class_fun_binding : Gram.Entry.t Ast.class_expr; - value class_fun_def : Gram.Entry.t Ast.class_expr; - value class_info_for_class_expr : Gram.Entry.t Ast.class_expr; - value class_info_for_class_type : Gram.Entry.t Ast.class_type; - value class_longident : Gram.Entry.t Ast.ident; - value class_longident_and_param : Gram.Entry.t Ast.class_expr; - value class_name_and_param : Gram.Entry.t (string * Ast.ctyp); - value class_sig_item : Gram.Entry.t Ast.class_sig_item; - value class_sig_item_quot : Gram.Entry.t Ast.class_sig_item; - value class_signature : Gram.Entry.t Ast.class_sig_item; - value class_str_item : Gram.Entry.t Ast.class_str_item; - value class_str_item_quot : Gram.Entry.t Ast.class_str_item; - value class_structure : Gram.Entry.t Ast.class_str_item; - value class_type : Gram.Entry.t Ast.class_type; - value class_type_declaration : Gram.Entry.t Ast.class_type; - value class_type_longident : Gram.Entry.t Ast.ident; - value class_type_longident_and_param : Gram.Entry.t Ast.class_type; - value class_type_plus : Gram.Entry.t Ast.class_type; - value class_type_quot : Gram.Entry.t Ast.class_type; - value comma_ctyp : Gram.Entry.t Ast.ctyp; - value comma_expr : Gram.Entry.t Ast.expr; - value comma_ipatt : Gram.Entry.t Ast.patt; - value comma_patt : Gram.Entry.t Ast.patt; - value comma_type_parameter : Gram.Entry.t Ast.ctyp; - value constrain : Gram.Entry.t (Ast.ctyp * Ast.ctyp); - value constructor_arg_list : Gram.Entry.t Ast.ctyp; - value constructor_declaration : Gram.Entry.t Ast.ctyp; - value constructor_declarations : Gram.Entry.t Ast.ctyp; - value ctyp : Gram.Entry.t Ast.ctyp; - value ctyp_quot : Gram.Entry.t Ast.ctyp; - value cvalue_binding : Gram.Entry.t Ast.expr; - value direction_flag : Gram.Entry.t Ast.direction_flag; - value direction_flag_quot : Gram.Entry.t Ast.direction_flag; - value dummy : Gram.Entry.t unit; - value eq_expr : Gram.Entry.t (string -> Ast.patt -> Ast.patt); - value expr : Gram.Entry.t Ast.expr; - value expr_eoi : Gram.Entry.t Ast.expr; - value expr_quot : Gram.Entry.t Ast.expr; - value field_expr : Gram.Entry.t Ast.rec_binding; - value field_expr_list : Gram.Entry.t Ast.rec_binding; - value fun_binding : Gram.Entry.t Ast.expr; - value fun_def : Gram.Entry.t Ast.expr; - value ident : Gram.Entry.t Ast.ident; - value ident_quot : Gram.Entry.t Ast.ident; - value ipatt : Gram.Entry.t Ast.patt; - value ipatt_tcon : Gram.Entry.t Ast.patt; - value label : Gram.Entry.t string; - value label_declaration : Gram.Entry.t Ast.ctyp; - value label_declaration_list : Gram.Entry.t Ast.ctyp; - value label_expr : Gram.Entry.t Ast.rec_binding; - value label_expr_list : Gram.Entry.t Ast.rec_binding; - value label_ipatt : Gram.Entry.t Ast.patt; - value label_ipatt_list : Gram.Entry.t Ast.patt; - value label_longident : Gram.Entry.t Ast.ident; - value label_patt : Gram.Entry.t Ast.patt; - value label_patt_list : Gram.Entry.t Ast.patt; - value labeled_ipatt : Gram.Entry.t Ast.patt; - value let_binding : Gram.Entry.t Ast.binding; - value meth_list : Gram.Entry.t (Ast.ctyp * Ast.row_var_flag); - value meth_decl : Gram.Entry.t Ast.ctyp; - value module_binding : Gram.Entry.t Ast.module_binding; - value module_binding0 : Gram.Entry.t Ast.module_expr; - value module_binding_quot : Gram.Entry.t Ast.module_binding; - value module_declaration : Gram.Entry.t Ast.module_type; - value module_expr : Gram.Entry.t Ast.module_expr; - value module_expr_quot : Gram.Entry.t Ast.module_expr; - value module_longident : Gram.Entry.t Ast.ident; - value module_longident_with_app : Gram.Entry.t Ast.ident; - value module_rec_declaration : Gram.Entry.t Ast.module_binding; - value module_type : Gram.Entry.t Ast.module_type; - value package_type : Gram.Entry.t Ast.module_type; - value module_type_quot : Gram.Entry.t Ast.module_type; - value more_ctyp : Gram.Entry.t Ast.ctyp; - value name_tags : Gram.Entry.t Ast.ctyp; - value opt_as_lident : Gram.Entry.t string; - value opt_class_self_patt : Gram.Entry.t Ast.patt; - value opt_class_self_type : Gram.Entry.t Ast.ctyp; - value opt_comma_ctyp : Gram.Entry.t Ast.ctyp; - value opt_dot_dot : Gram.Entry.t Ast.row_var_flag; - value row_var_flag_quot : Gram.Entry.t Ast.row_var_flag; - value opt_eq_ctyp : Gram.Entry.t Ast.ctyp; - value opt_expr : Gram.Entry.t Ast.expr; - value opt_meth_list : Gram.Entry.t Ast.ctyp; - value opt_mutable : Gram.Entry.t Ast.mutable_flag; - value mutable_flag_quot : Gram.Entry.t Ast.mutable_flag; - value opt_override : Gram.Entry.t Ast.override_flag; - value override_flag_quot : Gram.Entry.t Ast.override_flag; - value opt_polyt : Gram.Entry.t Ast.ctyp; - value opt_private : Gram.Entry.t Ast.private_flag; - value private_flag_quot : Gram.Entry.t Ast.private_flag; - value opt_rec : Gram.Entry.t Ast.rec_flag; - value rec_flag_quot : Gram.Entry.t Ast.rec_flag; - value opt_virtual : Gram.Entry.t Ast.virtual_flag; - value virtual_flag_quot : Gram.Entry.t Ast.virtual_flag; - value opt_when_expr : Gram.Entry.t Ast.expr; - value patt : Gram.Entry.t Ast.patt; - value patt_as_patt_opt : Gram.Entry.t Ast.patt; - value patt_eoi : Gram.Entry.t Ast.patt; - value patt_quot : Gram.Entry.t Ast.patt; - value patt_tcon : Gram.Entry.t Ast.patt; - value phrase : Gram.Entry.t Ast.str_item; - value poly_type : Gram.Entry.t Ast.ctyp; - value row_field : Gram.Entry.t Ast.ctyp; - value sem_expr : Gram.Entry.t Ast.expr; - value sem_expr_for_list : Gram.Entry.t (Ast.expr -> Ast.expr); - value sem_patt : Gram.Entry.t Ast.patt; - value sem_patt_for_list : Gram.Entry.t (Ast.patt -> Ast.patt); - value semi : Gram.Entry.t unit; - value sequence : Gram.Entry.t Ast.expr; - value do_sequence : Gram.Entry.t Ast.expr; - value sig_item : Gram.Entry.t Ast.sig_item; - value sig_item_quot : Gram.Entry.t Ast.sig_item; - value sig_items : Gram.Entry.t Ast.sig_item; - value star_ctyp : Gram.Entry.t Ast.ctyp; - value str_item : Gram.Entry.t Ast.str_item; - value str_item_quot : Gram.Entry.t Ast.str_item; - value str_items : Gram.Entry.t Ast.str_item; - value type_constraint : Gram.Entry.t unit; - value type_declaration : Gram.Entry.t Ast.ctyp; - value type_ident_and_parameters : Gram.Entry.t (string * list Ast.ctyp); - value type_kind : Gram.Entry.t Ast.ctyp; - value type_longident : Gram.Entry.t Ast.ident; - value type_longident_and_parameters : Gram.Entry.t Ast.ctyp; - value type_parameter : Gram.Entry.t Ast.ctyp; - value type_parameters : Gram.Entry.t (Ast.ctyp -> Ast.ctyp); - value typevars : Gram.Entry.t Ast.ctyp; - value val_longident : Gram.Entry.t Ast.ident; - value value_let : Gram.Entry.t unit; - value value_val : Gram.Entry.t unit; - value with_constr : Gram.Entry.t Ast.with_constr; - value with_constr_quot : Gram.Entry.t Ast.with_constr; - value prefixop : Gram.Entry.t Ast.expr; - value infixop0 : Gram.Entry.t Ast.expr; - value infixop1 : Gram.Entry.t Ast.expr; - value infixop2 : Gram.Entry.t Ast.expr; - value infixop3 : Gram.Entry.t Ast.expr; - 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 Quotation = Syn.Quotation); diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/AstFilters.ml ocaml-4.02.3/camlp4/Camlp4/Struct/AstFilters.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/AstFilters.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/AstFilters.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,37 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Ast : Sig.Camlp4Ast) -: Sig.AstFilters with module Ast = Ast -= struct - - module Ast = Ast; - - type filter 'a = 'a -> 'a; - - value interf_filters = Queue.create (); - value fold_interf_filters f i = Queue.fold f i interf_filters; - value implem_filters = Queue.create (); - value fold_implem_filters f i = Queue.fold f i implem_filters; - value topphrase_filters = Queue.create (); - value fold_topphrase_filters f i = Queue.fold f i topphrase_filters; - - value register_sig_item_filter f = Queue.add f interf_filters; - value register_str_item_filter f = Queue.add f implem_filters; - value register_topphrase_filter f = Queue.add f topphrase_filters; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml ocaml-4.02.3/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml 2013-08-30 13:39:33.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,1238 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2002-2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -module Make (Ast : Sig.Camlp4Ast) = struct - open Format; - open Camlp4_import.Parsetree; - open Camlp4_import.Longident; - open Camlp4_import.Asttypes; - open Ast; - - value constructors_arity () = - debug ast2pt "constructors_arity: %b@." Camlp4_config.constructors_arity.val in - Camlp4_config.constructors_arity.val; - - value error loc str = Loc.raise loc (Failure str); - - value char_of_char_token loc s = - try Token.Eval.char s with [ Failure _ as exn -> Loc.raise loc exn ] - ; - - value string_of_string_token loc s = - try Token.Eval.string s - with [ Failure _ as exn -> Loc.raise loc exn ] - ; - - value remove_underscores s = - let l = String.length s in - let rec remove src dst = - if src >= l then - if dst >= l then s else String.sub s 0 dst - else - match s.[src] with - [ '_' -> remove (src + 1) dst - | c -> do { s.[dst] := c; remove (src + 1) (dst + 1) } ] - in remove 0 0 - ; - - value mkloc = Loc.to_ocaml_location; - value mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc); - - value with_loc txt loc = Camlp4_import.Location.mkloc txt (mkloc loc); - - value mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc}; - value mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc}; - value mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc}; - value mkexp loc d = {pexp_desc = d; pexp_loc = mkloc loc}; - value mkmty loc d = {pmty_desc = d; pmty_loc = mkloc loc}; - value mksig loc d = {psig_desc = d; psig_loc = mkloc loc}; - value mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc}; - value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc}; - value mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc}; - value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc}; - value mkcl loc d = {pcl_desc = d; pcl_loc = mkloc loc}; - value mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; }; - value mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; }; - - value mkpolytype t = - match t.ptyp_desc with - [ Ptyp_poly _ _ -> t - | _ -> { (t) with ptyp_desc = Ptyp_poly [] t } ] - ; - - value mkvirtual = fun - [ <:virtual_flag< virtual >> -> Virtual - | <:virtual_flag<>> -> Concrete - | _ -> assert False ]; - - value mkdirection = fun - [ <:direction_flag< to >> -> Upto - | <:direction_flag< downto >> -> Downto - | _ -> assert False ]; - - value lident s = Lident s; - value lident_with_loc s loc = with_loc (Lident s) loc; - - - value ldot l s = Ldot l s; - value lapply l s = Lapply l s; - - value conv_con = - let t = Hashtbl.create 73 in - do { - List.iter (fun (s, s') -> Hashtbl.add t s s') - [("True", "true"); ("False", "false"); (" True", "True"); - (" False", "False")]; - fun s -> try Hashtbl.find t s with [ Not_found -> s ] - } - ; - - value conv_lab = - let t = Hashtbl.create 73 in - do { - List.iter (fun (s, s') -> Hashtbl.add t s s') [("val", "contents")]; - fun s -> try Hashtbl.find t s with [ Not_found -> s ] - } - ; - - value array_function_no_loc str name = - ldot (lident str) (if Camlp4_config.unsafe.val then "unsafe_" ^ name else name) - ; - value array_function loc str name = with_loc (array_function_no_loc str name) loc; - value mkrf = - fun - [ <:rec_flag< rec >> -> Recursive - | <:rec_flag<>> -> Nonrecursive - | _ -> assert False ]; - - value mkli sloc s list = with_loc (loop lident list) sloc - where rec loop f = - fun - [ [i :: il] -> loop (ldot (f i)) il - | [] -> f s ] - ; - - value rec ctyp_fa al = - fun - [ TyApp _ f a -> ctyp_fa [a :: al] f - | f -> (f, al) ] - ; - - value ident_tag ?(conv_lid = fun x -> x) i = - - let rec self i acc = - match i with - [ <:ident< $lid:"*predef*"$.$lid:"option"$ >> -> - (ldot (lident "*predef*") "option", `lident) - | <:ident< $i1$.$i2$ >> -> - self i2 (Some (self i1 acc)) - | <:ident< $i1$ $i2$ >> -> - let i' = Lapply (fst (self i1 None)) (fst (self i2 None)) in - let x = - match acc with - [ None -> i' - | _ -> error (loc_of_ident i) "invalid long identifier" ] - in (x, `app) - | <:ident< $uid:s$ >> -> - let x = - match acc with - [ None -> lident s - | Some (acc, `uident | `app) -> ldot acc s - | _ -> error (loc_of_ident i) "invalid long identifier" ] - in (x, `uident) - | <:ident< $lid:s$ >> -> - let x = - match acc with - [ None -> lident (conv_lid s) - | Some (acc, `uident | `app) -> ldot acc (conv_lid s) - | _ -> error (loc_of_ident i) "invalid long identifier" ] - in (x, `lident) - | _ -> error (loc_of_ident i) "invalid long identifier" ] - in self i None; - - value ident_noloc ?conv_lid i = fst (ident_tag ?conv_lid i); - value ident ?conv_lid i = - with_loc (ident_noloc ?conv_lid i) (loc_of_ident i); - - value long_lident msg id = - match ident_tag id with - [ (i, `lident) -> with_loc i (loc_of_ident id) - | _ -> error (loc_of_ident id) msg ] - ; - - value long_type_ident = long_lident "invalid long identifier type"; - value long_class_ident = long_lident "invalid class name"; - - value long_uident_noloc ?(conv_con = fun x -> x) i = - match ident_tag i with - [ (Ldot i s, `uident) -> ldot i (conv_con s) - | (Lident s, `uident) -> lident (conv_con s) - | (i, `app) -> i - | _ -> error (loc_of_ident i) "uppercase identifier expected" ] - ; - - value long_uident ?conv_con i = - with_loc (long_uident_noloc ?conv_con i) (loc_of_ident i); - - value rec ctyp_long_id_prefix t = - match t with - [ <:ctyp< $id:i$ >> -> ident_noloc i - | <:ctyp< $m1$ $m2$ >> -> - let li1 = ctyp_long_id_prefix m1 in - let li2 = ctyp_long_id_prefix m2 in - Lapply li1 li2 - | t -> error (loc_of_ctyp t) "invalid module expression" ] - ; - - value ctyp_long_id t = - match t with - [ <:ctyp< $id:i$ >> -> - (False, long_type_ident i) - | TyApp loc _ _ -> - error loc "invalid type name" - | TyCls _ i -> (True, ident i) - | t -> error (loc_of_ctyp t) "invalid type" ] - ; - - value rec ty_var_list_of_ctyp = - fun - [ <:ctyp< $t1$ $t2$ >> -> ty_var_list_of_ctyp t1 @ ty_var_list_of_ctyp t2 - | <:ctyp< '$s$ >> -> [s] - | _ -> assert False ]; - - value predef_option loc = - TyId (loc, IdAcc (loc, IdLid (loc, "*predef*"), IdLid (loc, "option"))); - - value rec ctyp = - fun - [ TyId loc i -> - let li = long_type_ident i in - mktyp loc (Ptyp_constr li []) - | TyAli loc t1 t2 -> - let (t, i) = - match (t1, t2) with - [ (t, TyQuo _ s) -> (t, s) - | (TyQuo _ s, t) -> (t, s) - | _ -> error loc "invalid alias type" ] - in - mktyp loc (Ptyp_alias (ctyp t) i) - | TyAny loc -> mktyp loc Ptyp_any - | TyApp loc _ _ as f -> - let (f, al) = ctyp_fa [] f in - let (is_cls, li) = ctyp_long_id f in - if is_cls then mktyp loc (Ptyp_class li (List.map ctyp al) []) - else mktyp loc (Ptyp_constr li (List.map ctyp al)) - | TyArr loc (TyLab _ lab t1) t2 -> - mktyp loc (Ptyp_arrow lab (ctyp t1) (ctyp t2)) - | TyArr loc (TyOlb loc1 lab t1) t2 -> - let t1 = TyApp loc1 (predef_option loc1) 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< < $fl$ > >> -> mktyp loc (Ptyp_object (meth_list fl [])) - | <:ctyp@loc< < $fl$ .. > >> -> - mktyp loc (Ptyp_object (meth_list fl [mkfield loc Pfield_var])) - | TyCls loc id -> - mktyp loc (Ptyp_class (ident id) [] []) - | <:ctyp@loc< (module $pt$) >> -> - let (i, cs) = package_type pt in - mktyp loc (Ptyp_package i cs) - | TyLab loc _ _ -> error loc "labelled type not allowed here" - | TyMan loc _ _ -> error loc "manifest type not allowed here" - | TyOlb loc _ _ -> error loc "labelled type not allowed here" - | TyPol loc t1 t2 -> mktyp loc (Ptyp_poly (ty_var_list_of_ctyp t1) (ctyp t2)) - | TyQuo loc s -> mktyp loc (Ptyp_var s) - | TyRec loc _ -> error loc "record type not allowed here" - | TySum loc _ -> error loc "sum type not allowed here" - | TyPrv loc _ -> error loc "private type not allowed here" - | TyMut loc _ -> error loc "mutable type not allowed here" - | TyOr loc _ _ -> error loc "type1 | type2 not allowed here" - | TyAnd loc _ _ -> error loc "type1 and type2 not allowed here" - | TyOf loc _ _ -> error loc "type1 of type2 not allowed here" - | TyCol loc _ _ -> error loc "type1 : type2 not allowed here" - | TySem loc _ _ -> error loc "type1 ; type2 not allowed here" - | <:ctyp@loc< ($t1$ * $t2$) >> -> - mktyp loc (Ptyp_tuple (List.map ctyp (list_of_ctyp t1 (list_of_ctyp t2 [])))) - | <:ctyp@loc< [ = $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) True None) - | <:ctyp@loc< [ > $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) False None) - | <:ctyp@loc< [ < $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) True (Some [])) - | <:ctyp@loc< [ < $t$ > $t'$ ] >> -> - mktyp loc (Ptyp_variant (row_field t) True (Some (name_tags t'))) - | TyAnt loc _ -> error loc "antiquotation not allowed here" - | TyOfAmp _ _ _ |TyAmp _ _ _ |TySta _ _ _ | - TyCom _ _ _ |TyVrn _ _ |TyQuM _ _ |TyQuP _ _ |TyDcl _ _ _ _ _ | - TyAnP _ | TyAnM _ | TyTypePol _ _ _ | - TyObj _ _ (RvAnt _) | TyNil _ | TyTup _ _ -> - assert False ] - and row_field = fun - [ <: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 - | t -> [Rinherit (ctyp t)] ] - and name_tags = fun - [ <:ctyp< $t1$ $t2$ >> -> name_tags t1 @ name_tags t2 - | <:ctyp< `$s$ >> -> [s] - | _ -> assert False ] - and meth_list fl acc = - match fl with - [ <: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 ] - - and package_type_constraints wc acc = - match wc with - [ <:with_constr<>> -> acc - | <:with_constr< type $id:id$ = $ct$ >> -> - [(ident id, ctyp ct) :: acc] - | <:with_constr< $wc1$ and $wc2$ >> -> - package_type_constraints wc1 (package_type_constraints wc2 acc) - | _ -> error (loc_of_with_constr wc) "unexpected `with constraint' for a package type" ] - - and package_type : module_type -> package_type = - fun - [ <:module_type< $id:i$ with $wc$ >> -> - (long_uident i, package_type_constraints wc []) - | <:module_type< $id:i$ >> -> (long_uident i, []) - | mt -> error (loc_of_module_type mt) "unexpected package type" ] - ; - - value mktype loc tl cl tk tp tm = - let (params, variance) = List.split tl in - {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; - ptype_private = tp; ptype_manifest = tm; ptype_loc = mkloc loc; - ptype_variance = variance} - ; - value mkprivate' m = if m then Private else Public; - value mkprivate = fun - [ <:private_flag< private >> -> Private - | <:private_flag<>> -> Public - | _ -> assert False ]; - value mktrecord = - fun - [ <:ctyp@loc< $id:(<:ident@sloc< $lid:s$ >>)$ : mutable $t$ >> -> - (with_loc s sloc, Mutable, mkpolytype (ctyp t), mkloc loc) - | <:ctyp@loc< $id:(<:ident@sloc< $lid:s$ >>)$ : $t$ >> -> - (with_loc s sloc, Immutable, mkpolytype (ctyp t), mkloc loc) - | _ -> assert False (*FIXME*) ]; - value mkvariant = - fun - [ <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ >> -> - (with_loc (conv_con s) sloc, [], None, mkloc loc) - | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ of $t$ >> -> - (with_loc (conv_con s) sloc, List.map ctyp (list_of_ctyp t []), None, mkloc loc) - | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : ($t$ -> $u$) >> -> - (with_loc (conv_con s) sloc, List.map ctyp (list_of_ctyp t []), Some (ctyp u), mkloc loc) - | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : $t$ >> -> - (with_loc (conv_con s) sloc, [], Some (ctyp t), mkloc loc) - - | _ -> assert False (*FIXME*) ]; - value rec type_decl tl cl loc m pflag = - fun - [ <:ctyp< $t1$ == $t2$ >> -> - type_decl tl cl loc (Some (ctyp t1)) pflag t2 - | <:ctyp@_loc< private $t$ >> -> - if pflag then - error _loc "multiple private keyword used, use only one instead" - else - type_decl tl cl loc m True t - | <:ctyp< { $t$ } >> -> - mktype loc tl cl - (Ptype_record (List.map mktrecord (list_of_ctyp t []))) (mkprivate' pflag) m - | <:ctyp< [ $t$ ] >> -> - mktype loc tl cl - (Ptype_variant (List.map mkvariant (list_of_ctyp t []))) (mkprivate' pflag) m - | t -> - if m <> None then - error loc "only one manifest type allowed by definition" else - let m = - match t with - [ <:ctyp<>> -> None - | _ -> Some (ctyp t) ] - in - mktype loc tl cl Ptype_abstract (mkprivate' pflag) m ] - ; - - value type_decl tl cl t loc = type_decl tl cl loc None False t; - - value mkvalue_desc loc t p = {pval_type = ctyp t; pval_prim = p; pval_loc = mkloc loc}; - - value rec list_of_meta_list = - fun - [ Ast.LNil -> [] - | Ast.LCons x xs -> [x :: list_of_meta_list xs] - | Ast.LAnt _ -> assert False ]; - - value mkmutable = fun - [ <:mutable_flag< mutable >> -> Mutable - | <:mutable_flag<>> -> Immutable - | _ -> assert False ]; - - value paolab lab p = - match (lab, p) with - [ ("", <:patt< $lid:i$ >> | <:patt< ($lid:i$ : $_$) >>) -> i - | ("", p) -> error (loc_of_patt p) "bad ast in label" - | _ -> lab ] - ; - - value opt_private_ctyp = - fun - [ <:ctyp< private $t$ >> -> (Ptype_abstract, Private, ctyp t) - | t -> (Ptype_abstract, Public, ctyp t) ]; - - value rec type_parameters t acc = - match t with - [ <:ctyp< $t1$ $t2$ >> -> type_parameters t1 (type_parameters t2 acc) - | <:ctyp< +'$s$ >> -> [(s, (True, False)) :: acc] - | <:ctyp< -'$s$ >> -> [(s, (False, True)) :: acc] - | <:ctyp< '$s$ >> -> [(s, (False, False)) :: acc] - | _ -> assert False ]; - - value rec optional_type_parameters t acc = - match t with - [ <:ctyp< $t1$ $t2$ >> -> optional_type_parameters t1 (optional_type_parameters t2 acc) - | <:ctyp@loc< +'$s$ >> -> [(Some (with_loc s loc), (True, False)) :: acc] - | Ast.TyAnP _loc -> [(None, (True, False)) :: acc] - | <:ctyp@loc< -'$s$ >> -> [(Some (with_loc s loc), (False, True)) :: acc] - | Ast.TyAnM _loc -> [(None, (False, True)) :: acc] - | <:ctyp@loc< '$s$ >> -> [(Some (with_loc s loc), (False, False)) :: acc] - | Ast.TyAny _loc -> [(None, (False, False)) :: acc] - | _ -> assert False ]; - - value rec class_parameters t acc = - match t with - [ <:ctyp< $t1$, $t2$ >> -> class_parameters t1 (class_parameters t2 acc) - | <:ctyp@loc< +'$s$ >> -> [(with_loc s loc, (True, False)) :: acc] - | <:ctyp@loc< -'$s$ >> -> [(with_loc s loc, (False, True)) :: acc] - | <:ctyp@loc< '$s$ >> -> [(with_loc s loc, (False, False)) :: acc] - | _ -> assert False ]; - - value rec type_parameters_and_type_name t acc = - match t with - [ <:ctyp< $t1$ $t2$ >> -> - type_parameters_and_type_name t1 - (optional_type_parameters t2 acc) - | <:ctyp< $id:i$ >> -> (ident i, acc) - | _ -> assert False ]; - - value mkwithtyp pwith_type loc id_tpl ct = - let (id, tpl) = type_parameters_and_type_name id_tpl [] in - let (params, variance) = List.split tpl in - let (kind, priv, ct) = opt_private_ctyp ct in - (id, pwith_type - {ptype_params = params; ptype_cstrs = []; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = Some ct; - ptype_loc = mkloc loc; ptype_variance = variance}); - - value rec mkwithc wc acc = - match wc with - [ <:with_constr<>> -> acc - | <:with_constr@loc< type $id_tpl$ = $ct$ >> -> - [mkwithtyp (fun x -> Pwith_type x) loc id_tpl ct :: acc] - | <:with_constr< module $i1$ = $i2$ >> -> - [(long_uident i1, Pwith_module (long_uident i2)) :: acc] - | <:with_constr@loc< type $id_tpl$ := $ct$ >> -> - [mkwithtyp (fun x -> Pwith_typesubst x) loc id_tpl ct :: acc] - | <:with_constr< module $i1$ := $i2$ >> (*WcMoS _ i1 i2*) -> - [(long_uident i1, Pwith_modsubst (long_uident i2)) :: acc] - | <:with_constr< $wc1$ and $wc2$ >> -> mkwithc wc1 (mkwithc wc2 acc) - | <:with_constr@loc< $anti:_$ >> -> - error loc "bad with constraint (antiquotation)" ]; - - value rec patt_fa al = - fun - [ PaApp _ f a -> patt_fa [a :: al] f - | f -> (f, al) ] - ; - - value rec deep_mkrangepat loc c1 c2 = - if c1 = c2 then mkghpat loc (Ppat_constant (Const_char c1)) - else - mkghpat loc - (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1))) - (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) - ; - - value rec mkrangepat loc c1 c2 = - if c1 > c2 then mkrangepat loc c2 c1 - else if c1 = c2 then mkpat loc (Ppat_constant (Const_char c1)) - else - mkpat loc - (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1))) - (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) - ; - - value rec patt = - fun - [ <:patt@loc< $id:(<:ident@sloc< $lid:s$ >>)$ >> -> - mkpat loc (Ppat_var (with_loc s sloc)) - | <:patt@loc< $id:i$ >> -> - let p = Ppat_construct (long_uident ~conv_con i) - None (constructors_arity ()) - in mkpat loc p - | PaAli loc p1 p2 -> - let (p, i) = - match (p1, p2) with - [ (p, <:patt< $id:(<:ident@sloc< $lid:s$ >>)$ >>) -> (p, with_loc s sloc) - | (<:patt< $id:(<:ident@sloc< $lid:s$ >>)$ >>, p) -> (p, with_loc s sloc) - | _ -> error loc "invalid alias pattern" ] - in - mkpat loc (Ppat_alias (patt p) i) - | PaAnt loc _ -> error loc "antiquotation not allowed here" - | PaAny loc -> mkpat loc Ppat_any - | <:patt@loc< $id:(<:ident@sloc< $uid:s$ >>)$ ($tup:<:patt@loc_any< _ >>$) >> -> - mkpat loc (Ppat_construct (lident_with_loc (conv_con s) sloc) - (Some (mkpat loc_any Ppat_any)) False) - | PaApp loc _ _ as f -> - let (f, al) = patt_fa [] f in - let al = List.map patt al in - match (patt f).ppat_desc with - [ Ppat_construct li None _ -> - if constructors_arity () then - mkpat loc (Ppat_construct li (Some (mkpat loc (Ppat_tuple al))) True) - else - let a = - match al with - [ [a] -> a - | _ -> mkpat loc (Ppat_tuple al) ] - in - mkpat loc (Ppat_construct li (Some a) False) - | Ppat_variant s None -> - let a = - if constructors_arity () then - mkpat loc (Ppat_tuple al) - else - match al with - [ [a] -> a - | _ -> mkpat loc (Ppat_tuple al) ] - in mkpat loc (Ppat_variant s (Some a)) - | _ -> - error (loc_of_patt f) - "this is not a constructor, it cannot be applied in a pattern" ] - | PaArr loc p -> mkpat loc (Ppat_array (List.map patt (list_of_patt p []))) - | PaChr loc s -> - mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s))) - | PaInt loc s -> - let i = try int_of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int" - ] in mkpat loc (Ppat_constant (Const_int i)) - | PaInt32 loc s -> - let i32 = try Int32.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32" - ] in mkpat loc (Ppat_constant (Const_int32 i32)) - | PaInt64 loc s -> - let i64 = try Int64.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64" - ] in mkpat loc (Ppat_constant (Const_int64 i64)) - | PaNativeInt loc s -> - let nati = try Nativeint.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint" - ] in mkpat loc (Ppat_constant (Const_nativeint nati)) - | PaFlo loc s -> mkpat loc (Ppat_constant (Const_float (remove_underscores s))) - | PaLab loc _ _ -> error loc "labeled pattern not allowed here" - | PaOlb loc _ _ | PaOlbi loc _ _ _ -> error loc "labeled pattern not allowed here" - | PaOrp loc p1 p2 -> mkpat loc (Ppat_or (patt p1) (patt p2)) - | PaRng loc p1 p2 -> - match (p1, p2) with - [ (PaChr loc1 c1, PaChr loc2 c2) -> - let c1 = char_of_char_token loc1 c1 in - let c2 = char_of_char_token loc2 c2 in - mkrangepat loc c1 c2 - | _ -> error loc "range pattern allowed only for characters" ] - | PaRec loc p -> - let ps = list_of_patt p [] in - let is_wildcard = fun [ <:patt< _ >> -> True | _ -> False ] in - let (wildcards,ps) = List.partition is_wildcard ps in - let is_closed = if wildcards = [] then Closed else Open in - mkpat loc (Ppat_record (List.map mklabpat ps, is_closed)) - | PaStr loc s -> - mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s))) - | <:patt@loc< ($p1$, $p2$) >> -> - mkpat loc (Ppat_tuple - (List.map patt (list_of_patt p1 (list_of_patt p2 [])))) - | <:patt@loc< ($tup:_$) >> -> error loc "singleton tuple pattern" - | PaTyc loc p t -> mkpat loc (Ppat_constraint (patt p) (ctyp t)) - | PaTyp loc i -> mkpat loc (Ppat_type (long_type_ident i)) - | PaVrn loc s -> mkpat loc (Ppat_variant (conv_con s) None) - | PaLaz loc p -> mkpat loc (Ppat_lazy (patt p)) - | PaMod loc m -> mkpat loc (Ppat_unpack (with_loc m loc)) - | PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p -> - error (loc_of_patt p) "invalid pattern" ] - and mklabpat = - fun - [ <:patt< $i$ = $p$ >> -> (ident ~conv_lid:conv_lab i, patt p) - | p -> error (loc_of_patt p) "invalid pattern" ]; - - value rec expr_fa al = - fun - [ ExApp _ f a -> expr_fa [a :: al] f - | f -> (f, al) ] - ; - - value rec class_expr_fa al = - fun - [ CeApp _ ce a -> class_expr_fa [a :: al] ce - | ce -> (ce, al) ] - ; - - - value rec sep_expr_acc l = - fun - [ ExAcc _ e1 e2 -> sep_expr_acc (sep_expr_acc l e2) e1 - | <:expr@loc< $uid:s$ >> as e -> - match l with - [ [] -> [(loc, [], e)] - | [(loc', sl, e) :: l] -> [(Loc.merge loc loc', [s :: sl], e) :: l] ] - | <:expr< $id:(<:ident< $_$.$_$ >> as i)$ >> -> - let rec normalize_acc = - fun - [ <:ident@_loc< $i1$.$i2$ >> -> - <:expr< $normalize_acc i1$.$normalize_acc i2$ >> - | <:ident@_loc< $i1$ $i2$ >> -> - <:expr< $normalize_acc i1$ $normalize_acc i2$ >> - | <:ident@_loc< $anti:_$ >> | <:ident@_loc< $uid:_$ >> | - <:ident@_loc< $lid:_$ >> as i -> <:expr< $id:i$ >> ] - in sep_expr_acc l (normalize_acc i) - | e -> [(loc_of_expr e, [], e) :: l] ] - ; - - value override_flag loc = - fun [ <:override_flag< ! >> -> Override - | <:override_flag<>> -> Fresh - | _ -> error loc "antiquotation not allowed here" - ]; - - value list_of_opt_ctyp ot acc = - match ot with - [ <:ctyp<>> -> acc - | t -> list_of_ctyp t acc ]; - -value varify_constructors var_names = - let rec loop t = - let desc = - match t.ptyp_desc with - [ - Ptyp_any -> Ptyp_any - | Ptyp_var x -> Ptyp_var x - | Ptyp_arrow label core_type core_type' -> - Ptyp_arrow label (loop core_type) (loop core_type') - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr ({ txt = Lident s }) [] when List.mem s var_names -> - Ptyp_var ("&" ^ s) - | Ptyp_constr longident lst -> - Ptyp_constr longident (List.map loop lst) - | Ptyp_object lst -> - Ptyp_object (List.map loop_core_field lst) - | Ptyp_class longident lst lbl_list -> - Ptyp_class (longident, List.map loop lst, lbl_list) - | Ptyp_alias core_type string -> - Ptyp_alias(loop core_type, string) - | Ptyp_variant row_field_list flag lbl_lst_option -> - Ptyp_variant(List.map loop_row_field row_field_list, flag, lbl_lst_option) - | Ptyp_poly string_lst core_type -> - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package longident lst -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) -] - in - {(t) with ptyp_desc = desc} - and loop_core_field t = - let desc = - match t.pfield_desc with - [ Pfield(n,typ) -> - Pfield(n,loop typ) - | Pfield_var -> - Pfield_var] - in - { (t) with pfield_desc=desc} - and loop_row_field x = - match x with - [ Rtag(label,flag,lst) -> - Rtag(label,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) ] - in - loop; - - - - value rec expr = - fun - [ <:expr@loc< $x$.val >> -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (lident_with_loc "!" loc))) [("", expr x)]) - | ExAcc loc _ _ | <:expr@loc< $id:<:ident< $_$ . $_$ >>$ >> as e -> - let (e, l) = - match sep_expr_acc [] e with - [ [(loc, ml, <:expr@sloc< $uid:s$ >>) :: l] -> - let ca = constructors_arity () in - (mkexp loc (Pexp_construct (mkli sloc (conv_con s) ml) None ca), l) - | [(loc, ml, <:expr@sloc< $lid:s$ >>) :: l] -> - (mkexp loc (Pexp_ident (mkli sloc s ml)), l) - | [(_, [], e) :: l] -> (expr e, l) - | _ -> error loc "bad ast in expression" ] - in - let (_, e) = - List.fold_left - (fun (loc_bp, e1) (loc_ep, ml, e2) -> - match e2 with - [ <:expr@sloc< $lid:s$ >> -> - let loc = Loc.merge loc_bp loc_ep - in (loc, mkexp loc (Pexp_field e1 (mkli sloc (conv_lab s) ml))) - | _ -> error (loc_of_expr e2) "lowercase identifier expected" ]) - (loc, e) l - in - e - | ExAnt loc _ -> error loc "antiquotation not allowed here" - | ExApp loc _ _ as f -> - let (f, al) = expr_fa [] f in - let al = List.map label_expr al in - match (expr f).pexp_desc with - [ Pexp_construct li None _ -> - let al = List.map snd al in - if constructors_arity () then - mkexp loc (Pexp_construct li (Some (mkexp loc (Pexp_tuple al))) True) - else - let a = - match al with - [ [a] -> a - | _ -> mkexp loc (Pexp_tuple al) ] - in - mkexp loc (Pexp_construct li (Some a) False) - | Pexp_variant s None -> - let al = List.map snd al in - let a = - if constructors_arity () then - mkexp loc (Pexp_tuple al) - else - match al with - [ [a] -> a - | _ -> mkexp loc (Pexp_tuple al) ] - in mkexp loc (Pexp_variant s (Some a)) - | _ -> mkexp loc (Pexp_apply (expr f) al) ] - | ExAre loc e1 e2 -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (array_function loc "Array" "get"))) - [("", expr e1); ("", expr e2)]) - | ExArr loc e -> mkexp loc (Pexp_array (List.map expr (list_of_expr e []))) - | ExAsf loc -> mkexp loc Pexp_assertfalse - | ExAss loc e v -> - let e = - match e with - [ <:expr@loc< $x$.val >> -> - Pexp_apply (mkexp loc (Pexp_ident (lident_with_loc ":=" loc))) - [("", expr x); ("", expr v)] - | ExAcc loc _ _ -> - match (expr e).pexp_desc with - [ Pexp_field e lab -> Pexp_setfield e lab (expr v) - | _ -> error loc "bad record access" ] - | ExAre loc e1 e2 -> - Pexp_apply (mkexp loc (Pexp_ident (array_function loc "Array" "set"))) - [("", expr e1); ("", expr e2); ("", expr v)] - | <:expr< $id:(<:ident@lloc< $lid:lab$ >>)$ >> -> Pexp_setinstvar (with_loc lab lloc) (expr v) - | ExSte loc e1 e2 -> - Pexp_apply - (mkexp loc (Pexp_ident (array_function loc "String" "set"))) - [("", expr e1); ("", expr e2); ("", expr v)] - | _ -> error loc "bad left part of assignment" ] - in - mkexp loc e - | ExAsr loc e -> mkexp loc (Pexp_assert (expr e)) - | ExChr loc s -> - mkexp loc (Pexp_constant (Const_char (char_of_char_token loc s))) - | ExCoe loc e t1 t2 -> - let t1 = - match t1 with - [ <:ctyp<>> -> None - | t -> Some (ctyp t) ] in - mkexp loc (Pexp_constraint (expr e) t1 (Some (ctyp t2))) - | ExFlo loc s -> mkexp loc (Pexp_constant (Const_float (remove_underscores s))) - | ExFor loc i e1 e2 df el -> - let e3 = ExSeq loc el in - mkexp loc (Pexp_for (with_loc i loc) (expr e1) (expr e2) (mkdirection df) (expr e3)) - | <:expr@loc< fun [ $PaLab _ lab po$ when $w$ -> $e$ ] >> -> - mkexp loc - (Pexp_function lab None - [(patt_of_lab loc lab po, when_expr e w)]) - | <:expr@loc< fun [ $PaOlbi _ lab p e1$ when $w$ -> $e2$ ] >> -> - let lab = paolab lab p in - mkexp loc - (Pexp_function ("?" ^ lab) (Some (expr e1)) [(patt p, when_expr e2 w)]) - | <:expr@loc< fun [ $PaOlb _ lab p$ when $w$ -> $e$ ] >> -> - let lab = paolab lab p in - mkexp loc - (Pexp_function ("?" ^ lab) None [(patt_of_lab loc lab p, when_expr e w)]) - | ExFun loc a -> mkexp loc (Pexp_function "" None (match_case a [])) - | ExIfe loc e1 e2 e3 -> - mkexp loc (Pexp_ifthenelse (expr e1) (expr e2) (Some (expr e3))) - | ExInt loc s -> - let i = try int_of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int" - ] in mkexp loc (Pexp_constant (Const_int i)) - | ExInt32 loc s -> - let i32 = try Int32.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32" - ] in mkexp loc (Pexp_constant (Const_int32 i32)) - | ExInt64 loc s -> - let i64 = try Int64.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64" - ] in mkexp loc (Pexp_constant (Const_int64 i64)) - | ExNativeInt loc s -> - let nati = try Nativeint.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint" - ] in mkexp loc (Pexp_constant (Const_nativeint nati)) - | ExLab loc _ _ -> error loc "labeled expression not allowed here" - | ExLaz loc e -> mkexp loc (Pexp_lazy (expr e)) - | ExLet loc rf bi e -> - mkexp loc (Pexp_let (mkrf rf) (binding bi []) (expr e)) - | ExLmd loc i me e -> mkexp loc (Pexp_letmodule (with_loc i loc) (module_expr me) (expr e)) - | ExMat loc e a -> mkexp loc (Pexp_match (expr e) (match_case a [])) - | ExNew loc id -> mkexp loc (Pexp_new (long_type_ident id)) - | ExObj loc po cfl -> - let p = - match po with - [ <:patt<>> -> <:patt@loc< _ >> - | p -> p ] - in - let cil = class_str_item cfl [] in - mkexp loc (Pexp_object { pcstr_pat = patt p; pcstr_fields = cil }) - | ExOlb loc _ _ -> error loc "labeled expression not allowed here" - | ExOvr loc iel -> mkexp loc (Pexp_override (mkideexp iel [])) - | ExRec loc lel eo -> - match lel with - [ <:rec_binding<>> -> error loc "empty record" - | _ -> - let eo = - match eo with - [ <:expr<>> -> None - | e -> Some (expr e) ] in - mkexp loc (Pexp_record (mklabexp lel []) eo) ] - | ExSeq _loc e -> - let rec loop = - fun - [ [] -> expr <:expr< () >> - | [e] -> expr e - | [e :: el] -> - let _loc = Loc.merge (loc_of_expr e) _loc in - mkexp _loc (Pexp_sequence (expr e) (loop el)) ] - in - loop (list_of_expr e []) - | ExSnd loc e s -> mkexp loc (Pexp_send (expr e) s) - | ExSte loc e1 e2 -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (array_function loc "String" "get"))) - [("", expr e1); ("", expr e2)]) - | ExStr loc s -> - mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s))) - | ExTry loc e a -> mkexp loc (Pexp_try (expr e) (match_case a [])) - | <:expr@loc< ($e1$, $e2$) >> -> - mkexp loc (Pexp_tuple (List.map expr (list_of_expr e1 (list_of_expr e2 [])))) - | <:expr@loc< ($tup:_$) >> -> error loc "singleton tuple" - | ExTyc loc e t -> mkexp loc (Pexp_constraint (expr e) (Some (ctyp t)) None) - | <:expr@loc< () >> -> - mkexp loc (Pexp_construct (lident_with_loc "()" loc) None True) - | <:expr@loc< $lid:s$ >> -> - mkexp loc (Pexp_ident (lident_with_loc s loc)) - | <:expr@loc< $uid:s$ >> -> - (* let ca = constructors_arity () in *) - mkexp loc (Pexp_construct (lident_with_loc (conv_con s) loc) None True) - | ExVrn loc s -> mkexp loc (Pexp_variant (conv_con s) None) - | ExWhi loc e1 el -> - let e2 = ExSeq loc el in - mkexp loc (Pexp_while (expr e1) (expr e2)) - | <:expr@loc< let open $i$ in $e$ >> -> - mkexp loc (Pexp_open Fresh (long_uident i) (expr e)) - | <:expr@loc< (module $me$ : $pt$) >> -> - mkexp loc (Pexp_constraint (mkexp loc (Pexp_pack (module_expr me)), - Some (mktyp loc (Ptyp_package (package_type pt))), None)) - | <:expr@loc< (module $me$) >> -> - mkexp loc (Pexp_pack (module_expr me)) - | ExFUN loc i e -> - mkexp loc (Pexp_newtype i (expr e)) - | <:expr@loc< $_$,$_$ >> -> error loc "expr, expr: not allowed here" - | <:expr@loc< $_$;$_$ >> -> - error loc "expr; expr: not allowed here, use do {...} or [|...|] to surround them" - | ExId _ _ | ExNil _ as e -> error (loc_of_expr e) "invalid expr" ] - and patt_of_lab _loc lab = - fun - [ <:patt<>> -> patt <:patt< $lid:lab$ >> - | p -> patt p ] - and expr_of_lab _loc lab = - fun - [ <:expr<>> -> expr <:expr< $lid:lab$ >> - | e -> expr e ] - and label_expr = - fun - [ ExLab loc lab eo -> (lab, expr_of_lab loc lab eo) - | ExOlb loc lab eo -> ("?" ^ lab, expr_of_lab loc lab eo) - | e -> ("", expr e) ] - and binding x acc = - match x with - [ <:binding< $x$ and $y$ >> -> - binding x (binding y acc) - | <:binding@_loc< $pat:( <:patt@sloc< $lid:bind_name$ >> )$ = ($e$ : $TyTypePol _ vs ty$) >> -> - (* this code is not pretty because it is temporary *) - let rec id_to_string x = - match x with - [ <:ctyp< $lid:x$ >> -> [x] - | <:ctyp< $x$ $y$ >> -> (id_to_string x) @ (id_to_string y) - | _ -> assert False] - in - let vars = id_to_string vs in - let ampersand_vars = List.map (fun x -> "&" ^ x) vars in - let ty' = varify_constructors vars (ctyp ty) in - let mkexp = mkexp _loc in - let mkpat = mkpat _loc in - let e = mkexp (Pexp_constraint (expr e) (Some (ctyp ty)) None) in - let rec mk_newtypes x = - match x with - [ [newtype :: []] -> mkexp (Pexp_newtype(newtype, e)) - | [newtype :: newtypes] -> - mkexp(Pexp_newtype (newtype,mk_newtypes newtypes)) - | [] -> assert False] - in - let pat = - mkpat (Ppat_constraint (mkpat (Ppat_var (with_loc bind_name sloc)), - mktyp _loc (Ptyp_poly ampersand_vars ty'))) - in - let e = mk_newtypes vars in - [( pat, e) :: acc] - | <:binding@_loc< $p$ = ($e$ : ! $vs$ . $ty$) >> -> - [(patt <:patt< ($p$ : ! $vs$ . $ty$ ) >>, expr e) :: acc] - | <:binding< $p$ = $e$ >> -> [(patt p, expr e) :: acc] - | <:binding<>> -> acc - | _ -> assert False ] - and match_case x acc = - match x with - [ <:match_case< $x$ | $y$ >> -> match_case x (match_case y acc) - | <:match_case< $pat:p$ when $w$ -> $e$ >> -> - [(patt p, when_expr e w) :: acc] - | <:match_case<>> -> acc - | _ -> assert False ] - and when_expr e w = - match w with - [ <:expr<>> -> expr e - | w -> mkexp (loc_of_expr w) (Pexp_when (expr w) (expr e)) ] - and mklabexp x acc = - match x with - [ <:rec_binding< $x$; $y$ >> -> - mklabexp x (mklabexp y acc) - | <:rec_binding< $i$ = $e$ >> -> [(ident ~conv_lid:conv_lab i, expr e) :: acc] - | _ -> assert False ] - and mkideexp x acc = - match x with - [ <:rec_binding<>> -> acc - | <:rec_binding< $x$; $y$ >> -> - mkideexp x (mkideexp y acc) - | <:rec_binding< $id:( <:ident@sloc< $lid:s$ >>)$ = $e$ >> -> [(with_loc s sloc, expr e) :: acc] - | _ -> assert False ] - and mktype_decl x acc = - match x with - [ <:ctyp< $x$ and $y$ >> -> - mktype_decl x (mktype_decl y acc) - | Ast.TyDcl cloc c tl td cl -> - let cl = - List.map - (fun (t1, t2) -> - let loc = Loc.merge (loc_of_ctyp t1) (loc_of_ctyp t2) in - (ctyp t1, ctyp t2, mkloc loc)) - cl - in - [(with_loc c cloc, - type_decl (List.fold_right optional_type_parameters tl []) cl td cloc) :: acc] - | _ -> assert False ] - and module_type = - fun - [ <:module_type@loc<>> -> error loc "abstract/nil module type not allowed here" - | <:module_type@loc< $id:i$ >> -> mkmty loc (Pmty_ident (long_uident i)) - | <:module_type@loc< functor ($n$ : $nt$) -> $mt$ >> -> - mkmty loc (Pmty_functor (with_loc n loc) (module_type nt) (module_type mt)) - | <:module_type@loc< '$_$ >> -> error loc "module type variable not allowed here" - | <:module_type@loc< sig $sl$ end >> -> - mkmty loc (Pmty_signature (sig_item sl [])) - | <:module_type@loc< $mt$ with $wc$ >> -> - mkmty loc (Pmty_with (module_type mt) (mkwithc wc [])) - | <:module_type@loc< module type of $me$ >> -> - mkmty loc (Pmty_typeof (module_expr me)) - | <:module_type< $anti:_$ >> -> assert False ] - and sig_item s l = - match s with - [ <:sig_item<>> -> l - | SgCls loc cd -> - [mksig loc (Psig_class - (List.map class_info_class_type (list_of_class_type cd []))) :: l] - | SgClt loc ctd -> - [mksig loc (Psig_class_type - (List.map class_info_class_type (list_of_class_type ctd []))) :: l] - | <:sig_item< $sg1$; $sg2$ >> -> sig_item sg1 (sig_item sg2 l) - | SgDir _ _ _ -> l - | <:sig_item@loc< exception $uid:s$ >> -> - [mksig loc (Psig_exception (with_loc (conv_con s) loc) []) :: l] - | <:sig_item@loc< exception $uid:s$ of $t$ >> -> - [mksig loc (Psig_exception (with_loc (conv_con s) loc) - (List.map ctyp (list_of_ctyp t []))) :: l] - | SgExc _ _ -> assert False (*FIXME*) - | SgExt loc n t sl -> [mksig loc (Psig_value (with_loc n loc) (mkvalue_desc loc t (list_of_meta_list sl))) :: l] - | SgInc loc mt -> [mksig loc (Psig_include (module_type mt)) :: l] - | SgMod loc n mt -> [mksig loc (Psig_module (with_loc n loc) (module_type mt)) :: l] - | SgRecMod loc mb -> - [mksig loc (Psig_recmodule (module_sig_binding mb [])) :: l] - | SgMty loc n mt -> - let si = - match mt with - [ MtQuo _ _ -> Pmodtype_abstract - | _ -> Pmodtype_manifest (module_type mt) ] - in - [mksig loc (Psig_modtype (with_loc n loc) si) :: l] - | SgOpn loc id -> - [mksig loc (Psig_open Fresh (long_uident id)) :: l] - | SgTyp loc tdl -> [mksig loc (Psig_type (mktype_decl tdl [])) :: l] - | SgVal loc n t -> [mksig loc (Psig_value (with_loc n loc) (mkvalue_desc loc t [])) :: l] - | <:sig_item@loc< $anti:_$ >> -> error loc "antiquotation in sig_item" ] - and module_sig_binding x acc = - match x with - [ <:module_binding< $x$ and $y$ >> -> - module_sig_binding x (module_sig_binding y acc) - | <:module_binding@loc< $s$ : $mt$ >> -> - [(with_loc s loc, module_type mt) :: acc] - | _ -> assert False ] - and module_str_binding x acc = - match x with - [ <:module_binding< $x$ and $y$ >> -> - module_str_binding x (module_str_binding y acc) - | <:module_binding@loc< $s$ : $mt$ = $me$ >> -> - [(with_loc s loc, module_type mt, module_expr me) :: acc] - | _ -> assert False ] - and module_expr = - fun - [ <:module_expr@loc<>> -> error loc "nil module expression" - | <:module_expr@loc< $id:i$ >> -> mkmod loc (Pmod_ident (long_uident i)) - | <:module_expr@loc< $me1$ $me2$ >> -> - mkmod loc (Pmod_apply (module_expr me1) (module_expr me2)) - | <:module_expr@loc< functor ($n$ : $mt$) -> $me$ >> -> - mkmod loc (Pmod_functor (with_loc n loc) (module_type mt) (module_expr me)) - | <:module_expr@loc< struct $sl$ end >> -> - mkmod loc (Pmod_structure (str_item sl [])) - | <:module_expr@loc< ($me$ : $mt$) >> -> - mkmod loc (Pmod_constraint (module_expr me) (module_type mt)) - | <:module_expr@loc< (value $e$ : $pt$) >> -> - mkmod loc (Pmod_unpack ( - mkexp loc (Pexp_constraint (expr e, - Some (mktyp loc (Ptyp_package (package_type pt))), - None)))) - | <:module_expr@loc< (value $e$) >> -> - mkmod loc (Pmod_unpack (expr e)) - | <:module_expr@loc< $anti:_$ >> -> error loc "antiquotation in module_expr" ] - and str_item s l = - match s with - [ <:str_item<>> -> l - | StCls loc cd -> - [mkstr loc (Pstr_class - (List.map class_info_class_expr (list_of_class_expr cd []))) :: l] - | StClt loc ctd -> - [mkstr loc (Pstr_class_type - (List.map class_info_class_type (list_of_class_type ctd []))) :: l] - | <:str_item< $st1$; $st2$ >> -> str_item st1 (str_item st2 l) - | StDir _ _ _ -> l - | <:str_item@loc< exception $uid:s$ >> -> - [mkstr loc (Pstr_exception (with_loc (conv_con s) loc) []) :: l ] - | <:str_item@loc< exception $uid:s$ of $t$ >> -> - [mkstr loc (Pstr_exception (with_loc (conv_con s) loc) - (List.map ctyp (list_of_ctyp t []))) :: l ] - | <:str_item@loc< exception $uid:s$ = $i$ >> -> - [mkstr loc (Pstr_exn_rebind (with_loc (conv_con s) loc) (long_uident ~conv_con i)) :: l ] - | <:str_item@loc< exception $uid:_$ of $_$ = $_$ >> -> - error loc "type in exception alias" - | StExc _ _ _ -> assert False (*FIXME*) - | StExp loc e -> [mkstr loc (Pstr_eval (expr e)) :: l] - | StExt loc n t sl -> [mkstr loc (Pstr_primitive (with_loc n loc) (mkvalue_desc loc t (list_of_meta_list sl))) :: l] - | StInc loc me -> [mkstr loc (Pstr_include (module_expr me)) :: l] - | StMod loc n me -> [mkstr loc (Pstr_module (with_loc n loc) (module_expr me)) :: l] - | StRecMod loc mb -> - [mkstr loc (Pstr_recmodule (module_str_binding mb [])) :: l] - | StMty loc n mt -> [mkstr loc (Pstr_modtype (with_loc n loc) (module_type mt)) :: l] - | StOpn loc id -> - [mkstr loc (Pstr_open Fresh (long_uident id)) :: l] - | StTyp loc tdl -> [mkstr loc (Pstr_type (mktype_decl tdl [])) :: l] - | StVal loc rf bi -> - [mkstr loc (Pstr_value (mkrf rf) (binding bi [])) :: l] - | <:str_item@loc< $anti:_$ >> -> error loc "antiquotation in str_item" ] - and class_type = - fun - [ CtCon loc ViNil id tl -> - mkcty loc - (Pcty_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl []))) - | CtFun loc (TyLab _ lab t) ct -> - mkcty loc (Pcty_fun lab (ctyp t) (class_type ct)) - | CtFun loc (TyOlb loc1 lab t) ct -> - let t = TyApp loc1 (predef_option loc1) t in - mkcty loc (Pcty_fun ("?" ^ lab) (ctyp t) (class_type ct)) - | CtFun loc t ct -> mkcty loc (Pcty_fun "" (ctyp t) (class_type ct)) - | CtSig loc t_o ctfl -> - let t = - match t_o with - [ <:ctyp<>> -> <:ctyp@loc< _ >> - | t -> t ] - in - let cil = class_sig_item ctfl [] in - mkcty loc (Pcty_signature { - pcsig_self = ctyp t; - pcsig_fields = cil; - pcsig_loc = mkloc loc; - }) - | CtCon loc _ _ _ -> - error loc "invalid virtual class inside a class type" - | CtAnt _ _ | CtEq _ _ _ | CtCol _ _ _ | CtAnd _ _ _ | CtNil _ -> - assert False ] - - and class_info_class_expr ci = - match ci with - [ CeEq _ (CeCon loc vir (IdLid nloc name) params) ce -> - let (loc_params, (params, variance)) = - match params with - [ <:ctyp<>> -> (loc, ([], [])) - | t -> (loc_of_ctyp t, List.split (class_parameters t [])) ] - in - {pci_virt = mkvirtual vir; - pci_params = (params, mkloc loc_params); - pci_name = with_loc name nloc; - pci_expr = class_expr ce; - pci_loc = mkloc loc; - pci_variance = variance} - | ce -> error (loc_of_class_expr ce) "bad class definition" ] - and class_info_class_type ci = - match ci with - [ CtEq _ (CtCon loc vir (IdLid nloc name) params) ct | - CtCol _ (CtCon loc vir (IdLid nloc name) params) ct -> - let (loc_params, (params, variance)) = - match params with - [ <:ctyp<>> -> (loc, ([], [])) - | t -> (loc_of_ctyp t, List.split (class_parameters t [])) ] - in - {pci_virt = mkvirtual vir; - pci_params = (params, mkloc loc_params); - pci_name = with_loc name nloc; - pci_expr = class_type ct; - pci_loc = mkloc loc; - pci_variance = variance} - | ct -> error (loc_of_class_type ct) - "bad class/class type declaration/definition" ] - and class_sig_item c l = - match c with - [ <:class_sig_item<>> -> l - | CgCtr loc t1 t2 -> [mkctf loc (Pctf_cstr (ctyp t1, ctyp t2)) :: l] - | <:class_sig_item< $csg1$; $csg2$ >> -> - class_sig_item csg1 (class_sig_item csg2 l) - | CgInh loc ct -> [mkctf loc (Pctf_inher (class_type ct)) :: l] - | CgMth loc s pf t -> - [mkctf loc (Pctf_meth (s, mkprivate pf, mkpolytype (ctyp t))) :: l] - | CgVal loc s b v t -> - [mkctf loc (Pctf_val (s, mkmutable b, mkvirtual v, ctyp t)) :: l] - | CgVir loc s b t -> - [mkctf loc (Pctf_virt (s, mkprivate b, mkpolytype (ctyp t))) :: l] - | CgAnt _ _ -> assert False ] - and class_expr = - fun - [ CeApp loc _ _ as c -> - let (ce, el) = class_expr_fa [] c in - let el = List.map label_expr el in - mkcl loc (Pcl_apply (class_expr ce) el) - | CeCon loc ViNil id tl -> - mkcl loc - (Pcl_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl []))) - | CeFun loc (PaLab _ lab po) ce -> - mkcl loc - (Pcl_fun lab None (patt_of_lab loc lab po) (class_expr ce)) - | CeFun loc (PaOlbi _ lab p e) ce -> - let lab = paolab lab p in - mkcl loc (Pcl_fun ("?" ^ lab) (Some (expr e)) (patt p) (class_expr ce)) - | CeFun loc (PaOlb _ lab p) ce -> - let lab = paolab lab p in - mkcl loc - (Pcl_fun ("?" ^ lab) None (patt_of_lab loc lab p) (class_expr ce)) - | CeFun loc p ce -> mkcl loc (Pcl_fun "" None (patt p) (class_expr ce)) - | CeLet loc rf bi ce -> - mkcl loc (Pcl_let (mkrf rf) (binding bi []) (class_expr ce)) - | CeStr loc po cfl -> - let p = - match po with - [ <:patt<>> -> <:patt@loc< _ >> - | p -> p ] - in - let cil = class_str_item cfl [] in - mkcl loc (Pcl_structure { - pcstr_pat = patt p; - pcstr_fields = cil; - }) - | CeTyc loc ce ct -> - mkcl loc (Pcl_constraint (class_expr ce) (class_type ct)) - | CeCon loc _ _ _ -> - error loc "invalid virtual class inside a class expression" - | CeAnt _ _ | CeEq _ _ _ | CeAnd _ _ _ | CeNil _ -> assert False ] - and class_str_item c l = - match c with - [ CrNil _ -> l - | CrCtr loc t1 t2 -> [mkcf loc (Pcf_constr (ctyp t1, ctyp t2)) :: l] - | <:class_str_item< $cst1$; $cst2$ >> -> - class_str_item cst1 (class_str_item cst2 l) - | CrInh loc ov ce pb -> - let opb = if pb = "" then None else Some pb in - [mkcf loc (Pcf_inher (override_flag loc ov) (class_expr ce) opb) :: l] - | CrIni loc e -> [mkcf loc (Pcf_init (expr e)) :: l] - | CrMth loc s ov pf e t -> - let t = - match t with - [ <:ctyp<>> -> None - | t -> Some (mkpolytype (ctyp t)) ] in - let e = mkexp loc (Pexp_poly (expr e) t) in - [mkcf loc (Pcf_meth (with_loc s loc, mkprivate pf, override_flag loc ov, e)) :: l] - | CrVal loc s ov mf e -> - [mkcf loc (Pcf_val (with_loc s loc, mkmutable mf, override_flag loc ov, expr e)) :: l] - | CrVir loc s pf t -> - [mkcf loc (Pcf_virt (with_loc s loc, mkprivate pf, mkpolytype (ctyp t))) :: l] - | CrVvr loc s mf t -> - [mkcf loc (Pcf_valvirt (with_loc s loc, mkmutable mf, ctyp t)) :: l] - | CrAnt _ _ -> assert False ]; - - value sig_item ast = sig_item ast []; - value str_item ast = str_item ast []; - - value directive = - fun - [ <:expr<>> -> Pdir_none - | ExStr _ s -> Pdir_string s - | ExInt _ i -> Pdir_int (int_of_string i) - | <:expr< True >> -> Pdir_bool True - | <:expr< False >> -> Pdir_bool False - | e -> Pdir_ident (ident_noloc (ident_of_expr e)) ] - ; - - value phrase = - fun - [ StDir _ d dp -> Ptop_dir d (directive dp) - | si -> Ptop_def (str_item si) ] - ; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli ocaml-4.02.3/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,32 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2002-2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -module Make (Camlp4Ast : Sig.Camlp4Ast) : sig - open Camlp4Ast; - - (** {6 Useful functions} *) - - 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 -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Camlp4Ast.mlast ocaml-4.02.3/camlp4/Camlp4/Struct/Camlp4Ast.mlast --- ocaml-4.01.0/camlp4/Camlp4/Struct/Camlp4Ast.mlast 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Camlp4Ast.mlast 1970-01-01 01:00:00.000000000 +0100 @@ -1,544 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Loc : Sig.Loc) -: Sig.Camlp4Ast with module Loc = Loc -= struct - module Loc = Loc; - - module Ast = struct - include Sig.MakeCamlp4Ast Loc; - - value safe_string_escaped s = - if String.length s > 2 && s.[0] = '\\' && s.[1] = '$' then s - else String.escaped s; - end; - - include Ast; - - external loc_of_ctyp : ctyp -> Loc.t = "%field0"; - external loc_of_patt : patt -> Loc.t = "%field0"; - external loc_of_expr : expr -> Loc.t = "%field0"; - external loc_of_module_type : module_type -> Loc.t = "%field0"; - external loc_of_module_expr : module_expr -> Loc.t = "%field0"; - external loc_of_sig_item : sig_item -> Loc.t = "%field0"; - external loc_of_str_item : str_item -> Loc.t = "%field0"; - external loc_of_class_type : class_type -> Loc.t = "%field0"; - external loc_of_class_sig_item : class_sig_item -> Loc.t = "%field0"; - external loc_of_class_expr : class_expr -> Loc.t = "%field0"; - external loc_of_class_str_item : class_str_item -> Loc.t = "%field0"; - external loc_of_with_constr : with_constr -> Loc.t = "%field0"; - external loc_of_binding : binding -> Loc.t = "%field0"; - external loc_of_rec_binding : rec_binding -> Loc.t = "%field0"; - external loc_of_module_binding : module_binding -> Loc.t = "%field0"; - external loc_of_match_case : match_case -> Loc.t = "%field0"; - external loc_of_ident : ident -> Loc.t = "%field0"; - - value ghost = Loc.ghost; - - value rec is_module_longident = - fun - [ <:ident< $_$.$i$ >> -> is_module_longident i - | <:ident< $i1$ $i2$ >> -> - is_module_longident i1 && is_module_longident i2 - | <:ident< $uid:_$ >> -> True - | _ -> False ]; - - value ident_of_expr = - let error () = - invalid_arg "ident_of_expr: this expression is not an identifier" in - let rec self = - fun - [ <:expr@_loc< $e1$ $e2$ >> -> <:ident< $self e1$ $self e2$ >> - | <:expr@_loc< $e1$.$e2$ >> -> <:ident< $self e1$.$self e2$ >> - | <:expr< $lid:_$ >> -> error () - | <:expr< $id:i$ >> -> if is_module_longident i then i else error () - | _ -> error () ] in - fun - [ <:expr< $id:i$ >> -> i - | <:expr< $_$ $_$ >> -> error () - | t -> self t ]; - - value ident_of_ctyp = - let error () = - invalid_arg "ident_of_ctyp: this type is not an identifier" in - let rec self = - fun - [ <:ctyp@_loc< $t1$ $t2$ >> -> <:ident< $self t1$ $self t2$ >> - | <:ctyp< $lid:_$ >> -> error () - | <:ctyp< $id:i$ >> -> if is_module_longident i then i else error () - | _ -> error () ] in - fun - [ <:ctyp< $id:i$ >> -> i - | t -> self t ]; - - value ident_of_patt = - let error () = - invalid_arg "ident_of_patt: this pattern is not an identifier" in - let rec self = - fun - [ <:patt@_loc< $p1$ $p2$ >> -> <:ident< $self p1$ $self p2$ >> - | <:patt< $lid:_$ >> -> error () - | <:patt< $id:i$ >> -> if is_module_longident i then i else error () - | _ -> error () ] in - fun - [ <:patt< $id:i$ >> -> i - | p -> self p ]; - - value rec is_irrefut_patt = - fun - [ <:patt< $lid:_$ >> -> True - | <:patt< () >> -> True - | <:patt< _ >> -> True - | <:patt<>> -> True (* why not *) - | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y - | <:patt< { $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< $p1$ | $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 (* could be more fine grained *) - | <:patt< $p1$ $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 - | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p - | <:patt< ($tup:pl$) >> -> is_irrefut_patt pl - | <:patt< ? $_$ >> -> True - | <:patt< ? $_$ : ($p$) >> -> is_irrefut_patt p - | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p - | <:patt< ~ $_$ >> -> True - | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p - | <:patt< lazy $p$ >> -> is_irrefut_patt p - | <:patt< $id:_$ >> -> False (* here one need to know the arity of constructors *) - | <:patt< (module $_$) >> -> True - | <:patt< `$_$ >> | <:patt< $str:_$ >> | <:patt< $_$ .. $_$ >> | - <:patt< $flo:_$ >> | <:patt< $nativeint:_$ >> | <:patt< $int64:_$ >> | - <:patt< $int32:_$ >> | <:patt< $int:_$ >> | <:patt< $chr:_$ >> | - <:patt< #$_$ >> | <:patt< [| $_$ |] >> | <:patt< $anti:_$ >> -> False - ]; - - value rec is_constructor = - fun - [ <:ident< $_$.$i$ >> -> is_constructor i - | <:ident< $uid:_$ >> -> True - | <:ident< $lid:_$ >> | <:ident< $_$ $_$ >> -> False - | <:ident< $anti:_$ >> -> assert False ]; - - value is_patt_constructor = - fun - [ <:patt< $id:i$ >> -> is_constructor i - | <:patt< `$_$ >> -> True - | _ -> False ]; - - value rec is_expr_constructor = - fun - [ <:expr< $id:i$ >> -> is_constructor i - | <:expr< $e1$.$e2$ >> -> is_expr_constructor e1 && is_expr_constructor e2 - | <:expr< `$_$ >> -> True - | _ -> False ]; - - value rec tyOr_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$ | $tyOr_of_list ts$ >> ]; - - value rec tyAnd_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$ and $tyAnd_of_list ts$ >> ]; - - value rec tySem_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$ ; $tySem_of_list ts$ >> ]; - - value rec tyCom_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$, $tyCom_of_list ts$ >> ]; - - value rec tyAmp_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$ & $tyAmp_of_list ts$ >> ]; - - value rec tySta_of_list = - fun - [ [] -> <:ctyp@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_ctyp t in <:ctyp< $t$ * $tySta_of_list ts$ >> ]; - - value rec stSem_of_list = - fun - [ [] -> <:str_item@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_str_item t in <:str_item< $t$ ; $stSem_of_list ts$ >> ]; - - value rec sgSem_of_list = - fun - [ [] -> <:sig_item@ghost<>> - | [t] -> t - | [t::ts] -> - let _loc = loc_of_sig_item t in <:sig_item< $t$ ; $sgSem_of_list ts$ >> ]; - - value rec biAnd_of_list = - fun - [ [] -> <:binding@ghost<>> - | [b] -> b - | [b::bs] -> - let _loc = loc_of_binding b in <:binding< $b$ and $biAnd_of_list bs$ >> ]; - - value rec rbSem_of_list = - fun - [ [] -> <:rec_binding@ghost<>> - | [b] -> b - | [b::bs] -> - let _loc = loc_of_rec_binding b in - <:rec_binding< $b$; $rbSem_of_list bs$ >> ]; - - value rec wcAnd_of_list = - fun - [ [] -> <:with_constr@ghost<>> - | [w] -> w - | [w::ws] -> - let _loc = loc_of_with_constr w in - <:with_constr< $w$ and $wcAnd_of_list ws$ >> ]; - - value rec idAcc_of_list = - fun - [ [] -> assert False - | [i] -> i - | [i::is] -> - let _loc = loc_of_ident i in - <:ident< $i$ . $idAcc_of_list is$ >> ]; - - value rec idApp_of_list = - fun - [ [] -> assert False - | [i] -> i - | [i::is] -> - let _loc = loc_of_ident i in - <:ident< $i$ $idApp_of_list is$ >> ]; - - value rec mcOr_of_list = - fun - [ [] -> <:match_case@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_match_case x in - <:match_case< $x$ | $mcOr_of_list xs$ >> ]; - - value rec mbAnd_of_list = - fun - [ [] -> <:module_binding@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_module_binding x in - <:module_binding< $x$ and $mbAnd_of_list xs$ >> ]; - - value rec meApp_of_list = - fun - [ [] -> assert False - | [x] -> x - | [x::xs] -> - let _loc = loc_of_module_expr x in - <:module_expr< $x$ $meApp_of_list xs$ >> ]; - - value rec ceAnd_of_list = - fun - [ [] -> <:class_expr@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_class_expr x in - <:class_expr< $x$ and $ceAnd_of_list xs$ >> ]; - - value rec ctAnd_of_list = - fun - [ [] -> <:class_type@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_class_type x in - <:class_type< $x$ and $ctAnd_of_list xs$ >> ]; - - value rec cgSem_of_list = - fun - [ [] -> <:class_sig_item@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_class_sig_item x in - <:class_sig_item< $x$; $cgSem_of_list xs$ >> ]; - - value rec crSem_of_list = - fun - [ [] -> <:class_str_item@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_class_str_item x in - <:class_str_item< $x$; $crSem_of_list xs$ >> ]; - - value rec paSem_of_list = - fun - [ [] -> <:patt@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_patt x in - <:patt< $x$; $paSem_of_list xs$ >> ]; - - value rec paCom_of_list = - fun - [ [] -> <:patt@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_patt x in - <:patt< $x$, $paCom_of_list xs$ >> ]; - - value rec exSem_of_list = - fun - [ [] -> <:expr@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_expr x in - <:expr< $x$; $exSem_of_list xs$ >> ]; - - value rec exCom_of_list = - fun - [ [] -> <:expr@ghost<>> - | [x] -> x - | [x::xs] -> - let _loc = loc_of_expr x in - <:expr< $x$, $exCom_of_list xs$ >> ]; - - value ty_of_stl = - fun - [ (_loc, s, []) -> <:ctyp< $uid:s$ >> - | (_loc, s, tl) -> <:ctyp< $uid:s$ of $tyAnd_of_list tl$ >> ]; - - value ty_of_sbt = - fun - [ (_loc, s, True, t) -> <:ctyp< $lid:s$ : mutable $t$ >> - | (_loc, s, False, t) -> <:ctyp< $lid:s$ : $t$ >> ]; - - value bi_of_pe (p, e) = let _loc = loc_of_patt p in <:binding< $p$ = $e$ >>; - value sum_type_of_list l = tyOr_of_list (List.map ty_of_stl l); - value record_type_of_list l = tySem_of_list (List.map ty_of_sbt l); - value binding_of_pel l = biAnd_of_list (List.map bi_of_pe l); - - value rec pel_of_binding = - fun - [ <:binding< $b1$ and $b2$ >> -> pel_of_binding b1 @ pel_of_binding b2 - | <:binding< $p$ = $e$ >> -> [(p, e)] - | _ -> assert False ]; - - value rec list_of_binding x acc = - match x with - [ <:binding< $b1$ and $b2$ >> -> - list_of_binding b1 (list_of_binding b2 acc) - | t -> [t :: acc] ]; - - value rec list_of_rec_binding x acc = - match x with - [ <:rec_binding< $b1$; $b2$ >> -> - list_of_rec_binding b1 (list_of_rec_binding b2 acc) - | t -> [t :: acc] ]; - - value rec list_of_with_constr x acc = - match x with - [ <:with_constr< $w1$ and $w2$ >> -> - list_of_with_constr w1 (list_of_with_constr w2 acc) - | t -> [t :: acc] ]; - - value rec list_of_ctyp x acc = - match x with - [ <:ctyp<>> -> acc - | <:ctyp< $x$ & $y$ >> | <:ctyp< $x$, $y$ >> | - <:ctyp< $x$ * $y$ >> | <:ctyp< $x$; $y$ >> | - <:ctyp< $x$ and $y$ >> | <:ctyp< $x$ | $y$ >> -> - list_of_ctyp x (list_of_ctyp y acc) - | x -> [x :: acc] ]; - - value rec list_of_patt x acc = - match x with - [ <:patt<>> -> acc - | <:patt< $x$, $y$ >> | <:patt< $x$; $y$ >> -> - list_of_patt x (list_of_patt y acc) - | x -> [x :: acc] ]; - - value rec list_of_expr x acc = - match x with - [ <:expr<>> -> acc - | <:expr< $x$, $y$ >> | <:expr< $x$; $y$ >> -> - list_of_expr x (list_of_expr y acc) - | x -> [x :: acc] ]; - - value rec list_of_str_item x acc = - match x with - [ <:str_item<>> -> acc - | <:str_item< $x$; $y$ >> -> - list_of_str_item x (list_of_str_item y acc) - | x -> [x :: acc] ]; - - value rec list_of_sig_item x acc = - match x with - [ <:sig_item<>> -> acc - | <:sig_item< $x$; $y$ >> -> - list_of_sig_item x (list_of_sig_item y acc) - | x -> [x :: acc] ]; - - value rec list_of_class_sig_item x acc = - match x with - [ <:class_sig_item<>> -> acc - | <:class_sig_item< $x$; $y$ >> -> - list_of_class_sig_item x (list_of_class_sig_item y acc) - | x -> [x :: acc] ]; - - value rec list_of_class_str_item x acc = - match x with - [ <:class_str_item<>> -> acc - | <:class_str_item< $x$; $y$ >> -> - list_of_class_str_item x (list_of_class_str_item y acc) - | x -> [x :: acc] ]; - - value rec list_of_class_type x acc = - match x with - [ <:class_type< $x$ and $y$ >> -> - list_of_class_type x (list_of_class_type y acc) - | x -> [x :: acc] ]; - - value rec list_of_class_expr x acc = - match x with - [ <:class_expr< $x$ and $y$ >> -> - list_of_class_expr x (list_of_class_expr y acc) - | x -> [x :: acc] ]; - - value rec list_of_module_expr x acc = - match x with - [ <:module_expr< $x$ $y$ >> -> - list_of_module_expr x (list_of_module_expr y acc) - | x -> [x :: acc] ]; - - value rec list_of_match_case x acc = - match x with - [ <:match_case<>> -> acc - | <:match_case< $x$ | $y$ >> -> - list_of_match_case x (list_of_match_case y acc) - | x -> [x :: acc] ]; - - value rec list_of_ident x acc = - match x with - [ <:ident< $x$ . $y$ >> | <:ident< $x$ $y$ >> -> - list_of_ident x (list_of_ident y acc) - | x -> [x :: acc] ]; - - value rec list_of_module_binding x acc = - match x with - [ <:module_binding< $x$ and $y$ >> -> - 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 - (** 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 -> Ast.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 -> Ast.expr; - end; - - module MetaLoc = struct - value meta_loc_patt _loc location = - let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in - <:patt< Loc.of_tuple - ($`str:a$, $`int:b$, $`int:c$, $`int:d$, - $`int:e$, $`int:f$, $`int:g$, - $if h then <:patt< True >> else <:patt< False >> $) >>; - value meta_loc_expr _loc location = - let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in - <:expr< Loc.of_tuple - ($`str:a$, $`int:b$, $`int:c$, $`int:d$, - $`int:e$, $`int:f$, $`int:g$, - $if h then <:expr< True >> else <:expr< False >> $) >>; - end; - - module MetaGhostLoc = struct - value meta_loc_patt _loc _ = <:patt< Loc.ghost >>; - value meta_loc_expr _loc _ = <:expr< Loc.ghost >>; - end; - - module MetaLocVar = struct - value meta_loc_patt _loc _ = <:patt< $lid:Loc.name.val$ >>; - value meta_loc_expr _loc _ = <:expr< $lid:Loc.name.val$ >>; - end; - - module Make (MetaLoc : META_LOC) = struct - open MetaLoc; - - value meta_loc = meta_loc_expr; - module Expr = Camlp4Filters.MetaGeneratorExpr Ast; - value meta_loc = meta_loc_patt; - module Patt = Camlp4Filters.MetaGeneratorPatt Ast; - end; - - end; - - class map = Camlp4MapGenerator.generated; - - class fold = Camlp4FoldGenerator.generated; - - value map_expr f = object - inherit map as super; - method expr x = f (super#expr x); - end; - value map_patt f = object - inherit map as super; - method patt x = f (super#patt x); - end; - value map_ctyp f = object - inherit map as super; - method ctyp x = f (super#ctyp x); - end; - value map_str_item f = object - inherit map as super; - method str_item x = f (super#str_item x); - end; - value map_sig_item f = object - inherit map as super; - method sig_item x = f (super#sig_item x); - end; - value map_loc f = object - inherit map as super; - method loc x = f (super#loc x); - end; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/CleanAst.ml ocaml-4.02.3/camlp4/Camlp4/Struct/CleanAst.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/CleanAst.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/CleanAst.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,145 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -(** This module is suppose to contain nils elimination. *) -module Make (Ast : Sig.Camlp4Ast) = struct - - class clean_ast = object - - inherit Ast.map as super; - - 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; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/CommentFilter.ml ocaml-4.02.3/camlp4/Camlp4/Struct/CommentFilter.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/CommentFilter.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/CommentFilter.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,56 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Token : Sig.Camlp4Token) = struct - open Token; - - type t = (Stream.t (string * Loc.t) * Queue.t (string * Loc.t)); - - value mk () = - let q = Queue.create () in - let f _ = - debug comments "take...@\n" in - try Some (Queue.take q) with [ Queue.Empty -> None ] - in (Stream.from f, q); - - value filter (_, q) = - let rec self = - parser - [ [: ` (Sig.COMMENT x, loc); xs :] -> - do { Queue.add (x, loc) q; - debug comments "add: %S at %a@\n" x Loc.dump loc in - self xs } - | [: ` x; xs :] -> - (* debug comments "Found %a at %a@." Token.print x Loc.dump loc in *) - [: ` x; self xs :] - | [: :] -> [: :] ] - in self; - - value take_list (_, q) = - let rec self accu = - if Queue.is_empty q then accu else self [Queue.take q :: accu] - in self []; - - value take_stream = fst; - - value define token_fiter comments_strm = - debug comments "Define a comment filter@\n" in - Token.Filter.define_filter token_fiter - (fun previous strm -> previous (filter comments_strm strm)); - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/CommentFilter.mli ocaml-4.02.3/camlp4/Camlp4/Struct/CommentFilter.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/CommentFilter.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/CommentFilter.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,33 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Token : Sig.Camlp4Token) : sig - open Token; - - type t; - - value mk : unit -> t; - - value define : Token.Filter.t -> t -> unit; - - value filter : t -> Stream.t (Token.t * Loc.t) -> Stream.t (Token.t * Loc.t); - - value take_list : t -> list (string * Loc.t); - - value take_stream : t -> Stream.t (string * Loc.t); -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/DynAst.ml ocaml-4.02.3/camlp4/Camlp4/Struct/DynAst.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/DynAst.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/DynAst.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,91 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Ast) : Sig.DynAst with module Ast = Ast = struct - module Ast = Ast; - type tag 'a = - [ Tag_ctyp - | Tag_patt - | Tag_expr - | Tag_module_type - | Tag_sig_item - | Tag_with_constr - | Tag_module_expr - | Tag_str_item - | Tag_class_type - | Tag_class_sig_item - | Tag_class_expr - | Tag_class_str_item - | Tag_match_case - | Tag_ident - | Tag_binding - | Tag_rec_binding - | Tag_module_binding ]; - - value string_of_tag = - fun - [ Tag_ctyp -> "ctyp" - | Tag_patt -> "patt" - | Tag_expr -> "expr" - | Tag_module_type -> "module_type" - | Tag_sig_item -> "sig_item" - | Tag_with_constr -> "with_constr" - | Tag_module_expr -> "module_expr" - | Tag_str_item -> "str_item" - | Tag_class_type -> "class_type" - | Tag_class_sig_item -> "class_sig_item" - | Tag_class_expr -> "class_expr" - | Tag_class_str_item -> "class_str_item" - | Tag_match_case -> "match_case" - | Tag_ident -> "ident" - | Tag_binding -> "binding" - | Tag_rec_binding -> "rec_binding" - | Tag_module_binding -> "module_binding" ]; - - value ctyp_tag = Tag_ctyp; - value patt_tag = Tag_patt; - value expr_tag = Tag_expr; - value module_type_tag = Tag_module_type; - value sig_item_tag = Tag_sig_item; - value with_constr_tag = Tag_with_constr; - value module_expr_tag = Tag_module_expr; - value str_item_tag = Tag_str_item; - value class_type_tag = Tag_class_type; - value class_sig_item_tag = Tag_class_sig_item; - value class_expr_tag = Tag_class_expr; - value class_str_item_tag = Tag_class_str_item; - value match_case_tag = Tag_match_case; - value ident_tag = Tag_ident; - value binding_tag = Tag_binding; - value rec_binding_tag = Tag_rec_binding; - value module_binding_tag = Tag_module_binding; - - type dyn; - external dyn_tag : tag 'a -> tag dyn = "%identity"; - - module Pack(X : sig type t 'a; end) = struct - (* These Obj.* hacks should be avoided with GADTs *) - type pack = (tag dyn * Obj.t); - exception Pack_error; - value pack tag v = (dyn_tag tag, Obj.repr v); - value unpack (tag : tag 'a) (tag', obj) = - if dyn_tag tag = tag' then (Obj.obj obj : X.t 'a) else raise Pack_error; - value print_tag f (tag, _) = Format.pp_print_string f (string_of_tag tag); - end; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/DynLoader.ml ocaml-4.02.3/camlp4/Camlp4/Struct/DynLoader.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/DynLoader.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/DynLoader.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,84 +0,0 @@ -(* camlp4r pa_macro.cmo *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2001-2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - - -type t = Queue.t string; - -exception Error of string and string; - -value include_dir x y = Queue.add y x; - -value fold_load_path x f acc = Queue.fold (fun x y -> f y x) acc x; - -value mk ?(ocaml_stdlib = True) ?(camlp4_stdlib = True) () = - let q = Queue.create () in do { - if ocaml_stdlib then include_dir q Camlp4_config.ocaml_standard_library else (); - if camlp4_stdlib then do { - include_dir q Camlp4_config.camlp4_standard_library; - include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Parsers"); - include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Printers"); - include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Filters"); - } else (); - include_dir q "."; - q -}; - -(* Load files in core *) - -value find_in_path x name = - if not (Filename.is_implicit name) then - if Sys.file_exists name then name else raise Not_found - else - let res = - fold_load_path x - (fun dir -> - fun - [ None -> - let fullname = Filename.concat dir name in - if Sys.file_exists fullname then Some fullname else None - | x -> x ]) None - in match res with [ None -> raise Not_found | Some x -> x ]; - -value load = - let _initialized = ref False in - fun _path file -> - do { - if not _initialized.val then - try do { - Dynlink.init (); - Dynlink.allow_unsafe_modules True; - _initialized.val := True - } - with - [ Dynlink.Error e -> - raise (Error "Camlp4's dynamic loader initialization" (Dynlink.error_message e)) ] - else (); - let fname = - try find_in_path _path file with - [ Not_found -> raise (Error file "file not found in path") ] - in - try Dynlink.loadfile fname with - [ Dynlink.Error e -> raise (Error fname (Dynlink.error_message e)) ] - }; - - -value is_native = Dynlink.is_native; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/DynLoader.mli ocaml-4.02.3/camlp4/Camlp4/Struct/DynLoader.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/DynLoader.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/DynLoader.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,20 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -include Sig.DynLoader; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/EmptyError.ml ocaml-4.02.3/camlp4/Camlp4/Struct/EmptyError.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/EmptyError.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/EmptyError.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,22 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -type t = unit; -exception E of t; -value print _ = assert False; -value to_string _ = assert False; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/EmptyError.mli ocaml-4.02.3/camlp4/Camlp4/Struct/EmptyError.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/EmptyError.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/EmptyError.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,19 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -include Sig.Error; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/EmptyPrinter.ml ocaml-4.02.3/camlp4/Camlp4/Struct/EmptyPrinter.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/EmptyPrinter.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/EmptyPrinter.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,22 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Ast) = struct - value print_interf ?input_file:(_) ?output_file:(_) _ = failwith "No interface printer"; - value print_implem ?input_file:(_) ?output_file:(_) _ = failwith "No implementation printer"; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/EmptyPrinter.mli ocaml-4.02.3/camlp4/Camlp4/Struct/EmptyPrinter.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/EmptyPrinter.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/EmptyPrinter.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,19 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006-2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Ast) : (Sig.Printer Ast).S; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/FreeVars.ml ocaml-4.02.3/camlp4/Camlp4/Struct/FreeVars.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/FreeVars.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/FreeVars.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,127 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Camlp4Ast) = struct - - module S = Set.Make String; - - class c_fold_pattern_vars ['accu] f init = - object - inherit Ast.fold as super; - value acc = init; - method acc : 'accu = acc; - method patt = - fun - [ <:patt< $lid:s$ >> | <:patt< ~ $s$ >> | <:patt< ? $s$ >> -> - {< acc = f s acc >} - | p -> super#patt p ]; - end; - - value fold_pattern_vars f p init = ((new c_fold_pattern_vars f init)#patt p)#acc; - - value rec fold_binding_vars f bi acc = - match bi with - [ <:binding< $bi1$ and $bi2$ >> -> - fold_binding_vars f bi1 (fold_binding_vars f bi2 acc) - | <:binding< $p$ = $_$ >> -> fold_pattern_vars f p acc - | <:binding<>> -> acc - | <:binding< $anti:_$ >> -> assert False ]; - - class fold_free_vars ['accu] (f : string -> 'accu -> 'accu) ?(env_init = S.empty) free_init = - object (o) - inherit Ast.fold as super; - value free : 'accu = free_init; - value env : S.t = env_init; - - method free = free; - method set_env env = {< env = env >}; - method add_atom s = {< env = S.add s env >}; - method add_patt p = {< env = fold_pattern_vars S.add p env >}; - method add_binding bi = {< env = fold_binding_vars S.add bi env >}; - - method expr = - fun - [ <:expr< $lid:s$ >> | <:expr< ~ $s$ >> | <:expr< ? $s$ >> -> - if S.mem s env then o else {< free = f s free >} - - | <:expr< let $bi$ in $e$ >> -> - (((o#add_binding bi)#expr e)#set_env env)#binding bi - - | <:expr< let rec $bi$ in $e$ >> -> - (((o#add_binding bi)#expr e)#binding bi)#set_env env - - | <:expr< for $s$ = $e1$ $to:_$ $e2$ do { $e3$ } >> -> - ((((o#expr e1)#expr e2)#add_atom s)#expr e3)#set_env env - - | <:expr< $id:_$ >> | <:expr< new $_$ >> -> o - - | <:expr< object ($p$) $cst$ end >> -> - ((o#add_patt p)#class_str_item cst)#set_env env - - | e -> super#expr e ]; - - method match_case = - fun - [ <:match_case< $p$ when $e1$ -> $e2$ >> -> - (((o#add_patt p)#expr e1)#expr e2)#set_env env - | m -> super#match_case m ]; - - method str_item = - fun - [ <:str_item< external $s$ : $t$ = $_$ >> -> - (o#ctyp t)#add_atom s - | <:str_item< value $bi$ >> -> - (o#binding bi)#add_binding bi - | <:str_item< value rec $bi$ >> -> - (o#add_binding bi)#binding bi - | st -> super#str_item st ]; - - method class_expr = - fun - [ <:class_expr< fun $p$ -> $ce$ >> -> - ((o#add_patt p)#class_expr ce)#set_env env - | <:class_expr< let $bi$ in $ce$ >> -> - (((o#binding bi)#add_binding bi)#class_expr ce)#set_env env - | <:class_expr< let rec $bi$ in $ce$ >> -> - (((o#add_binding bi)#binding bi)#class_expr ce)#set_env env - | <:class_expr< object ($p$) $cst$ end >> -> - ((o#add_patt p)#class_str_item cst)#set_env env - | ce -> super#class_expr ce ]; - - method class_str_item = - fun - [ <:class_str_item< inherit $override:_$ $_$ >> as cst -> super#class_str_item cst - | <:class_str_item< inherit $override:_$ $ce$ as $s$ >> -> - (o#class_expr ce)#add_atom s - | <:class_str_item< value $override:_$ $mutable:_$ $s$ = $e$ >> -> - (o#expr e)#add_atom s - | <:class_str_item< value virtual $mutable:_$ $s$ : $t$ >> -> - (o#ctyp t)#add_atom s - | cst -> super#class_str_item cst ]; - - method module_expr = fun - [ <:module_expr< struct $st$ end >> -> - (o#str_item st)#set_env env - | me -> super#module_expr me ]; - - end; - - value free_vars env_init e = - let fold = new fold_free_vars S.add ~env_init S.empty in (fold#expr e)#free; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/FreeVars.mli ocaml-4.02.3/camlp4/Camlp4/Struct/FreeVars.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/FreeVars.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/FreeVars.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,48 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -module Make (Ast : Sig.Camlp4Ast) : sig - module S : Set.S with type elt = string; - - value fold_binding_vars : (string -> 'accu -> 'accu) -> Ast.binding -> 'accu -> 'accu; - - class c_fold_pattern_vars ['accu] : [string -> 'accu -> 'accu] -> ['accu] -> - object - inherit Ast.fold; - value acc : 'accu; - method acc : 'accu; - end; - - value fold_pattern_vars : (string -> 'accu -> 'accu) -> Ast.patt -> 'accu -> 'accu; - - class fold_free_vars ['accu] : [string -> 'accu -> 'accu] -> [?env_init:S.t] -> ['accu] -> - object ('self_type) - inherit Ast.fold; - value free : 'accu; - value env : S.t; - method free : 'accu; - method set_env : S.t -> 'self_type; - method add_atom : string -> 'self_type; - method add_patt : Ast.patt -> 'self_type; - method add_binding : Ast.binding -> 'self_type; - end; - - value free_vars : S.t -> Ast.expr -> S.t; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Delete.ml ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Delete.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Delete.ml 2012-10-25 14:28:15.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Delete.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,187 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -exception Rule_not_found of (string * string); - -let () = - Printexc.register_printer - (fun - [ Rule_not_found (symbols, entry) -> - let msg = Printf.sprintf "rule %S cannot be found in entry\n%s" symbols entry in - Some msg - | _ -> None ]) in () -; - -module Make (Structure : Structure.S) = struct - module Tools = Tools.Make Structure; - module Parser = Parser.Make Structure; - module Print = Print.Make Structure; - open Structure; - -value raise_rule_not_found entry symbols = - let to_string f x = - let buff = Buffer.create 128 in - let ppf = Format.formatter_of_buffer buff in - do { - f ppf x; - Format.pp_print_flush ppf (); - Buffer.contents buff - } in - let entry = to_string Print.entry entry in - let symbols = to_string Print.print_rule symbols in - raise (Rule_not_found (symbols, entry)) -; - -(* Deleting a rule *) - -(* [delete_rule_in_tree] returns - [Some (dsl, t)] if success - [dsl] = - Some (list of deleted nodes) if branch deleted - None if action replaced by previous version of action - [t] = remaining tree - [None] if failure *) - -value delete_rule_in_tree entry = - let rec delete_in_tree symbols tree = - match (symbols, tree) with - [ ([s :: sl], Node n) -> - if Tools.logically_eq_symbols entry s n.node then delete_son sl n - else - match delete_in_tree symbols n.brother with - [ Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) - | None -> None ] - | ([_ :: _], _) -> None - | ([], Node n) -> - match delete_in_tree [] n.brother with - [ Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) - | None -> None ] - | ([], DeadEnd) -> None - | ([], LocAct _ []) -> Some (Some [], DeadEnd) - | ([], LocAct _ [action :: list]) -> Some (None, LocAct action list) ] - and delete_son sl n = - match delete_in_tree sl n.son with - [ Some (Some dsl, DeadEnd) -> Some (Some [n.node :: dsl], n.brother) - | Some (Some dsl, t) -> - let t = Node {node = n.node; son = t; brother = n.brother} in - Some (Some [n.node :: dsl], t) - | Some (None, t) -> - let t = Node {node = n.node; son = t; brother = n.brother} in - Some (None, t) - | None -> None ] - in - delete_in_tree -; -value rec decr_keyw_use gram = - fun - [ Skeyword kwd -> removing gram kwd - | Smeta _ sl _ -> List.iter (decr_keyw_use gram) sl - | Slist0 s | Slist1 s | Sopt s | Stry s -> decr_keyw_use gram s - | Slist0sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 } - | Slist1sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 } - | Stree t -> decr_keyw_use_in_tree gram t - | Sself | Snext | Snterm _ | Snterml _ _ | Stoken _ -> () ] -and decr_keyw_use_in_tree gram = - fun - [ DeadEnd | LocAct _ _ -> () - | Node n -> - do { - decr_keyw_use gram n.node; - decr_keyw_use_in_tree gram n.son; - decr_keyw_use_in_tree gram n.brother - } ] -; -value rec delete_rule_in_suffix entry symbols = - fun - [ [lev :: levs] -> - match delete_rule_in_tree entry symbols lev.lsuffix with - [ Some (dsl, t) -> - do { - match dsl with - [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl - | None -> () ]; - match t with - [ DeadEnd when lev.lprefix == DeadEnd -> levs - | _ -> - let lev = - {assoc = lev.assoc; lname = lev.lname; lsuffix = t; - lprefix = lev.lprefix} - in - [lev :: levs] ] - } - | None -> - let levs = delete_rule_in_suffix entry symbols levs in - [lev :: levs] ] - | [] -> raise_rule_not_found entry symbols ] -; - -value rec delete_rule_in_prefix entry symbols = - fun - [ [lev :: levs] -> - match delete_rule_in_tree entry symbols lev.lprefix with - [ Some (dsl, t) -> - do { - match dsl with - [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl - | None -> () ]; - match t with - [ DeadEnd when lev.lsuffix == DeadEnd -> levs - | _ -> - let lev = - {assoc = lev.assoc; lname = lev.lname; - lsuffix = lev.lsuffix; lprefix = t} - in - [lev :: levs] ] - } - | None -> - let levs = delete_rule_in_prefix entry symbols levs in - [lev :: levs] ] - | [] -> raise_rule_not_found entry symbols ] -; - -value rec delete_rule_in_level_list entry symbols levs = - match symbols with - [ [Sself :: symbols] -> delete_rule_in_suffix entry symbols levs - | [Snterm e :: symbols] when e == entry -> - delete_rule_in_suffix entry symbols levs - | _ -> delete_rule_in_prefix entry symbols levs ] -; - - -value delete_rule entry sl = - match entry.edesc with - [ Dlevels levs -> - let levs = delete_rule_in_level_list entry sl levs in - do { - entry.edesc := Dlevels levs; - entry.estart := - fun lev strm -> - let f = Parser.start_parser_of_entry entry in - do { entry.estart := f; f lev strm }; - entry.econtinue := - fun lev bp a strm -> - let f = Parser.continue_parser_of_entry entry in - do { entry.econtinue := f; f lev bp a strm } - } - | Dparser _ -> () ] -; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Dynamic.ml ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Dynamic.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Dynamic.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Dynamic.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,73 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Lexer : Sig.Lexer) -: Sig.Grammar.Dynamic with module Loc = Lexer.Loc - and module Token = Lexer.Token -= struct - module Structure = Structure.Make Lexer; - module Delete = Delete.Make Structure; - module Insert = Insert.Make Structure; - module Entry = Entry.Make Structure; - module Fold = Fold.Make Structure; - module Tools = Tools.Make Structure; - include Structure; - - value mk () = - let gkeywords = Hashtbl.create 301 in - { - gkeywords = gkeywords; - gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); - glexer = Lexer.mk (); - warning_verbose = ref True; (* FIXME *) - error_verbose = Camlp4_config.verbose - }; - - value get_filter g = g.gfilter; - - value lex g loc cs = g.glexer loc cs; - - value lex_string g loc str = lex g loc (Stream.of_string str); - - value filter g ts = Tools.keep_prev_loc (Token.Filter.filter g.gfilter ts); - - value parse_tokens_after_filter entry ts = Entry.parse_tokens_after_filter entry ts; - - value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter entry.egram ts); - - value parse entry loc cs = parse_tokens_before_filter entry (lex entry.egram loc cs); - - value parse_string entry loc str = - parse_tokens_before_filter entry (lex_string entry.egram loc str); - - value delete_rule = Delete.delete_rule; - - value srules e rl = - let t = - List.fold_left - (fun tree (symbols, action) -> Insert.insert_tree e symbols action tree) - DeadEnd rl - in - Stree t; - value sfold0 = Fold.sfold0; - value sfold1 = Fold.sfold1; - value sfold0sep = Fold.sfold0sep; - (* value sfold1sep = Fold.sfold1sep; *) - - value extend = Insert.extend; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Entry.ml ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Entry.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Entry.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Entry.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,92 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) = struct - module Dump = Print.MakeDump Structure; - module Print = Print.Make Structure; - module Tools = Tools.Make Structure; - open Format; - open Structure; - open Tools; - - type t 'a = internal_entry; - - value name e = e.ename; - - value print ppf e = fprintf ppf "%a@\n" Print.entry e; - value dump ppf e = fprintf ppf "%a@\n" Dump.entry e; - - (* value find e s = Find.entry e s; *) - - value mk g n = - { egram = g; - ename = n; - estart = empty_entry n; - econtinue _ _ _ = parser []; - edesc = Dlevels [] }; - - value action_parse entry ts : Action.t = - try entry.estart 0 ts with - [ Stream.Failure -> - Loc.raise (get_prev_loc ts) - (Stream.Error ("illegal begin of " ^ entry.ename)) - | Loc.Exc_located _ _ as exc -> raise exc - | exc -> Loc.raise (get_prev_loc ts) exc ]; - - value lex entry loc cs = entry.egram.glexer loc cs; - - value lex_string entry loc str = lex entry loc (Stream.of_string str); - - value filter entry ts = - keep_prev_loc (Token.Filter.filter (get_filter entry.egram) ts); - - value parse_tokens_after_filter entry ts = Action.get (action_parse entry ts); - - value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter entry ts); - - value parse entry loc cs = parse_tokens_before_filter entry (lex entry loc cs); - - value parse_string entry loc str = - parse_tokens_before_filter entry (lex_string entry loc str); - - value of_parser g n (p : Stream.t (Token.t * token_info) -> 'a) : t 'a = - let f ts = Action.mk (p ts) in - { egram = g; - ename = n; - estart _ = f; - econtinue _ _ _ = parser []; - edesc = Dparser f }; - - value setup_parser e (p : Stream.t (Token.t * token_info) -> 'a) = - let f ts = Action.mk (p ts) in do { - e.estart := fun _ -> f; - e.econtinue := fun _ _ _ -> parser []; - e.edesc := Dparser f - }; - - value clear e = - do { - e.estart := fun _ -> parser []; - e.econtinue := fun _ _ _ -> parser []; - e.edesc := Dlevels [] - }; - - value obj x = x; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Failed.ml ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Failed.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Failed.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Failed.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,132 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) = struct - module Tools = Tools.Make Structure; - module Search = Search.Make Structure; - module Print = Print.Make Structure; - open Structure; - open Format; - -value rec name_of_symbol entry = - fun - [ Snterm e -> "[" ^ e.ename ^ "]" - | Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]" - | Sself | Snext -> "[" ^ entry.ename ^ "]" - | Stoken (_, descr) -> descr - | Skeyword kwd -> "\"" ^ kwd ^ "\"" - | _ -> "???" ] -; - - -value rec name_of_symbol_failed entry = - fun - [ Slist0 s | Slist0sep s _ | - Slist1 s | Slist1sep s _ | - Sopt s | Stry s -> name_of_symbol_failed entry s - | Stree t -> name_of_tree_failed entry t - | s -> name_of_symbol entry s ] -and name_of_tree_failed entry = - fun - [ Node {node = s; brother = bro; son = son} -> - let tokl = - match s with - [ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son - | _ -> None ] - in - match tokl with - [ None -> - let txt = name_of_symbol_failed entry s in - let txt = - match (s, son) with - [ (Sopt _, Node _) -> txt ^ " or " ^ name_of_tree_failed entry son - | _ -> txt ] - in - let txt = - match bro with - [ DeadEnd | LocAct _ _ -> txt - | Node _ -> txt ^ " or " ^ name_of_tree_failed entry bro ] - in - txt - | Some (tokl, _, _) -> - List.fold_left - (fun s tok -> - (if s = "" then "" else s ^ " then ") ^ - match tok with - [ Stoken (_, descr) -> descr - | Skeyword kwd -> kwd - | _ -> assert False ]) - "" tokl ] - | DeadEnd | LocAct _ _ -> "???" ] -; -value magic _s x = debug magic "Obj.magic: %s@." _s in Obj.magic x; -value tree_failed entry prev_symb_result prev_symb tree = - let txt = name_of_tree_failed entry tree in - let txt = - match prev_symb with - [ Slist0 s -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | Slist1 s -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | Slist0sep s sep -> - match magic "tree_failed: 'a -> list 'b" prev_symb_result with - [ [] -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | _ -> - let txt1 = name_of_symbol_failed entry sep in - txt1 ^ " or " ^ txt ^ " expected" ] - | Slist1sep s sep -> - match magic "tree_failed: 'a -> list 'b" prev_symb_result with - [ [] -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | _ -> - let txt1 = name_of_symbol_failed entry sep in - txt1 ^ " or " ^ txt ^ " expected" ] - | Stry _(*NP: not sure about this*) | Sopt _ | Stree _ -> txt ^ " expected" - | _ -> txt ^ " expected after " ^ name_of_symbol entry prev_symb ] - in - do { - if entry.egram.error_verbose.val then do { - 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; - fprintf ppf "@["; - Print.print_level ppf pp_force_newline (Print.flatten_tree tree); - fprintf ppf "@]@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "@]@." - } - else (); - txt ^ " (in [" ^ entry.ename ^ "])" - } -; -value symb_failed entry prev_symb_result prev_symb symb = - let tree = Node {node = symb; brother = DeadEnd; son = DeadEnd} in - tree_failed entry prev_symb_result prev_symb tree -; - -value symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Find.ml ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Find.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Find.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Find.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,68 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -(* - value entry e s = - let rec find_levels = - fun - [ [] -> None - | [lev :: levs] -> - match find_tree lev.lsuffix with - [ None -> - match find_tree lev.lprefix with - [ None -> find_levels levs - | x -> x ] - | x -> x ] ] - and symbol = - fun - [ Snterm e -> if e.ename = s then Some e else None - | Snterml e _ -> if e.ename = s then Some e else None - | Smeta _ sl _ -> find_symbol_list sl - | Slist0 s -> find_symbol s - | Slist0sep s _ -> find_symbol s - | Slist1 s -> find_symbol s - | Slist1sep s _ -> find_symbol s - | Sopt s -> find_symbol s - | Stree t -> find_tree t - | Sself | Snext | Stoken _ | Stoken_fun _ -> None ] - and symbol_list = - fun - [ [s :: sl] -> - match find_symbol s with - [ None -> find_symbol_list sl - | x -> x ] - | [] -> None ] - and tree = - fun - [ Node {node = s; brother = bro; son = son} -> - match find_symbol s with - [ None -> - match find_tree bro with - [ None -> find_tree son - | x -> x ] - | x -> x ] - | LocAct _ _ | DeadEnd -> None ] - in - match e.edesc with - [ Dlevels levs -> - match find_levels levs with - [ Some e -> e - | None -> raise Not_found ] - | Dparser _ -> raise Not_found ] - ; -*) diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Fold.ml ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Fold.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Fold.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Fold.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,95 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - - - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Structure : Structure.S) = struct - open Structure; - open Format; - module Parse = Parser.Make Structure; - module Fail = Failed.Make Structure; - open Sig.Grammar; - - (* Prevent from implict usage. *) - module Stream = struct - type t 'a = Stream.t 'a; - exception Failure = Stream.Failure; - exception Error = Stream.Error; - end; - - value sfold0 f e _entry _symbl psymb = - let rec fold accu = - parser - [ [: a = psymb; s :] -> fold (f a accu) s - | [: :] -> accu ] - in - parser [: a = fold e :] -> a - ; - - value sfold1 f e _entry _symbl psymb = - let rec fold accu = - parser - [ [: a = psymb; s :] -> fold (f a accu) s - | [: :] -> accu ] - in - parser [: a = psymb; a = fold (f a e) :] -> a - ; - - value sfold0sep f e entry symbl psymb psep = - let failed = - fun - [ [symb; sep] -> Fail.symb_failed_txt entry sep symb - | _ -> "failed" ] - in - let rec kont accu = - parser - [ [: () = psep; a = psymb ?? failed symbl; s :] -> kont (f a accu) s - | [: :] -> accu ] - in - parser - [ [: a = psymb; s :] -> kont (f a e) s - | [: :] -> e ] - ; - - value sfold1sep f e entry symbl psymb psep = - let failed = - fun - [ [symb; sep] -> Fail.symb_failed_txt entry sep symb - | _ -> "failed" ] - in - let parse_top = - fun - [ [symb; _] -> Parse.parse_top_symb entry symb (* FIXME context *) - | _ -> raise Stream.Failure ] - in - let rec kont accu = - parser - [ [: () = psep; - a = - parser - [ [: a = psymb :] -> a - | [: a = parse_top symbl :] -> Obj.magic a - | [: :] -> raise (Stream.Error (failed symbl)) ]; - s :] -> - kont (f a accu) s - | [: :] -> accu ] - in - parser [: a = psymb; s :] -> kont (f a e) s - ; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Fold.mli ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Fold.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Fold.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Fold.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,30 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - - - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) : sig - open Structure; - - value sfold0 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold1 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; - value sfold0sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; - (* value sfold1sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; *) -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Insert.ml ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Insert.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Insert.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Insert.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,323 +0,0 @@ -(* -*- camlp4r -*- *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) = struct - module Tools = Tools.Make Structure; - module Parser = Parser.Make Structure; - open Structure; - open Format; - open Sig.Grammar; - - value is_before s1 s2 = - match (s1, s2) with - [ (Skeyword _ | Stoken _, Skeyword _ | Stoken _) -> False - | (Skeyword _ | Stoken _, _) -> True - | _ -> False ] - ; - value rec derive_eps = - fun - [ Slist0 _ | Slist0sep _ _ | Sopt _ -> True - | Stry s -> derive_eps s - | Stree t -> tree_derive_eps t - | Slist1 _ | Slist1sep _ _ | Stoken _ | Skeyword _ -> - (* For sure we cannot derive epsilon from these *) - False - | Smeta _ _ _ | Snterm _ | Snterml _ _ | Snext | Sself -> - (* Approximation *) - False ] - and tree_derive_eps = - fun - [ LocAct _ _ -> True - | Node {node = s; brother = bro; son = son} -> - derive_eps s && tree_derive_eps son || tree_derive_eps bro - | DeadEnd -> False ] - ; - - value empty_lev lname assoc = - let assoc = - match assoc with - [ Some a -> a - | None -> LeftA ] - in - {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd} - ; - value change_lev entry lev n lname assoc = - let a = - match assoc with - [ None -> lev.assoc - | Some a -> - do { - if a <> lev.assoc && entry.egram.warning_verbose.val then do { - eprintf " Changing associativity of level \"%s\"\n" n; - flush Pervasives.stderr - } - else (); - a - } ] - in - do { - match lname with - [ Some n -> - if lname <> lev.lname && entry.egram.warning_verbose.val then do { - eprintf " Level label \"%s\" ignored\n" n; flush Pervasives.stderr - } - else () - | None -> () ]; - {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; - lprefix = lev.lprefix} - } - ; - value change_to_self entry = - fun - [ Snterm e when e == entry -> Sself - | x -> x ] - ; - - - value get_level entry position levs = - match position with - [ Some First -> ([], empty_lev, levs) - | Some Last -> (levs, empty_lev, []) - | Some (Level n) -> - let rec get = - fun - [ [] -> - do { - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if Tools.is_level_labelled n lev then ([], change_lev entry lev n, levs) - else - let (levs1, rlev, levs2) = get levs in - ([lev :: levs1], rlev, levs2) ] - in - get levs - | Some (Before n) -> - let rec get = - fun - [ [] -> - do { - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if Tools.is_level_labelled n lev then ([], empty_lev, [lev :: levs]) - else - let (levs1, rlev, levs2) = get levs in - ([lev :: levs1], rlev, levs2) ] - in - get levs - | Some (After n) -> - let rec get = - fun - [ [] -> - do { - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if Tools.is_level_labelled n lev then ([lev], empty_lev, levs) - else - let (levs1, rlev, levs2) = get levs in - ([lev :: levs1], rlev, levs2) ] - in - get levs - | None -> - match levs with - [ [lev :: levs] -> ([], change_lev entry lev "", levs) - | [] -> ([], empty_lev, []) ] ] - ; - - value rec check_gram entry = - fun - [ Snterm e -> - if e.egram != entry.egram then do { - eprintf "\ - Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush Pervasives.stderr; - failwith "Grammar.extend error" - } - else () - | Snterml e _ -> - if e.egram != entry.egram then do { - eprintf "\ - Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush Pervasives.stderr; - failwith "Grammar.extend error" - } - else () - | Smeta _ sl _ -> List.iter (check_gram entry) sl - | Slist0sep s t -> do { check_gram entry t; check_gram entry s } - | Slist1sep s t -> do { check_gram entry t; check_gram entry s } - | Slist0 s | Slist1 s | Sopt s | Stry s -> check_gram entry s - | Stree t -> tree_check_gram entry t - | Snext | Sself | Stoken _ | Skeyword _ -> () ] - and tree_check_gram entry = - fun - [ Node {node = n; brother = bro; son = son} -> - do { - check_gram entry n; - tree_check_gram entry bro; - tree_check_gram entry son - } - | LocAct _ _ | DeadEnd -> () ] - ; - value get_initial = - fun - [ [Sself :: symbols] -> (True, symbols) - | symbols -> (False, symbols) ] - ; - - - value insert_tokens gram symbols = - let rec insert = - fun - [ Smeta _ sl _ -> List.iter insert sl - | Slist0 s | Slist1 s | Sopt s | Stry s -> insert s - | Slist0sep s t -> do { insert s; insert t } - | Slist1sep s t -> do { insert s; insert t } - | Stree t -> tinsert t - | Skeyword kwd -> using gram kwd - | Snterm _ | Snterml _ _ | Snext | Sself | Stoken _ -> () ] - and tinsert = - fun - [ Node {node = s; brother = bro; son = son} -> - do { insert s; tinsert bro; tinsert son } - | LocAct _ _ | DeadEnd -> () ] - in - List.iter insert symbols - ; - - value insert_tree entry gsymbols action tree = - let rec insert symbols tree = - match symbols with - [ [s :: sl] -> insert_in_tree s sl tree - | [] -> - match tree with - [ Node {node = s; son = son; brother = bro} -> - Node {node = s; son = son; brother = insert [] bro} - | LocAct old_action action_list -> - let () = - if entry.egram.warning_verbose.val then - eprintf " Grammar extension: in [%s] some rule has been masked@." - entry.ename - else () - in LocAct action [old_action :: action_list] - | DeadEnd -> LocAct action [] ] ] - and insert_in_tree s sl tree = - match try_insert s sl tree with - [ Some t -> t - | None -> Node {node = s; son = insert sl DeadEnd; brother = tree} ] - and try_insert s sl tree = - match tree with - [ Node {node = s1; son = son; brother = bro} -> - if Tools.eq_symbol s s1 then - let t = Node {node = s1; son = insert sl son; brother = bro} in - Some t - else if is_before s1 s || derive_eps s && not (derive_eps s1) then - let bro = - match try_insert s sl bro with - [ Some bro -> bro - | None -> - Node {node = s; son = insert sl DeadEnd; brother = bro} ] - in - let t = Node {node = s1; son = son; brother = bro} in - Some t - else - match try_insert s sl bro with - [ Some bro -> - let t = Node {node = s1; son = son; brother = bro} in - Some t - | None -> None ] - | LocAct _ _ | DeadEnd -> None ] - in - insert gsymbols tree - ; - value insert_level entry e1 symbols action slev = - match e1 with - [ True -> - {assoc = slev.assoc; lname = slev.lname; - lsuffix = insert_tree entry symbols action slev.lsuffix; - lprefix = slev.lprefix} - | False -> - {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; - lprefix = insert_tree entry symbols action slev.lprefix} ] - ; - - value levels_of_rules entry position rules = - let elev = - match entry.edesc with - [ Dlevels elev -> elev - | Dparser _ -> - do { - eprintf "Error: entry not extensible: \"%s\"\n" entry.ename; - flush Pervasives.stderr; - failwith "Grammar.extend" - } ] - in - if rules = [] then elev - else - let (levs1, make_lev, levs2) = get_level entry position elev in - let (levs, _) = - List.fold_left - (fun (levs, make_lev) (lname, assoc, level) -> - let lev = make_lev lname assoc in - let lev = - List.fold_left - (fun lev (symbols, action) -> - let symbols = List.map (change_to_self entry) symbols in - do { - List.iter (check_gram entry) symbols; - let (e1, symbols) = get_initial symbols; - insert_tokens entry.egram symbols; - insert_level entry e1 symbols action lev - }) - lev level - in - ([lev :: levs], empty_lev)) - ([], make_lev) rules - in - levs1 @ List.rev levs @ levs2 - ; - - value extend entry (position, rules) = - let elev = levels_of_rules entry position rules in - do { - entry.edesc := Dlevels elev; - entry.estart := - fun lev strm -> - let f = Parser.start_parser_of_entry entry in - do { entry.estart := f; f lev strm }; - entry.econtinue := - fun lev bp a strm -> - let f = Parser.continue_parser_of_entry entry in - do { entry.econtinue := f; f lev bp a strm } - }; - - end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Parser.ml ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Parser.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Parser.ml 2012-07-20 11:26:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Parser.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,431 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) = struct - module Tools = Tools.Make Structure; - module Failed = Failed.Make Structure; - module Print = Print.Make Structure; - open Structure; - open Sig.Grammar; - - module StreamOrig = Stream; - - value njunk strm n = - for i = 1 to n do Stream.junk strm done; - - value loc_bp = Tools.get_cur_loc; - value loc_ep = Tools.get_prev_loc; - value drop_prev_loc = Tools.drop_prev_loc; - - value add_loc bp parse_fun strm = - let x = parse_fun strm in - let ep = loc_ep strm in - let loc = - if Loc.start_off bp > Loc.stop_off ep then - (* If nothing has been consumed, create a 0-length location. *) - Loc.join bp - else - Loc.merge bp ep - in - (x, loc); - - value stream_peek_nth strm n = - let rec loop i = fun - [ [x :: xs] -> if i = 1 then Some x else loop (i - 1) xs - | [] -> None ] - in - loop n (Stream.npeek n strm); - - (* We don't want Stream's functions to be used implictly. *) - module Stream = struct - type t 'a = StreamOrig.t 'a; - exception Failure = StreamOrig.Failure; - exception Error = StreamOrig.Error; - value peek = StreamOrig.peek; - value junk = StreamOrig.junk; - - value dup strm = - (* This version of peek_nth is off-by-one from Stream.peek_nth *) - let peek_nth n = - loop n (Stream.npeek (n + 1) strm) where rec loop n = - fun - [ [] -> None - | [x] -> if n = 0 then Some x else None - | [_ :: l] -> loop (n - 1) l ] - in - Stream.from peek_nth; - end; - - value try_parser ps strm = - let strm' = Stream.dup strm in - let r = - try ps strm' - with - [ Stream.Error _ | Loc.Exc_located _ (Stream.Error _) -> - raise Stream.Failure - | exc -> raise exc ] - in do { - njunk strm (StreamOrig.count strm'); - r; - }; - - value level_number entry lab = - let rec lookup levn = - fun - [ [] -> failwith ("unknown level " ^ lab) - | [lev :: levs] -> - if Tools.is_level_labelled lab lev then levn else lookup (succ levn) levs ] - in - match entry.edesc with - [ Dlevels elev -> lookup 0 elev - | Dparser _ -> raise Not_found ] - ; - value strict_parsing = ref False; - value strict_parsing_warning = ref False; - - value rec top_symb entry = - fun - [ Sself | Snext -> Snterm entry - | Snterml e _ -> Snterm e - | Slist1sep s sep -> Slist1sep (top_symb entry s) sep - | _ -> raise Stream.Failure ] - ; - - value top_tree entry = - fun - [ Node {node = s; brother = bro; son = son} -> - Node {node = top_symb entry s; brother = bro; son = son} - | LocAct _ _ | DeadEnd -> raise Stream.Failure ] - ; - - value entry_of_symb entry = - fun - [ Sself | Snext -> entry - | Snterm e -> e - | Snterml e _ -> e - | _ -> raise Stream.Failure ] - ; - - value continue entry loc a s son p1 = - parser - [: a = (entry_of_symb entry s).econtinue 0 loc a; - act = p1 ?? Failed.tree_failed entry a s son :] -> - Action.mk (fun _ -> Action.getf act a) - ; - - (* PR#4603, PR#4330, PR#4551: - Here loc_bp replaced get_loc_ep to fix all these bugs. - If you do change it again look at these bugs. *) - value skip_if_empty bp strm = - if loc_bp strm = bp then Action.mk (fun _ -> raise Stream.Failure) - else - raise Stream.Failure - ; - - value do_recover parser_of_tree entry nlevn alevn loc a s son = - parser - [ [: a = parser_of_tree entry nlevn alevn (top_tree entry son) :] -> a - | [: a = skip_if_empty loc :] -> a - | [: a = - continue entry loc a s son - (parser_of_tree entry nlevn alevn son) :] -> - a ] - ; - - - value recover parser_of_tree entry nlevn alevn loc a s son strm = - if strict_parsing.val then raise (Stream.Error (Failed.tree_failed entry a s son)) - else - let _ = - if strict_parsing_warning.val then begin - let msg = Failed.tree_failed entry a s son; - Format.eprintf "Warning: trying to recover from syntax error"; - if entry.ename <> "" then Format.eprintf " in [%s]" entry.ename else (); - Format.eprintf "\n%s%a@." msg Loc.print loc; - end else () in - do_recover parser_of_tree entry nlevn alevn loc a s son strm - ; - - value rec parser_of_tree entry nlevn alevn = - fun - [ DeadEnd -> parser [] - | LocAct act _ -> parser [: :] -> act - | Node {node = Sself; son = LocAct act _; brother = DeadEnd} -> - parser [: a = entry.estart alevn :] -> Action.getf act a - | Node {node = Sself; son = LocAct act _; brother = bro} -> - let p2 = parser_of_tree entry nlevn alevn bro in - parser - [ [: a = entry.estart alevn :] -> Action.getf act a - | [: a = p2 :] -> a ] - | Node {node = s; son = son; brother = DeadEnd} -> - let tokl = - match s with - [ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son - | _ -> None ] - in - match tokl with - [ None -> - let ps = parser_of_symbol entry nlevn s in - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn s son in - fun strm -> - let bp = loc_bp strm in - match strm with parser - [: a = ps; act = p1 bp a :] -> Action.getf act a - | Some (tokl, last_tok, son) -> - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn last_tok son in - parser_of_token_list p1 tokl ] - | Node {node = s; son = son; brother = bro} -> - let tokl = - match s with - [ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son - | _ -> None ] - in - match tokl with - [ None -> - let ps = parser_of_symbol entry nlevn s in - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn s son in - let p2 = parser_of_tree entry nlevn alevn bro in - fun strm -> - let bp = loc_bp strm in - match strm with parser - [ [: a = ps; act = p1 bp a :] -> Action.getf act a - | [: a = p2 :] -> a ] - | Some (tokl, last_tok, son) -> - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn last_tok son in - let p1 = parser_of_token_list p1 tokl in - let p2 = parser_of_tree entry nlevn alevn bro in - parser - [ [: a = p1 :] -> a - | [: a = p2 :] -> a ] ] ] - and parser_cont p1 entry nlevn alevn s son loc a = - parser - [ [: a = p1 :] -> a - | [: a = recover parser_of_tree entry nlevn alevn loc a s son :] -> a - | [: :] -> raise (Stream.Error (Failed.tree_failed entry a s son)) ] - and parser_of_token_list p1 tokl = - loop 1 tokl where rec loop n = - fun - [ [Stoken (tematch, _) :: tokl] -> - match tokl with - [ [] -> - let ps strm = - match stream_peek_nth strm n with - [ Some (tok, _) when tematch tok -> (njunk strm n; Action.mk tok) - | _ -> raise Stream.Failure ] - in - fun strm -> - let bp = loc_bp strm in - match strm with parser - [: a = ps; act = p1 bp a :] -> Action.getf act a - | _ -> - let ps strm = - match stream_peek_nth strm n with - [ Some (tok, _) when tematch tok -> tok - | _ -> raise Stream.Failure ] - in - let p1 = loop (n + 1) tokl in - parser [: tok = ps; s :] -> - let act = p1 s in Action.getf act tok ] - | [Skeyword kwd :: tokl] -> - match tokl with - [ [] -> - let ps strm = - match stream_peek_nth strm n with - [ Some (tok, _) when Token.match_keyword kwd tok -> - (njunk strm n; Action.mk tok) - | _ -> raise Stream.Failure ] - in - fun strm -> - let bp = loc_bp strm in - match strm with parser - [: a = ps; act = p1 bp a :] -> Action.getf act a - | _ -> - let ps strm = - match stream_peek_nth strm n with - [ Some (tok, _) when Token.match_keyword kwd tok -> tok - | _ -> raise Stream.Failure ] - in - let p1 = loop (n + 1) tokl in - parser [: tok = ps; s :] -> - let act = p1 s in Action.getf act tok ] - | _ -> invalid_arg "parser_of_token_list" ] - and parser_of_symbol entry nlevn = - fun - [ Smeta _ symbl act -> - let act = Obj.magic act entry symbl in - let pl = List.map (parser_of_symbol entry nlevn) symbl in - Obj.magic (List.fold_left (fun act p -> Obj.magic act p) act pl) - | Slist0 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al = - parser - [ [: a = ps; s :] -> loop [a :: al] s - | [: :] -> al ] - in - parser [: a = loop [] :] -> Action.mk (List.rev a) - | Slist0sep symb sep -> - let ps = parser_of_symbol entry nlevn symb in - let pt = parser_of_symbol entry nlevn sep in - let rec kont al = - parser - [ [: v = pt; a = ps ?? Failed.symb_failed entry v sep symb; - s :] -> - kont [a :: al] s - | [: :] -> al ] - in - parser - [ [: a = ps; s :] -> Action.mk (List.rev (kont [a] s)) - | [: :] -> Action.mk [] ] - | Slist1 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al = - parser - [ [: a = ps; s :] -> loop [a :: al] s - | [: :] -> al ] - in - parser [: a = ps; s :] -> Action.mk (List.rev (loop [a] s)) - | Slist1sep symb sep -> - let ps = parser_of_symbol entry nlevn symb in - let pt = parser_of_symbol entry nlevn sep in - let rec kont al = - parser - [ [: v = pt; - a = - parser - [ [: a = ps :] -> a - | [: a = parse_top_symb entry symb :] -> a - | [: :] -> - raise (Stream.Error (Failed.symb_failed entry v sep symb)) ]; - s :] -> - kont [a :: al] s - | [: :] -> al ] - in - parser [: a = ps; s :] -> Action.mk (List.rev (kont [a] s)) - | Sopt s -> - let ps = parser_of_symbol entry nlevn s in - parser - [ [: a = ps :] -> Action.mk (Some a) - | [: :] -> Action.mk None ] - | Stry s -> - let ps = parser_of_symbol entry nlevn s in - try_parser ps - | Stree t -> - let pt = parser_of_tree entry 1 0 t in - fun strm -> - let bp = loc_bp strm in - match strm with parser - [: (act, loc) = add_loc bp pt :] -> - Action.getf act loc - | Snterm e -> parser [: a = e.estart 0 :] -> a - | Snterml e l -> - parser [: a = e.estart (level_number e l) :] -> a - | Sself -> parser [: a = entry.estart 0 :] -> a - | Snext -> parser [: a = entry.estart nlevn :] -> a - | Skeyword kwd -> - parser - [: `(tok, _) when Token.match_keyword kwd tok :] -> - Action.mk tok - | Stoken (f, _) -> - parser - [: `(tok,_) when f tok :] -> Action.mk tok ] - and parse_top_symb entry symb strm = - parser_of_symbol entry 0 (top_symb entry symb) strm; - - value rec start_parser_of_levels entry clevn = - fun - [ [] -> fun _ -> parser [] - | [lev :: levs] -> - let p1 = start_parser_of_levels entry (succ clevn) levs in - match lev.lprefix with - [ DeadEnd -> p1 - | tree -> - let alevn = - match lev.assoc with - [ LeftA | NonA -> succ clevn - | RightA -> clevn ] - in - let p2 = parser_of_tree entry (succ clevn) alevn tree in - match levs with - [ [] -> - fun levn strm -> - let bp = loc_bp strm in - match strm with parser - [: (act, loc) = add_loc bp p2; strm :] -> - let a = Action.getf act loc in - entry.econtinue levn loc a strm - | _ -> - fun levn strm -> - if levn > clevn then p1 levn strm - else - let bp = loc_bp strm in - match strm with parser - [ [: (act, loc) = add_loc bp p2 :] -> - let a = Action.getf act loc in - entry.econtinue levn loc a strm - | [: act = p1 levn :] -> act ] ] ] ] - ; - - value start_parser_of_entry entry = - debug gram "start_parser_of_entry: @[<2>%a@]@." Print.entry entry in - match entry.edesc with - [ Dlevels [] -> Tools.empty_entry entry.ename - | Dlevels elev -> start_parser_of_levels entry 0 elev - | Dparser p -> fun _ -> p ] - ; - value rec continue_parser_of_levels entry clevn = - fun - [ [] -> fun _ _ _ -> parser [] - | [lev :: levs] -> - let p1 = continue_parser_of_levels entry (succ clevn) levs in - match lev.lsuffix with - [ DeadEnd -> p1 - | tree -> - let alevn = - match lev.assoc with - [ LeftA | NonA -> succ clevn - | RightA -> clevn ] - in - let p2 = parser_of_tree entry (succ clevn) alevn tree in - fun levn bp a strm -> - if levn > clevn then p1 levn bp a strm - else - match strm with parser - [ [: act = p1 levn bp a :] -> act - | [: (act, loc) = add_loc bp p2 :] -> - let a = Action.getf2 act a loc in - entry.econtinue levn loc a strm ] ] ] - ; - - value continue_parser_of_entry entry = - debug gram "continue_parser_of_entry: @[<2>%a@]@." Print.entry entry in - match entry.edesc with - [ Dlevels elev -> - let p = continue_parser_of_levels entry 0 elev in - fun levn bp a -> - parser - [ [: a = p levn bp a :] -> a - | [: :] -> a ] - | Dparser _ -> fun _ _ _ -> parser [] ] - ; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Parser.mli ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Parser.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Parser.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Parser.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,62 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2007 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed under *) -(* the terms of the GNU Library General Public License, with the special *) -(* exception on linking described in LICENSE at the top of the OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - - - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) : sig - open Structure; - value add_loc : - Loc.t -> (token_stream -> 'b) -> token_stream -> ('b * Loc.t); - value level_number : internal_entry -> string -> int; - value strict_parsing : ref bool; - value strict_parsing_warning : ref bool; - value top_symb : - internal_entry -> symbol -> symbol; - value top_tree : - internal_entry -> tree -> tree; - value entry_of_symb : - internal_entry -> symbol -> internal_entry; - value continue : - internal_entry -> Loc.t -> Action.t -> symbol -> tree -> efun -> efun; - value do_recover : - (internal_entry -> 'a -> 'b -> tree -> efun) -> internal_entry -> - 'a -> 'b -> Loc.t -> Action.t -> symbol -> tree -> efun; - value recover : - (internal_entry -> 'a -> 'b -> tree -> efun) -> internal_entry -> - 'a -> 'b -> Loc.t -> Action.t -> symbol -> tree -> efun; - value parser_of_tree : - internal_entry -> int -> int -> tree -> efun; - value parser_cont : - efun -> internal_entry -> int -> int -> symbol -> tree -> Loc.t -> Action.t -> efun; - value parser_of_token_list : - (Loc.t -> Action.t -> efun) -> list symbol -> efun; - value parser_of_symbol : - internal_entry -> int -> symbol -> efun; - value parse_top_symb : - internal_entry -> symbol -> efun; - value start_parser_of_levels : - internal_entry -> int -> list level -> int -> efun; - value start_parser_of_entry : - internal_entry -> int -> efun; - value continue_parser_of_levels : - internal_entry -> int -> list level -> int -> Loc.t -> 'a -> efun; - value continue_parser_of_entry : - internal_entry -> int -> Loc.t -> Action.t -> efun; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Print.ml ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Print.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Print.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Print.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,270 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) = struct - open Structure; - open Format; - open Sig.Grammar; - - value rec flatten_tree = - fun - [ DeadEnd -> [] - | LocAct _ _ -> [[]] - | Node {node = n; brother = b; son = s} -> - [ [n :: l] | l <- flatten_tree s ] @ flatten_tree b ]; - - value rec print_symbol ppf = - fun - [ Smeta n sl _ -> print_meta ppf n sl - | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s - | Slist0sep s t -> - fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t - | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s - | Slist1sep s t -> - fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t - | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s - | Stry s -> fprintf ppf "TRY %a" print_symbol1 s - | Snterml e l -> fprintf ppf "%s@ LEVEL@ %S" e.ename l - | Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s -> - print_symbol1 ppf s ] - and print_meta ppf n sl = - loop 0 sl where rec loop i = - fun - [ [] -> () - | [s :: sl] -> - let j = - try String.index_from n i ' ' with [ Not_found -> String.length n ] - in - do { - fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; - if sl = [] then () - else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl } - } ] - and print_symbol1 ppf = - fun - [ Snterm e -> pp_print_string ppf e.ename - | Sself -> pp_print_string ppf "SELF" - | Snext -> pp_print_string ppf "NEXT" - | Stoken (_, descr) -> pp_print_string ppf descr - | Skeyword s -> fprintf ppf "%S" s - | Stree t -> print_level ppf pp_print_space (flatten_tree t) - | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | - Slist1sep _ _ | Sopt _ | Stry _ as s -> - fprintf ppf "(%a)" print_symbol s ] - and print_rule ppf symbols = - do { - fprintf ppf "@["; - let _ = - List.fold_left - (fun sep symbol -> - do { - fprintf ppf "%t%a" sep print_symbol symbol; - fun ppf -> fprintf ppf ";@ " - }) - (fun _ -> ()) symbols - in - fprintf ppf "@]" - } - and print_level ppf pp_print_space rules = - do { - fprintf ppf "@[[ "; - let _ = - List.fold_left - (fun sep rule -> - do { - fprintf ppf "%t%a" sep print_rule rule; - fun ppf -> fprintf ppf "%a| " pp_print_space () - }) - (fun _ -> ()) rules - in - fprintf ppf " ]@]" - } - ; - - value levels ppf elev = - let _ = - List.fold_left - (fun sep lev -> - let rules = - [ [Sself :: t] | t <- flatten_tree lev.lsuffix ] @ - flatten_tree lev.lprefix - in - do { - fprintf ppf "%t@[" sep; - match lev.lname with - [ Some n -> fprintf ppf "%S@;<1 2>" n - | None -> () ]; - match lev.assoc with - [ LeftA -> fprintf ppf "LEFTA" - | RightA -> fprintf ppf "RIGHTA" - | NonA -> fprintf ppf "NONA" ]; - fprintf ppf "@]@;<1 2>"; - print_level ppf pp_force_newline rules; - fun ppf -> fprintf ppf "@,| " - }) - (fun _ -> ()) elev - in - (); - - value entry ppf e = - do { - fprintf ppf "@[%s: [ " e.ename; - match e.edesc with - [ Dlevels elev -> levels ppf elev - | Dparser _ -> fprintf ppf "" ]; - fprintf ppf " ]@]" - }; - -end; - -module MakeDump (Structure : Structure.S) = struct - open Structure; - open Format; - open Sig.Grammar; - - type brothers = [ Bro of symbol and list brothers ]; - - value rec print_tree ppf tree = - let rec get_brothers acc = - fun - [ DeadEnd -> List.rev acc - | LocAct _ _ -> List.rev acc - | Node {node = n; brother = b; son = s} -> get_brothers [Bro n (get_brothers [] s) :: acc] b ] - and print_brothers ppf brothers = - if brothers = [] then fprintf ppf "@ []" - else - List.iter (fun [ Bro n xs -> do { - fprintf ppf "@ @[- %a" print_symbol n; - match xs with - [ [] -> () - | [_] -> try print_children ppf (get_children [] xs) - with [ Exit -> fprintf ppf ":%a" print_brothers xs ] - | _ -> fprintf ppf ":%a" print_brothers xs ]; - fprintf ppf "@]"; - }]) brothers - and print_children ppf = List.iter (fprintf ppf ";@ %a" print_symbol) - and get_children acc = - fun - [ [] -> List.rev acc - | [Bro n x] -> get_children [n::acc] x - | _ -> raise Exit ] - in print_brothers ppf (get_brothers [] tree) - and print_symbol ppf = - fun - [ Smeta n sl _ -> print_meta ppf n sl - | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s - | Slist0sep s t -> - fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t - | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s - | Slist1sep s t -> - fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t - | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s - | Stry s -> fprintf ppf "TRY %a" print_symbol1 s - | Snterml e l -> fprintf ppf "%s@ LEVEL@ %S" e.ename l - | Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s -> - print_symbol1 ppf s ] - and print_meta ppf n sl = - loop 0 sl where rec loop i = - fun - [ [] -> () - | [s :: sl] -> - let j = - try String.index_from n i ' ' with [ Not_found -> String.length n ] - in - do { - fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; - if sl = [] then () - else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl } - } ] - and print_symbol1 ppf = - fun - [ Snterm e -> pp_print_string ppf e.ename - | Sself -> pp_print_string ppf "SELF" - | Snext -> pp_print_string ppf "NEXT" - | Stoken (_, descr) -> pp_print_string ppf descr - | Skeyword s -> fprintf ppf "%S" s - | Stree t -> print_tree ppf t - | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | - Slist1sep _ _ | Sopt _ | Stry _ as s -> - fprintf ppf "(%a)" print_symbol s ] - and print_rule ppf symbols = - do { - fprintf ppf "@["; - let _ = - List.fold_left - (fun sep symbol -> - do { - fprintf ppf "%t%a" sep print_symbol symbol; - fun ppf -> fprintf ppf ";@ " - }) - (fun _ -> ()) symbols - in - fprintf ppf "@]" - } - and print_level ppf pp_print_space rules = - do { - fprintf ppf "@[[ "; - let _ = - List.fold_left - (fun sep rule -> - do { - fprintf ppf "%t%a" sep print_rule rule; - fun ppf -> fprintf ppf "%a| " pp_print_space () - }) - (fun _ -> ()) rules - in - fprintf ppf " ]@]" - } - ; - - value levels ppf elev = - let _ = - List.fold_left - (fun sep lev -> - do { - fprintf ppf "%t@[" sep; - match lev.lname with - [ Some n -> fprintf ppf "%S@;<1 2>" n - | None -> () ]; - match lev.assoc with - [ LeftA -> fprintf ppf "LEFTA" - | RightA -> fprintf ppf "RIGHTA" - | NonA -> fprintf ppf "NONA" ]; - fprintf ppf "@]@;<1 2>"; - fprintf ppf "@[suffix:@ "; - print_tree ppf lev.lsuffix; - fprintf ppf "@]@ @[prefix:@ "; - print_tree ppf lev.lprefix; - fprintf ppf "@]"; - fun ppf -> fprintf ppf "@,| " - }) - (fun _ -> ()) elev - in - (); - - value entry ppf e = - do { - fprintf ppf "@[%s: [ " e.ename; - match e.edesc with - [ Dlevels elev -> levels ppf elev - | Dparser _ -> fprintf ppf "" ]; - fprintf ppf " ]@]" - }; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Print.mli ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Print.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Print.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Print.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,47 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Structure : Structure.S) : sig - value flatten_tree : Structure.tree -> list (list Structure.symbol); - value print_symbol : Format.formatter -> Structure.symbol -> unit; - value print_meta : - Format.formatter -> string -> list Structure.symbol -> unit; - value print_symbol1 : Format.formatter -> Structure.symbol -> unit; - value print_rule : Format.formatter -> list Structure.symbol -> unit; - value print_level : - Format.formatter -> - (Format.formatter -> unit -> unit) -> - list (list Structure.symbol) -> unit; - value levels : Format.formatter -> list Structure.level -> unit; - value entry : Format.formatter -> Structure.internal_entry -> unit; -end; - -module MakeDump (Structure : Structure.S) : sig - value print_symbol : Format.formatter -> Structure.symbol -> unit; - value print_meta : - Format.formatter -> string -> list Structure.symbol -> unit; - value print_symbol1 : Format.formatter -> Structure.symbol -> unit; - value print_rule : Format.formatter -> list Structure.symbol -> unit; - value print_level : - Format.formatter -> - (Format.formatter -> unit -> unit) -> - list (list Structure.symbol) -> unit; - value levels : Format.formatter -> list Structure.level -> unit; - value entry : Format.formatter -> Structure.internal_entry -> unit; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Search.ml ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Search.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Search.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Search.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,95 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -module Make (Structure : Structure.S) = struct - open Structure; -value tree_in_entry prev_symb tree = - fun - [ Dlevels levels -> - let rec search_levels = - fun - [ [] -> tree - | [level :: levels] -> - match search_level level with - [ Some tree -> tree - | None -> search_levels levels ] ] - and search_level level = - match search_tree level.lsuffix with - [ Some t -> Some (Node {node = Sself; son = t; brother = DeadEnd}) - | None -> search_tree level.lprefix ] - and search_tree t = - if tree <> DeadEnd && t == tree then Some t - else - match t with - [ Node n -> - match search_symbol n.node with - [ Some symb -> - Some (Node {node = symb; son = n.son; brother = DeadEnd}) - | None -> - match search_tree n.son with - [ Some t -> - Some (Node {node = n.node; son = t; brother = DeadEnd}) - | None -> search_tree n.brother ] ] - | LocAct _ _ | DeadEnd -> None ] - and search_symbol symb = - match symb with - [ Snterm _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | - Slist1sep _ _ | Sopt _ | Stry _ | Stoken _ | Stree _ | Skeyword _ - when symb == prev_symb -> - Some symb - | Slist0 symb -> - match search_symbol symb with - [ Some symb -> Some (Slist0 symb) - | None -> None ] - | Slist0sep symb sep -> - match search_symbol symb with - [ Some symb -> Some (Slist0sep symb sep) - | None -> - match search_symbol sep with - [ Some sep -> Some (Slist0sep symb sep) - | None -> None ] ] - | Slist1 symb -> - match search_symbol symb with - [ Some symb -> Some (Slist1 symb) - | None -> None ] - | Slist1sep symb sep -> - match search_symbol symb with - [ Some symb -> Some (Slist1sep symb sep) - | None -> - match search_symbol sep with - [ Some sep -> Some (Slist1sep symb sep) - | None -> None ] ] - | Sopt symb -> - match search_symbol symb with - [ Some symb -> Some (Sopt symb) - | None -> None ] - | Stry symb -> - match search_symbol symb with - [ Some symb -> Some (Stry symb) - | None -> None ] - | Stree t -> - match search_tree t with - [ Some t -> Some (Stree t) - | None -> None ] - | _ -> None ] - in - search_levels levels - | Dparser _ -> tree ] -; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Static.ml ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Static.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Static.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Static.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,84 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring -*) - -value uncurry f (x,y) = f x y; -value flip f x y = f y x; - -module Make (Lexer : Sig.Lexer) -: Sig.Grammar.Static with module Loc = Lexer.Loc - and module Token = Lexer.Token -= struct - module Structure = Structure.Make Lexer; - module Delete = Delete.Make Structure; - module Insert = Insert.Make Structure; - module Fold = Fold.Make Structure; - module Tools = Tools.Make Structure; - include Structure; - - value gram = - let gkeywords = Hashtbl.create 301 in - { - gkeywords = gkeywords; - gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); - glexer = Lexer.mk (); - warning_verbose = ref True; (* FIXME *) - error_verbose = Camlp4_config.verbose - }; - - module Entry = struct - module E = Entry.Make Structure; - type t 'a = E.t 'a; - value mk = E.mk gram; - value of_parser name strm = E.of_parser gram name strm; - value setup_parser = E.setup_parser; - value name = E.name; - value print = E.print; - value clear = E.clear; - value dump = E.dump; - value obj x = x; - end; - - value get_filter () = gram.gfilter; - - value lex loc cs = gram.glexer loc cs; - - value lex_string loc str = lex loc (Stream.of_string str); - - value filter ts = Tools.keep_prev_loc (Token.Filter.filter gram.gfilter ts); - - value parse_tokens_after_filter entry ts = Entry.E.parse_tokens_after_filter entry ts; - - value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter ts); - - value parse entry loc cs = parse_tokens_before_filter entry (lex loc cs); - - value parse_string entry loc str = parse_tokens_before_filter entry (lex_string loc str); - - value delete_rule = Delete.delete_rule; - - value srules e rl = - Stree (List.fold_left (flip (uncurry (Insert.insert_tree e))) DeadEnd rl); - value sfold0 = Fold.sfold0; - value sfold1 = Fold.sfold1; - value sfold0sep = Fold.sfold0sep; - (* value sfold1sep = Fold.sfold1sep; *) - - value extend = Insert.extend; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Structure.ml ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Structure.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Structure.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Structure.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,294 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -open Sig.Grammar; - -module type S = sig - module Loc : Sig.Loc; - module Token : Sig.Token with module Loc = Loc; - module Lexer : Sig.Lexer - with module Loc = Loc - and module Token = Token; - module Action : Sig.Grammar.Action; - - type gram = - { gfilter : Token.Filter.t; - gkeywords : Hashtbl.t string (ref int); - glexer : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t); - warning_verbose : ref bool; - error_verbose : ref bool }; - - type token_info = { prev_loc : Loc.t - ; cur_loc : Loc.t - ; prev_loc_only : bool - }; - - type token_stream = Stream.t (Token.t * token_info); - - type efun = token_stream -> Action.t; - - type token_pattern = ((Token.t -> bool) * string); - - type internal_entry = - { egram : gram; - ename : string; - estart : mutable int -> efun; - econtinue : mutable int -> Loc.t -> Action.t -> efun; - edesc : mutable desc } - and desc = - [ Dlevels of list level - | Dparser of token_stream -> Action.t ] - and level = - { assoc : assoc ; - lname : option string ; - lsuffix : tree ; - lprefix : tree } - and symbol = - [ Smeta of string and list symbol and Action.t - | Snterm of internal_entry - | Snterml of internal_entry and string - | Slist0 of symbol - | Slist0sep of symbol and symbol - | Slist1 of symbol - | Slist1sep of symbol and symbol - | Sopt of symbol - | Stry of symbol - | Sself - | Snext - | Stoken of token_pattern - | Skeyword of string - | Stree of tree ] - and tree = - [ Node of node - | LocAct of Action.t and list Action.t - | DeadEnd ] - and node = - { node : symbol ; - son : tree ; - brother : tree }; - - type production_rule = (list symbol * Action.t); - type single_extend_statment = - (option string * option assoc * list production_rule); - type extend_statment = - (option position * list single_extend_statment); - type delete_statment = list symbol; - - type fold 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> Stream.t 'a -> 'c; - - type foldsep 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c; - - (* Accessors *) - value get_filter : gram -> Token.Filter.t; - - (* Useful functions *) - value using : gram -> string -> unit; - value removing : gram -> string -> unit; -end; - -module Make (Lexer : Sig.Lexer) = struct - module Loc = Lexer.Loc; - module Token = Lexer.Token; - module Action : Sig.Grammar.Action = struct - type t = Obj.t ; - value mk = Obj.repr; - value get = Obj.obj ; - value getf = Obj.obj ; - value getf2 = Obj.obj ; - end; - module Lexer = Lexer; - - type gram = - { gfilter : Token.Filter.t; - gkeywords : Hashtbl.t string (ref int); - glexer : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t); - warning_verbose : ref bool; - error_verbose : ref bool }; - - type token_info = { prev_loc : Loc.t - ; cur_loc : Loc.t - ; prev_loc_only : bool - }; - - type token_stream = Stream.t (Token.t * token_info); - - type efun = token_stream -> Action.t; - - type token_pattern = ((Token.t -> bool) * string); - - type internal_entry = - { egram : gram; - ename : string; - estart : mutable int -> efun; - econtinue : mutable int -> Loc.t -> Action.t -> efun; - edesc : mutable desc } - and desc = - [ Dlevels of list level - | Dparser of token_stream -> Action.t ] - and level = - { assoc : assoc ; - lname : option string ; - lsuffix : tree ; - lprefix : tree } - and symbol = - [ Smeta of string and list symbol and Action.t - | Snterm of internal_entry - | Snterml of internal_entry and string - | Slist0 of symbol - | Slist0sep of symbol and symbol - | Slist1 of symbol - | Slist1sep of symbol and symbol - | Sopt of symbol - | Stry of symbol - | Sself - | Snext - | Stoken of token_pattern - | Skeyword of string - | Stree of tree ] - and tree = - [ Node of node - | LocAct of Action.t and list Action.t - | DeadEnd ] - and node = - { node : symbol ; - son : tree ; - brother : tree }; - - type production_rule = (list symbol * Action.t); - type single_extend_statment = - (option string * option assoc * list production_rule); - type extend_statment = - (option position * list single_extend_statment); - type delete_statment = list symbol; - - type fold 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> Stream.t 'a -> 'c; - - type foldsep 'a 'b 'c = - internal_entry -> list symbol -> - (Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c; - - value get_filter g = g.gfilter; - value token_location r = r.cur_loc; - - type not_filtered 'a = 'a; - value using { gkeywords = table; gfilter = filter } kwd = - let r = try Hashtbl.find table kwd with - [ Not_found -> - let r = ref 0 in do { Hashtbl.add table kwd r; r } ] - in do { Token.Filter.keyword_added filter kwd (r.val = 0); - incr r }; - - value removing { gkeywords = table; gfilter = filter } kwd = - let r = Hashtbl.find table kwd in - let () = decr r in - if r.val = 0 then do { - Token.Filter.keyword_removed filter kwd; - Hashtbl.remove table kwd - } else (); -end; - -(* -value iter_entry f e = - let treated = ref [] in - let rec do_entry e = - if List.memq e treated.val then () - else do { - treated.val := [e :: treated.val]; - f e; - match e.edesc with - [ Dlevels ll -> List.iter do_level ll - | Dparser _ -> () ] - } - and do_level lev = do { do_tree lev.lsuffix; do_tree lev.lprefix } - and do_tree = - fun - [ Node n -> do_node n - | LocAct _ _ | DeadEnd -> () ] - and do_node n = do { do_symbol n.node; do_tree n.son; do_tree n.brother } - and do_symbol = - fun - [ Smeta _ sl _ -> List.iter do_symbol sl - | Snterm e | Snterml e _ -> do_entry e - | Slist0 s | Slist1 s | Sopt s | Stry s -> do_symbol s - | Slist0sep s1 s2 | Slist1sep s1 s2 -> do { do_symbol s1; do_symbol s2 } - | Stree t -> do_tree t - | Sself | Snext | Stoken _ | Stoken_fun _ -> () ] - in - do_entry e -; - -value fold_entry f e init = - let treated = ref [] in - let rec do_entry accu e = - if List.memq e treated.val then accu - else do { - treated.val := [e :: treated.val]; - let accu = f e accu in - match e.edesc with - [ Dlevels ll -> List.fold_left do_level accu ll - | Dparser _ -> accu ] - } - and do_level accu lev = - let accu = do_tree accu lev.lsuffix in - do_tree accu lev.lprefix - and do_tree accu = - fun - [ Node n -> do_node accu n - | LocAct _ _ | DeadEnd -> accu ] - and do_node accu n = - let accu = do_symbol accu n.node in - let accu = do_tree accu n.son in - do_tree accu n.brother - and do_symbol accu = - fun - [ Smeta _ sl _ -> List.fold_left do_symbol accu sl - | Snterm e | Snterml e _ -> do_entry accu e - | Slist0 s | Slist1 s | Sopt s | Stry s -> do_symbol accu s - | Slist0sep s1 s2 | Slist1sep s1 s2 -> - let accu = do_symbol accu s1 in - do_symbol accu s2 - | Stree t -> do_tree accu t - | Sself | Snext | Stoken _ | Stoken_fun _ -> accu ] - in - do_entry init e -; - -value is_level_labelled n lev = - match lev.lname with - [ Some n1 -> n = n1 - | None -> False ] -; - -value tokens g con = - let list = ref [] in - do { - Hashtbl.iter - (fun (p_con, p_prm) c -> - if p_con = con then list.val := [(p_prm, c.val) :: list.val] else ()) - g.gtokens; - list.val - } -; -*) diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Tools.ml ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Tools.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar/Tools.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar/Tools.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,132 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -(* PR#5090: don't do lookahead on get_prev_loc. *) -value get_prev_loc_only = ref False; - -module Make (Structure : Structure.S) = struct - open Structure; - - value empty_entry ename _ = - raise (Stream.Error ("entry [" ^ ename ^ "] is empty")); - - value rec stream_map f = parser - [ [: ` x; strm :] -> [: ` (f x); stream_map f strm :] - | [: :] -> [: :] ]; - - value keep_prev_loc strm = - match Stream.peek strm with - [ None -> [: :] - | Some (tok0,init_loc) -> - let rec go prev_loc strm1 = - if get_prev_loc_only.val then - [: `(tok0, {prev_loc; cur_loc = prev_loc; prev_loc_only = True}); - go prev_loc strm1 :] - else - match strm1 with parser - [ [: `(tok,cur_loc); strm :] -> - [: `(tok, {prev_loc; cur_loc; prev_loc_only = False}); - go cur_loc strm :] - | [: :] -> [: :] ] - in go init_loc strm ]; - - value drop_prev_loc strm = stream_map (fun (tok,r) -> (tok,r.cur_loc)) strm; - - value get_cur_loc strm = - match Stream.peek strm with - [ Some (_,r) -> r.cur_loc - | None -> Loc.ghost ]; - - value get_prev_loc strm = - begin - get_prev_loc_only.val := True; - let result = match Stream.peek strm with - [ Some (_, {prev_loc; prev_loc_only = True}) -> - begin Stream.junk strm; prev_loc end - | Some (_, {prev_loc; prev_loc_only = False}) -> prev_loc - | None -> Loc.ghost ]; - get_prev_loc_only.val := False; - result - end; - - value is_level_labelled n lev = - match lev.lname with - [ Some n1 -> n = n1 - | None -> False ]; - - value warning_verbose = ref True; - - value rec get_token_list entry tokl last_tok tree = - match tree with - [ Node {node = (Stoken _ | Skeyword _ as tok); son = son; brother = DeadEnd} -> - get_token_list entry [last_tok :: tokl] tok son - | _ -> - if tokl = [] then None - else Some (List.rev [last_tok :: tokl], last_tok, tree) ]; - - value is_antiquot s = - let len = String.length s in - len > 1 && s.[0] = '$'; - - value eq_Stoken_ids s1 s2 = - not (is_antiquot s1) && not (is_antiquot s2) && s1 = s2; - - value logically_eq_symbols entry = - let rec eq_symbols s1 s2 = - match (s1, s2) with - [ (Snterm e1, Snterm e2) -> e1.ename = e2.ename - | (Snterm e1, Sself) -> e1.ename = entry.ename - | (Sself, Snterm e2) -> entry.ename = e2.ename - | (Snterml e1 l1, Snterml e2 l2) -> e1.ename = e2.ename && l1 = l2 - | (Slist0 s1, Slist0 s2) | - (Slist1 s1, Slist1 s2) | - (Sopt s1, Sopt s2) | - (Stry s1, Stry s2) -> eq_symbols s1 s2 - | (Slist0sep s1 sep1, Slist0sep s2 sep2) | - (Slist1sep s1 sep1, Slist1sep s2 sep2) -> - eq_symbols s1 s2 && eq_symbols sep1 sep2 - | (Stree t1, Stree t2) -> eq_trees t1 t2 - | (Stoken (_, s1), Stoken (_, s2)) -> eq_Stoken_ids s1 s2 - | _ -> s1 = s2 ] - and eq_trees t1 t2 = - match (t1, t2) with - [ (Node n1, Node n2) -> - eq_symbols n1.node n2.node && eq_trees n1.son n2.son && - eq_trees n1.brother n2.brother - | (LocAct _ _ | DeadEnd, LocAct _ _ | DeadEnd) -> True - | _ -> False ] - in - eq_symbols; - - value rec eq_symbol s1 s2 = - match (s1, s2) with - [ (Snterm e1, Snterm e2) -> e1 == e2 - | (Snterml e1 l1, Snterml e2 l2) -> e1 == e2 && l1 = l2 - | (Slist0 s1, Slist0 s2) | - (Slist1 s1, Slist1 s2) | - (Sopt s1, Sopt s2) | - (Stry s1, Stry s2) -> eq_symbol s1 s2 - | (Slist0sep s1 sep1, Slist0sep s2 sep2) | - (Slist1sep s1 sep1, Slist1sep s2 sep2) -> - eq_symbol s1 s2 && eq_symbol sep1 sep2 - | (Stree _, Stree _) -> False - | (Stoken (_, s1), Stoken (_, s2)) -> eq_Stoken_ids s1 s2 - | _ -> s1 = s2 ] - ; -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar.mlpack ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar.mlpack --- ocaml-4.01.0/camlp4/Camlp4/Struct/Grammar.mlpack 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Grammar.mlpack 1970-01-01 01:00:00.000000000 +0100 @@ -1,13 +0,0 @@ -Delete -Dynamic -Entry -Failed -Find -Fold -Insert -Parser -Print -Search -Static -Structure -Tools diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/.ignore ocaml-4.02.3/camlp4/Camlp4/Struct/.ignore --- ocaml-4.01.0/camlp4/Camlp4/Struct/.ignore 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/.ignore 1970-01-01 01:00:00.000000000 +0100 @@ -1,2 +0,0 @@ -Lexer.ml -Camlp4Ast.tmp.ml diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Lexer.mll ocaml-4.02.3/camlp4/Camlp4/Struct/Lexer.mll --- ocaml-4.01.0/camlp4/Camlp4/Struct/Lexer.mll 2013-08-30 13:39:33.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Lexer.mll 1970-01-01 01:00:00.000000000 +0100 @@ -1,495 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006-2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -(* The lexer definition *) - - -{ - -(** A lexical analyzer. *) - -(* FIXME interface module Make (Token : Token) |+ Note that this Token sig is not in Sig +| *) -(* : Sig.Lexer. S with module Loc = Token.Loc and module Token = Token; *) - -(* type context = -{ loc : Loc.t ; - in_comment : bool ; - |+* FIXME When True, all lexers built by [Plexer.make ()] do not lex the - quotation syntax any more. Default is False (quotations are - lexed). +| - quotations : bool }; - -value default_context : context; - -value mk : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t); - -value mk' : context -> Stream.t char -> Stream.t (Token.t * Loc.t); *) -(* FIXME Beware the context argument must be given like that: - * mk' { (default_context) with ... = ... } strm - *) - -module TokenEval = Token.Eval -module Make (Token : Sig.Camlp4Token) -= struct - module Loc = Token.Loc - module Token = Token - - open Lexing - open Sig - - (* Error report *) - module Error = struct - - type t = - | Illegal_character of char - | Illegal_escape of string - | Unterminated_comment - | Unterminated_string - | Unterminated_quotation - | Unterminated_antiquot - | Unterminated_string_in_comment - | Comment_start - | Comment_not_end - | Literal_overflow of string - - exception E of t - - open Format - - let print ppf = - function - | Illegal_character c -> - fprintf ppf "Illegal character (%s)" (Char.escaped c) - | Illegal_escape s -> - fprintf ppf "Illegal backslash escape in string or character (%s)" s - | Unterminated_comment -> - fprintf ppf "Comment not terminated" - | Unterminated_string -> - fprintf ppf "String literal not terminated" - | Unterminated_string_in_comment -> - fprintf ppf "This comment contains an unterminated string literal" - | Unterminated_quotation -> - fprintf ppf "Quotation not terminated" - | Unterminated_antiquot -> - fprintf ppf "Antiquotation not terminated" - | Literal_overflow ty -> - fprintf ppf "Integer literal exceeds the range of representable integers of type %s" ty - | Comment_start -> - fprintf ppf "this is the start of a comment" - | Comment_not_end -> - fprintf ppf "this is not the end of a comment" - - let to_string x = - let b = Buffer.create 50 in - let () = bprintf b "%a" print x in Buffer.contents b - end;; - - let module M = ErrorHandler.Register(Error) in () - - open Error - - (* To store some context information: - * loc : position of the beginning of a string, quotation and comment - * in_comment: are we in a comment? - * quotations: shall we lex quotation? - * If quotations is false it's a SYMBOL token. - * antiquots : shall we lex antiquotations. - *) - - type context = - { loc : Loc.t ; - in_comment : bool ; - quotations : bool ; - antiquots : bool ; - lexbuf : lexbuf ; - buffer : Buffer.t } - - let default_context lb = - { loc = Loc.ghost ; - in_comment = false ; - quotations = true ; - antiquots = false ; - lexbuf = lb ; - buffer = Buffer.create 256 } - - (* To buffer string literals, quotations and antiquotations *) - - let store c = Buffer.add_string c.buffer (Lexing.lexeme c.lexbuf) - let istore_char c i = Buffer.add_char c.buffer (Lexing.lexeme_char c.lexbuf i) - let buff_contents c = - let contents = Buffer.contents c.buffer in - Buffer.reset c.buffer; contents - - let loc c = Loc.merge c.loc (Loc.of_lexbuf c.lexbuf) - let quotations c = c.quotations - let antiquots c = c.antiquots - let is_in_comment c = c.in_comment - let in_comment c = { (c) with in_comment = true } - let set_start_p c = c.lexbuf.lex_start_p <- Loc.start_pos c.loc - let move_start_p shift c = - let p = c.lexbuf.lex_start_p in - c.lexbuf.lex_start_p <- { (p) with pos_cnum = p.pos_cnum + shift } - - let update_loc c = { (c) with loc = Loc.of_lexbuf c.lexbuf } - let with_curr_loc f c = f (update_loc c) c.lexbuf - let parse_nested f c = - with_curr_loc f c; - set_start_p c; - buff_contents c - let shift n c = { (c) with loc = Loc.move `both n c.loc } - let store_parse f c = store c ; f c c.lexbuf - let parse f c = f c c.lexbuf - let mk_quotation quotation c name loc shift = - let s = parse_nested quotation (update_loc c) in - let contents = String.sub s 0 (String.length s - 2) in - QUOTATION { q_name = name ; - q_loc = loc ; - q_shift = shift ; - q_contents = contents } - - - (* Update the current location with file name and line number. *) - - let update_loc c file line absolute chars = - let lexbuf = c.lexbuf in - let pos = lexbuf.lex_curr_p in - let new_file = match file with - | None -> pos.pos_fname - | Some s -> s - in - lexbuf.lex_curr_p <- { pos with - pos_fname = new_file; - pos_lnum = if absolute then line else pos.pos_lnum + line; - pos_bol = pos.pos_cnum - chars; - } - - (* To convert integer literals, copied from "../parsing/lexer.mll" *) - - let cvt_int_literal s = - - int_of_string ("-" ^ s) - let cvt_int32_literal s = - Int32.neg (Int32.of_string ("-" ^ s)) - let cvt_int64_literal s = - Int64.neg (Int64.of_string ("-" ^ s)) - let cvt_nativeint_literal s = - Nativeint.neg (Nativeint.of_string ("-" ^ s)) - - - let err error loc = - raise(Loc.Exc_located(loc, Error.E error)) - - let warn error loc = - Format.eprintf "Warning: %a: %a@." Loc.print loc Error.print error - - } - - let newline = ('\010' | '\013' | "\013\010") - let blank = [' ' '\009' '\012'] - let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] - let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] - let identchar = - ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] - let ident = (lowercase|uppercase) identchar* - let locname = ident - 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' '_']* - let hex_literal = - '0' ['x' 'X'] hexa_char ['0'-'9' 'A'-'F' 'a'-'f' '_']* - let oct_literal = - '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']* - let bin_literal = - '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']* - let int_literal = - decimal_literal | hex_literal | oct_literal | bin_literal - let float_literal = - ['0'-'9'] ['0'-'9' '_']* - ('.' ['0'-'9' '_']* )? - (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? - - (* Delimitors are extended (from 3.09) in a conservative way *) - - (* These chars that can't start an expression or a pattern: *) - let safe_delimchars = ['%' '&' '/' '@' '^'] - - (* These symbols are unsafe since "[<", "[|", etc. exsist. *) - let delimchars = safe_delimchars | ['|' '<' '>' ':' '=' '.'] - - let left_delims = ['(' '[' '{'] - let right_delims = [')' ']' '}'] - - let left_delimitor = - (* At least a safe_delimchars *) - left_delims delimchars* safe_delimchars (delimchars|left_delims)* - - (* A '(' or a new super '(' without "(<" *) - | '(' (['|' ':'] delimchars*)? - (* Old brackets, no new brackets starting with "[|" or "[:" *) - | '[' ['|' ':']? - (* Old "[<","{<" and new ones *) - | ['[' '{'] delimchars* '<' - (* Old brace and new ones *) - | '{' (['|' ':'] delimchars*)? - - let right_delimitor = - (* At least a safe_delimchars *) - (delimchars|right_delims)* safe_delimchars (delimchars|right_delims)* right_delims - (* A ')' or a new super ')' without ">)" *) - | (delimchars* ['|' ':'])? ')' - (* Old brackets, no new brackets ending with "|]" or ":]" *) - | ['|' ':']? ']' - (* Old ">]",">}" and new ones *) - | '>' delimchars* [']' '}'] - (* Old brace and new ones *) - | (delimchars* ['|' ':'])? '}' - - - rule token c = parse - | newline { update_loc c None 1 false 0; NEWLINE } - | blank + as x { BLANKS x } - | "~" (lowercase identchar * as x) ':' { LABEL x } - | "?" (lowercase identchar * as x) ':' { OPTLABEL x } - | lowercase identchar * as x { LIDENT x } - | uppercase identchar * as x { UIDENT x } - | int_literal as i - { try INT(cvt_int_literal i, i) - with Failure _ -> err (Literal_overflow "int") (Loc.of_lexbuf lexbuf) } - | float_literal as f - { try FLOAT(float_of_string f, f) - with Failure _ -> err (Literal_overflow "float") (Loc.of_lexbuf lexbuf) } - | (int_literal as i) "l" - { try INT32(cvt_int32_literal i, i) - with Failure _ -> err (Literal_overflow "int32") (Loc.of_lexbuf lexbuf) } - | (int_literal as i) "L" - { try INT64(cvt_int64_literal i, i) - with Failure _ -> err (Literal_overflow "int64") (Loc.of_lexbuf lexbuf) } - | (int_literal as i) "n" - { try NATIVEINT(cvt_nativeint_literal i, i) - with Failure _ -> err (Literal_overflow "nativeint") (Loc.of_lexbuf lexbuf) } - | '"' - { with_curr_loc string c; - let s = buff_contents c in STRING (TokenEval.string s, s) } - | "'" (newline as x) "'" - { update_loc c None 1 false 1; CHAR (TokenEval.char x, x) } - | "'" ( [^ '\\' '\010' '\013'] - | '\\' (['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] - |['0'-'9'] ['0'-'9'] ['0'-'9'] - |'x' hexa_char hexa_char) - as x) "'" { CHAR (TokenEval.char x, x) } - | "'\\" (_ as c) - { err (Illegal_escape (String.make 1 c)) (Loc.of_lexbuf lexbuf) } - | "(*" - { store c; COMMENT(parse_nested comment (in_comment c)) } - | "(*)" - { warn Comment_start (Loc.of_lexbuf lexbuf) ; - parse comment (in_comment c); COMMENT (buff_contents c) } - | "*)" - { warn Comment_not_end (Loc.of_lexbuf lexbuf) ; - move_start_p (-1) c; SYMBOL "*" } - | "<<" (quotchar* as beginning) - { if quotations 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 = "" } - else parse (symbolchar_star "<<>>") c } - | "<@" - { if quotations c then with_curr_loc maybe_quotation_at c - else parse (symbolchar_star "<@") c } - | "<:" - { if quotations c then with_curr_loc maybe_quotation_colon c - else parse (symbolchar_star "<:") c } - | "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* - ("\"" ([^ '\010' '\013' '"' ] * as name) "\"")? - [^ '\010' '\013'] * newline - { let inum = int_of_string num - in update_loc c name inum true 0; LINE_DIRECTIVE(inum, name) } - | '(' (not_star_symbolchar as op) ')' - { ESCAPED_IDENT (String.make 1 op) } - | '(' (not_star_symbolchar symbolchar* not_star_symbolchar as op) ')' - { ESCAPED_IDENT op } - | '(' (not_star_symbolchar symbolchar* as op) blank+ ')' - { ESCAPED_IDENT op } - | '(' blank+ (symbolchar* not_star_symbolchar as op) ')' - { ESCAPED_IDENT op } - | '(' blank+ (symbolchar+ as op) blank+ ')' - { ESCAPED_IDENT op } - | ( "#" | "`" | "'" | "," | "." | ".." | ":" | "::" - | ":=" | ":>" | ";" | ";;" | "_" - | left_delimitor | right_delimitor ) as x { SYMBOL x } - | '$' { if antiquots c - then with_curr_loc dollar (shift 1 c) - else parse (symbolchar_star "$") c } - | ['~' '?' '!' '=' '<' '>' '|' '&' '@' '^' '+' '-' '*' '/' '%' '\\'] symbolchar * - as x { SYMBOL x } - | eof - { let pos = lexbuf.lex_curr_p in - lexbuf.lex_curr_p <- { pos with pos_bol = pos.pos_bol + 1 ; - pos_cnum = pos.pos_cnum + 1 }; EOI } - | _ as c { err (Illegal_character c) (Loc.of_lexbuf lexbuf) } - - and comment c = parse - "(*" - { store c; with_curr_loc comment c; parse comment c } - | "*)" { store c } - | '<' (':' ident)? ('@' locname)? '<' - { store c; - if quotations c then with_curr_loc quotation c; parse comment c } - | ident { store_parse comment c } - | "\"" - { store c; - begin try with_curr_loc string c - with Loc.Exc_located(_, Error.E Unterminated_string) -> - err Unterminated_string_in_comment (loc c) - end; - Buffer.add_char c.buffer '"'; - parse comment c } - | "''" { store_parse comment c } - | "'''" { store_parse comment c } - | "'" newline "'" - { update_loc c None 1 false 1; store_parse comment c } - | "'" [^ '\\' '\'' '\010' '\013' ] "'" { store_parse comment c } - | "'\\" ['\\' '"' '\'' 'n' 't' 'b' 'r' ' '] "'" { store_parse comment c } - | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { store_parse comment c } - | "'\\" 'x' hexa_char hexa_char "'" { store_parse comment c } - | eof - { err Unterminated_comment (loc c) } - | newline - { update_loc c None 1 false 0; store_parse comment c } - | _ { store_parse comment c } - - and string c = parse - '"' { set_start_p c } - | '\\' newline ([' ' '\t'] * as space) - { update_loc c None 1 false (String.length space); - store_parse string c } - | '\\' ['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] { store_parse string c } - | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { store_parse string c } - | '\\' 'x' hexa_char hexa_char { store_parse string c } - | '\\' (_ as x) - { if is_in_comment c - then store_parse string c - else begin - warn (Illegal_escape (String.make 1 x)) (Loc.of_lexbuf lexbuf); - store_parse string c - end } - | newline - { update_loc c None 1 false 0; store_parse string c } - | eof { err Unterminated_string (loc c) } - | _ { store_parse string c } - - and symbolchar_star beginning c = parse - | symbolchar* as tok { move_start_p (-String.length beginning) c ; - SYMBOL(beginning ^ tok) } - - and maybe_quotation_at c = parse - | (ident as 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 "" (1 + String.length name) } - | (ident as name) '@' (locname as loc) '<' - { mk_quotation quotation c name loc - (2 + String.length loc + String.length name) } - | symbolchar* as tok { SYMBOL("<:" ^ tok) } - - and quotation c = parse - | '<' (':' ident)? ('@' locname)? '<' { store c ; - with_curr_loc quotation c ; - parse quotation c } - | ">>" { store c } - | eof { err Unterminated_quotation (loc c) } - | newline { update_loc c None 1 false 0 ; - store_parse quotation c } - | _ { store_parse quotation c } - - and dollar c = parse - | '$' { set_start_p c; ANTIQUOT("", "") } - | ('`'? (identchar*|['.' '!']+) as name) ':' - { with_curr_loc (antiquot name) (shift (1 + String.length name) c) } - | _ { store_parse (antiquot "") c } - - and antiquot name c = parse - | '$' { set_start_p c; ANTIQUOT(name, buff_contents c) } - | eof { err Unterminated_antiquot (loc c) } - | newline - { update_loc c None 1 false 0; store_parse (antiquot name) c } - | '<' (':' ident)? ('@' locname)? '<' - { store c; with_curr_loc quotation c; parse (antiquot name) c } - | _ { store_parse (antiquot name) c } - - { - - let lexing_store s buff max = - let rec self n s = - if n >= max then n - else - match Stream.peek s with - | Some x -> - Stream.junk s; - buff.[n] <- x; - succ n - | _ -> n - in - self 0 s - - let from_context c = - let next _ = - let tok = with_curr_loc token c in - let loc = Loc.of_lexbuf c.lexbuf in - Some ((tok, loc)) - in Stream.from next - - let from_lexbuf ?(quotations = true) lb = - let c = { (default_context lb) with - loc = Loc.of_lexbuf lb; - antiquots = !Camlp4_config.antiquotations; - quotations = quotations } - in from_context c - - let setup_loc lb loc = - let start_pos = Loc.start_pos loc in - lb.lex_abs_pos <- start_pos.pos_cnum; - lb.lex_curr_p <- start_pos - - let from_string ?quotations loc str = - let lb = Lexing.from_string str in - setup_loc lb loc; - from_lexbuf ?quotations lb - - let from_stream ?quotations loc strm = - let lb = Lexing.from_function (lexing_store strm) in - setup_loc lb loc; - from_lexbuf ?quotations lb - - let mk () loc strm = - from_stream ~quotations:!Camlp4_config.quotations loc strm -end -} diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Loc.ml ocaml-4.02.3/camlp4/Camlp4/Struct/Loc.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Loc.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Loc.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,307 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -(* camlp4r *) - -open Format; - -(* FIXME - Study these 2 others implementations which change the ghost - handling: - - type pos = ... the same ... - - 1/ - - type loc = { - file_name : string; - start : pos; - stop : pos - }; - - type t = - [ Nowhere - | Ghost of loc (* the closest non ghost loc *) - | Concrete of loc ]; - - 2/ - - type loc = { - file_name : string; - start : pos; - stop : pos - }; - - type t = option loc; - - 3/ - - type t = { - file_name : option string; - start : pos; - stop : pos - }; - -*) - -type pos = { - line : int; - bol : int; - off : int -}; - -type t = { - file_name : string; - start : pos; - stop : pos; - ghost : bool -}; - -(* Debug section *) -value dump_sel f x = - let s = - match x with - [ `start -> "`start" - | `stop -> "`stop" - | `both -> "`both" - | _ -> "" ] - in pp_print_string f s; -value dump_pos f x = - fprintf f "@[{ line = %d ;@ bol = %d ;@ off = %d } : pos@]" - x.line x.bol x.off; -value dump_long f x = - fprintf f - "@[{ file_name = %s ;@ start = %a (%d-%d);@ stop = %a (%d);@ ghost = %b@ } : Loc.t@]" - x.file_name dump_pos x.start (x.start.off - x.start.bol) - (x.stop.off - x.start.bol) dump_pos x.stop - (x.stop.off - x.stop.bol) x.ghost; -value dump f x = - fprintf f "[%S: %d:%d-%d %d:%d%t]" - x.file_name x.start.line (x.start.off - x.start.bol) - (x.stop.off - x.start.bol) x.stop.line (x.stop.off - x.stop.bol) - (fun o -> if x.ghost then fprintf o " (ghost)" else ()); - -value start_pos = { line = 1 ; bol = 0 ; off = 0 }; - -value ghost = - { file_name = "ghost-location"; - start = start_pos; - stop = start_pos; - ghost = True }; - -value mk file_name = - debug loc "mk %s@\n" file_name in - { file_name = file_name; - start = start_pos; - stop = start_pos; - ghost = False }; - -value of_tuple (file_name, start_line, start_bol, start_off, - stop_line, stop_bol, stop_off, ghost) = - { file_name = file_name; - start = { line = start_line ; bol = start_bol ; off = start_off }; - stop = { line = stop_line ; bol = stop_bol ; off = stop_off }; - ghost = ghost }; - -value to_tuple - { file_name = file_name; - start = { line = start_line ; bol = start_bol ; off = start_off }; - stop = { line = stop_line ; bol = stop_bol ; off = stop_off }; - ghost = ghost } = - (file_name, start_line, start_bol, start_off, - stop_line, stop_bol, stop_off, ghost); - -value pos_of_lexing_position p = - let pos = - { line = p.Lexing.pos_lnum ; - bol = p.Lexing.pos_bol ; - off = p.Lexing.pos_cnum } in - debug loc "pos_of_lexing_position: %a@\n" dump_pos pos in - pos; - -value pos_to_lexing_position p file_name = - (* debug loc "pos_to_lexing_position: %a@\n" dump_pos p in *) - { Lexing. - pos_fname = file_name; - pos_lnum = p.line ; - pos_bol = p.bol ; - pos_cnum = p.off }; - -value better_file_name a b = - match (a, b) with - [ ("", "") -> a - | ("", x) -> x - | (x, "") -> x - | ("-", x) -> x - | (x, "-") -> x - | (x, _) -> x ]; - -value of_lexbuf lb = - let start = Lexing.lexeme_start_p lb - and stop = Lexing.lexeme_end_p lb in - let loc = - { file_name = better_file_name start.Lexing.pos_fname stop.Lexing.pos_fname; - start = pos_of_lexing_position start; - stop = pos_of_lexing_position stop; - ghost = False } in - debug loc "of_lexbuf: %a@\n" dump loc in - loc; - -value of_lexing_position pos = - let loc = - { file_name = pos.Lexing.pos_fname; - start = pos_of_lexing_position pos; - stop = pos_of_lexing_position pos; - ghost = False } in - debug loc "of_lexing_position: %a@\n" dump loc in - loc; - -value to_ocaml_location x = - debug loc "to_ocaml_location: %a@\n" dump x in - { 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 { 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 = g } in - debug loc "of_ocaml_location: %a@\n" dump res in - res; - -value start_pos x = pos_to_lexing_position x.start x.file_name; -value stop_pos x = pos_to_lexing_position x.stop x.file_name; - -value merge a b = - if a == b then - debug loc "trivial merge@\n" in - a - else - let r = - match (a.ghost, b.ghost) with - [ (False, False) -> - (* FIXME if a.file_name <> b.file_name then - raise (Invalid_argument - (sprintf "Loc.merge: Filenames must be equal: %s <> %s" - a.file_name b.file_name)) *) - (* else *) - { (a) with stop = b.stop } - | (True, True) -> { (a) with stop = b.stop } - | (True, _) -> { (a) with stop = b.stop } - | (_, True) -> { (b) with start = a.start } ] - in debug loc "@[merge %a@ %a@ %a@]@\n" dump a dump b dump r in r; - -value join x = { (x) with stop = x.start }; - -value map f start_stop_both x = - match start_stop_both with - [ `start -> { (x) with start = f x.start } - | `stop -> { (x) with stop = f x.stop } - | `both -> { (x) with start = f x.start; stop = f x.stop } ]; - -value move_pos chars x = { (x) with off = x.off + chars }; - -value move s chars x = - debug loc "move %a %d %a@\n" dump_sel s chars dump x in - map (move_pos chars) s x; - -value move_line lines x = - debug loc "move_line %d %a@\n" lines dump x in - let move_line_pos x = - { (x) with line = x.line + lines ; bol = x.off } - in map move_line_pos `both x; - -value shift width x = - { (x) with start = x.stop ; stop = move_pos width x.stop }; - -value file_name x = x.file_name; -value start_line x = x.start.line; -value stop_line x = x.stop.line; -value start_bol x = x.start.bol; -value stop_bol x = x.stop.bol; -value start_off x = x.start.off; -value stop_off x = x.stop.off; -value is_ghost x = x.ghost; - -value set_file_name s x = - debug loc "set_file_name: %a@\n" dump x in - { (x) with file_name = s }; - -value ghostify x = - debug loc "ghostify: %a@\n" dump x in - { (x) with ghost = True }; - -value make_absolute x = - debug loc "make_absolute: %a@\n" dump x in - let pwd = Sys.getcwd () in - if Filename.is_relative x.file_name then - { (x) with file_name = Filename.concat pwd x.file_name } - else x; - -value strictly_before x y = - let b = x.stop.off < y.start.off && x.file_name = y.file_name in - debug loc "%a [strictly_before] %a => %b@\n" dump x dump y b in - b; - -value to_string x = do { - let (a, b) = (x.start, x.stop) in - let res = sprintf "File \"%s\", line %d, characters %d-%d" - x.file_name a.line (a.off - a.bol) (b.off - a.bol) in - if x.start.line <> x.stop.line then - sprintf "%s (end at line %d, character %d)" - res x.stop.line (b.off - b.bol) - else res -}; - -value print out x = pp_print_string out (to_string x); - -value check x msg = - if ((start_line x) > (stop_line x) || - (start_bol x) > (stop_bol x) || - (start_off x) > (stop_off x) || - (start_line x) < 0 || (stop_line x) < 0 || - (start_bol x) < 0 || (stop_bol x) < 0 || - (start_off x) < 0 || (stop_off x) < 0) - (* Here, we don't check - (start_off x) < (start_bol x) || (stop_off x) < (start_bol x) - since the lexer is called on antiquotations, with off=0, but line and bolpos - have "correct" values *) - then do { - eprintf "*** Warning: (%s) strange positions ***\n%a@\n" msg print x; - False - } - else True; - -exception Exc_located of t and exn; - -ErrorHandler.register - (fun ppf -> - fun [ Exc_located loc exn -> - fprintf ppf "%a:@\n%a" print loc ErrorHandler.print exn - | exn -> raise exn ]); - -value name = ref "_loc"; - -value raise loc exc = - match exc with - [ Exc_located _ _ -> raise exc - | _ -> raise (Exc_located loc exc) ] -; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Loc.mli ocaml-4.02.3/camlp4/Camlp4/Struct/Loc.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/Loc.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Loc.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,19 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) -include Sig.Loc; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Quotation.ml ocaml-4.02.3/camlp4/Camlp4/Struct/Quotation.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Quotation.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Quotation.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,167 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2002-2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -module Make (Ast : Sig.Camlp4Ast) -: Sig.Quotation with module Ast = Ast -= struct - module Ast = Ast; - module DynAst = DynAst.Make Ast; - module Loc = Ast.Loc; - open Format; - open Sig; - - type expand_fun 'a = Loc.t -> option string -> string -> 'a; - - module Exp_key = DynAst.Pack(struct - type t 'a = unit; - end); - - module Exp_fun = DynAst.Pack(struct - type t 'a = expand_fun 'a; - end); - - value expanders_table = - (ref [] : ref (list ((string * Exp_key.pack) * Exp_fun.pack))); - - value default = ref ""; - value translate = ref (fun x -> x); - - value expander_name name = - match translate.val name with - [ "" -> default.val - | name -> name ]; - - value find name tag = - let key = (expander_name name, Exp_key.pack tag ()) in - Exp_fun.unpack tag (List.assoc key expanders_table.val); - - value add name tag f = - let elt = ((name, Exp_key.pack tag ()), Exp_fun.pack tag f) in - expanders_table.val := [elt :: expanders_table.val]; - - value dump_file = ref None; - - module Error = struct - type error = - [ Finding - | Expanding - | ParsingResult of Loc.t and string - | Locating ]; - type t = (string * string * error * exn); - exception E of t; - - value print ppf (name, position, ctx, exn) = - let name = if name = "" then default.val else name in - let pp x = fprintf ppf "@?@[<2>While %s %S in a position of %S:" x name position in - let () = - match ctx with - [ Finding -> begin - pp "finding quotation"; - 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 -> - let () = pp "parsing result of quotation" in - match dump_file.val with - [ Some dump_file -> - let () = fprintf ppf " dumping result...\n" in - try - let oc = open_out_bin dump_file in - 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" - dump_file - | None -> - fprintf ppf - "\n(consider setting variable Quotation.dump_file, or using the -QD option)" - ] - ] - in fprintf ppf "@\n%a@]@." ErrorHandler.print exn; - - value to_string x = - let b = Buffer.create 50 in - let () = bprintf b "%a" print x in Buffer.contents b; - end; - let module M = ErrorHandler.Register Error in (); - open Error; - - value expand_quotation loc expander pos_tag quot = - debug quot "expand_quotation: name: %s, str: %S@." quot.q_name quot.q_contents in - let loc_name_opt = if quot.q_loc = "" then None else Some quot.q_loc in - try expander loc loc_name_opt quot.q_contents with - [ Loc.Exc_located _ (Error.E _) as exc -> - raise exc - | Loc.Exc_located iloc exc -> - let exc1 = Error.E (quot.q_name, pos_tag, Expanding, exc) in - raise (Loc.Exc_located iloc exc1) - | exc -> - let exc1 = Error.E (quot.q_name, pos_tag, Expanding, exc) in - raise (Loc.Exc_located loc exc1) ]; - - value parse_quotation_result parse loc quot pos_tag str = - try parse loc str with - [ Loc.Exc_located iloc (Error.E (n, pos_tag, Expanding, exc)) -> - let ctx = ParsingResult iloc quot.q_contents in - let exc1 = Error.E (n, pos_tag, ctx, exc) in - raise (Loc.Exc_located iloc exc1) - | Loc.Exc_located iloc (Error.E _ as exc) -> - raise (Loc.Exc_located iloc exc) - | Loc.Exc_located iloc exc -> - let ctx = ParsingResult iloc quot.q_contents in - let exc1 = Error.E (quot.q_name, pos_tag, ctx, exc) in - raise (Loc.Exc_located iloc exc1) ]; - - value expand loc quotation tag = - let pos_tag = DynAst.string_of_tag tag in - let name = quotation.q_name in - debug quot "handle_quotation: name: %s, str: %S@." name quotation.q_contents in - let expander = - try find name tag - with - [ Loc.Exc_located _ (Error.E _) as exc -> raise exc - | Loc.Exc_located qloc exc -> - raise (Loc.Exc_located qloc (Error.E (name, pos_tag, Finding, exc))) - | exc -> - raise (Loc.Exc_located loc (Error.E (name, pos_tag, Finding, exc))) ] - in - let loc = Loc.join (Loc.move `start quotation.q_shift loc) in - expand_quotation loc expander pos_tag quotation; - -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Token.ml ocaml-4.02.3/camlp4/Camlp4/Struct/Token.ml --- ocaml-4.01.0/camlp4/Camlp4/Struct/Token.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Token.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,244 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - -open Format; - -module Make (Loc : Sig.Loc) -: Sig.Camlp4Token with module Loc = Loc -= struct - module Loc = Loc; - open Sig; - type t = camlp4_token; - type token = t; - - value to_string = - fun - [ KEYWORD s -> sprintf "KEYWORD %S" s - | SYMBOL s -> sprintf "SYMBOL %S" s - | LIDENT s -> sprintf "LIDENT %S" s - | UIDENT s -> sprintf "UIDENT %S" s - | INT _ s -> sprintf "INT %s" s - | INT32 _ s -> sprintf "INT32 %sd" s - | INT64 _ s -> sprintf "INT64 %sd" s - | NATIVEINT _ s-> sprintf "NATIVEINT %sd" s - | FLOAT _ s -> sprintf "FLOAT %s" s - | CHAR _ s -> sprintf "CHAR '%s'" s - | STRING _ s -> sprintf "STRING \"%s\"" s - (* here it's not %S since the string is already escaped *) - | LABEL s -> sprintf "LABEL %S" s - | OPTLABEL s -> sprintf "OPTLABEL %S" s - | ANTIQUOT n s -> sprintf "ANTIQUOT %s: %S" n s - | QUOTATION x -> sprintf "QUOTATION { q_name=%S; q_loc=%S; q_shift=%d; q_contents=%S }" - x.q_name x.q_loc x.q_shift x.q_contents - | COMMENT s -> sprintf "COMMENT %S" s - | BLANKS s -> sprintf "BLANKS %S" s - | NEWLINE -> sprintf "NEWLINE" - | EOI -> sprintf "EOI" - | ESCAPED_IDENT s -> sprintf "ESCAPED_IDENT %S" s - | LINE_DIRECTIVE i None -> sprintf "LINE_DIRECTIVE %d" i - | LINE_DIRECTIVE i (Some s) -> sprintf "LINE_DIRECTIVE %d %S" i s ]; - - value print ppf x = pp_print_string ppf (to_string x); - - value match_keyword kwd = - fun - [ KEYWORD kwd' when kwd = kwd' -> True - | _ -> False ]; - - value extract_string = - fun - [ KEYWORD s | SYMBOL s | LIDENT s | UIDENT s | INT _ s | INT32 _ s | - INT64 _ s | NATIVEINT _ s | FLOAT _ s | CHAR _ s | STRING _ s | - LABEL s | OPTLABEL s | COMMENT s | BLANKS s | ESCAPED_IDENT s -> s - | tok -> - invalid_arg ("Cannot extract a string from this token: "^ - to_string tok) ]; - - module Error = struct - type t = - [ Illegal_token of string - | Keyword_as_label of string - | Illegal_token_pattern of string and string - | Illegal_constructor of string ]; - - exception E of t; - - value print ppf = - fun - [ Illegal_token s -> - fprintf ppf "Illegal token (%s)" s - | Keyword_as_label kwd -> - fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd - | Illegal_token_pattern p_con p_prm -> - fprintf ppf "Illegal token pattern: %s %S" p_con p_prm - | Illegal_constructor con -> - fprintf ppf "Illegal constructor %S" con ]; - - value to_string x = - let b = Buffer.create 50 in - let () = bprintf b "%a" print x in Buffer.contents b; - end; - let module M = ErrorHandler.Register Error in (); - - module Filter = struct - type token_filter = stream_filter t Loc.t; - - type t = - { is_kwd : string -> bool; - filter : mutable token_filter }; - - value err error loc = - raise (Loc.Exc_located loc (Error.E error)); - - value keyword_conversion tok is_kwd = - match tok with - [ SYMBOL s | LIDENT s | UIDENT s when is_kwd s -> KEYWORD s - | ESCAPED_IDENT s -> LIDENT s - | _ -> tok ]; - - value check_keyword_as_label tok loc is_kwd = - let s = - match tok with - [ LABEL s -> s - | OPTLABEL s -> s - | _ -> "" ] - in if s <> "" && is_kwd s then err (Error.Keyword_as_label s) loc else (); - - value check_unknown_keywords tok loc = - match tok with - [ SYMBOL s -> err (Error.Illegal_token s) loc - | _ -> () ]; - - value error_no_respect_rules p_con p_prm = - raise (Error.E (Error.Illegal_token_pattern p_con p_prm)); - - value check_keyword _ = True; - (* FIXME let lb = Lexing.from_string s in - let next () = token default_context lb in - try - match next () with - [ SYMBOL _ | UIDENT _ | LIDENT _ -> (next () = EOI) - | _ -> False ] - with [ Stream.Error _ -> False ]; *) - - value error_on_unknown_keywords = ref False; - - value rec ignore_layout = - parser - [ [: `(COMMENT _ | BLANKS _ | NEWLINE | LINE_DIRECTIVE _ _, _); s :] -> - ignore_layout s - | [: ` x; s :] -> [: ` x; ignore_layout s :] - | [: :] -> [: :] ]; - - value mk is_kwd = - { is_kwd = is_kwd; - filter = ignore_layout }; - - value filter x = - let f tok loc = do { - let tok = keyword_conversion tok x.is_kwd; - check_keyword_as_label tok loc x.is_kwd; - if error_on_unknown_keywords.val - then check_unknown_keywords tok loc else (); - debug token "@[Lexer before filter:@ %a@ at@ %a@]@." - print tok Loc.dump loc in - (tok, loc) - } in - let rec filter = - parser - [ [: `(tok, loc); s :] -> [: ` f tok loc; filter s :] - | [: :] -> [: :] ] - in - let rec tracer = (* FIXME add a debug block construct *) - parser - [ [: `((_tok, _loc) as x); xs :] -> - debug token "@[Lexer after filter:@ %a@ at@ %a@]@." - print _tok Loc.dump _loc in - [: ` x; tracer xs :] - | [: :] -> [: :] ] - in fun strm -> tracer (x.filter (filter strm)); - - value define_filter x f = x.filter := f x.filter; - - value keyword_added _ _ _ = (); - value keyword_removed _ _ = (); - end; - -end; - -(* Char and string tokens to real chars and string *) -module Eval = struct - - value valch x = Char.code x - Char.code '0'; - value valch_hex x = - let d = Char.code x in - if d >= 97 then d - 87 - else if d >= 65 then d - 55 - else d - 48; - - value rec skip_indent = parser - [ [: `' ' | '\t'; s :] -> skip_indent s - | [: :] -> () ]; - - value skip_opt_linefeed = parser - [ [: `'\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' - | [: `'n' :] -> '\n' - | [: `'r' :] -> '\r' - | [: `'t' :] -> '\t' - | [: `'b' :] -> '\b' - | [: `'\\' :] -> '\\' - | [: `'"' :] -> '"' - | [: `'\'' :] -> '\'' - | [: `' ' :] -> ' ' - | [: `('0'..'9' as c1); `('0'..'9' as c2); `('0'..'9' as 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) :] -> - chr (16 * (valch_hex c1) + (valch_hex c2)) ]; - - value rec backslash_in_string strict store = parser - [ [: `'\010'; s :] -> skip_indent s - | [: `'\013'; s :] -> do { skip_opt_linefeed s; skip_indent s } - | [: x = backslash :] -> store x - | [: `c when not strict :] -> do { store '\\'; store c } - | [: :] -> failwith "invalid string token" ]; - - value char s = - if String.length s = 1 then s.[0] - else if String.length s = 0 then failwith "invalid char token" - else match Stream.of_string s with parser - [ [: `'\\'; x = backslash :] -> x - | [: :] -> failwith "invalid char token" ]; - - value string ?strict s = - let buf = Buffer.create 23 in - let store = Buffer.add_char buf in - let rec parse = parser - [ [: `'\\'; _ = backslash_in_string (strict <> None) store; s :] -> parse s - | [: `c; s :] -> do { store c; parse s } - | [: :] -> Buffer.contents buf ] - in parse (Stream.of_string s); -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct/Token.mli ocaml-4.02.3/camlp4/Camlp4/Struct/Token.mli --- ocaml-4.01.0/camlp4/Camlp4/Struct/Token.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct/Token.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,35 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -module Make (Loc : Sig.Loc) : Sig.Camlp4Token with module Loc = Loc; - -module Eval : sig - value char : string -> char; - (** Convert a char token, where the escape sequences (backslashes) - remain to be interpreted; raise [Failure] if an - incorrect backslash sequence is found; [Token.Eval.char (Char.escaped c)] - returns [c] *) - - value string : ?strict:unit -> string -> string; - (** [Taken.Eval.string strict s] - Convert a string token, where the escape sequences (backslashes) - remain to be interpreted; raise [Failure] if [strict] and an - incorrect backslash sequence is found; - [Token.Eval.string strict (String.escaped s)] returns [s] *) -end; diff -Nru ocaml-4.01.0/camlp4/Camlp4/Struct.mlpack ocaml-4.02.3/camlp4/Camlp4/Struct.mlpack --- ocaml-4.01.0/camlp4/Camlp4/Struct.mlpack 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4/Struct.mlpack 1970-01-01 01:00:00.000000000 +0100 @@ -1,15 +0,0 @@ -AstFilters -Camlp4Ast -Camlp4Ast2OCamlAst -CleanAst -CommentFilter -DynLoader -EmptyError -EmptyPrinter -FreeVars -Lexer -Loc -Quotation -Token -Grammar -DynAst diff -Nru ocaml-4.01.0/camlp4/Camlp4Bin.ml ocaml-4.02.3/camlp4/Camlp4Bin.ml --- ocaml-4.01.0/camlp4/Camlp4Bin.ml 2013-08-30 13:39:33.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4Bin.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,325 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - - - -open Camlp4; -open PreCast.Syntax; -open PreCast; -open Format; -module CleanAst = Camlp4.Struct.CleanAst.Make Ast; -module SSet = Set.Make String; - -value pa_r = "Camlp4OCamlRevisedParser"; -value pa_rr = "Camlp4OCamlReloadedParser"; -value pa_o = "Camlp4OCamlParser"; -value pa_rp = "Camlp4OCamlRevisedParserParser"; -value pa_op = "Camlp4OCamlParserParser"; -value pa_g = "Camlp4GrammarParser"; -value pa_m = "Camlp4MacroParser"; -value pa_qb = "Camlp4QuotationCommon"; -value pa_q = "Camlp4QuotationExpander"; -value pa_rq = "Camlp4OCamlRevisedQuotationExpander"; -value pa_oq = "Camlp4OCamlOriginalQuotationExpander"; -value pa_l = "Camlp4ListComprehension"; - -open Register; - -value dyn_loader = ref (fun []); -value rcall_callback = ref (fun () -> ()); -value loaded_modules = ref SSet.empty; -value add_to_loaded_modules name = - loaded_modules.val := SSet.add name loaded_modules.val; - -value (objext,libext) = - if DynLoader.is_native then (".cmxs",".cmxs") - else (".cmo",".cma"); - -value rewrite_and_load n x = - let dyn_loader = dyn_loader.val () in - let find_in_path = DynLoader.find_in_path dyn_loader in - let real_load name = do { - add_to_loaded_modules name; - DynLoader.load dyn_loader name - } in - let load = List.iter begin fun n -> - if SSet.mem n loaded_modules.val || List.mem n Register.loaded_modules.val then () - else begin - add_to_loaded_modules n; - DynLoader.load dyn_loader (n ^ objext); - end - end in - do { - match (n, String.lowercase x) with - [ ("Parsers"|"", "pa_r.cmo" | "r" | "ocamlr" | "ocamlrevised" | "camlp4ocamlrevisedparser.cmo") -> load [pa_r] - | ("Parsers"|"", "rr" | "reloaded" | "ocamlreloaded" | "camlp4ocamlreloadedparser.cmo") -> load [pa_rr] - | ("Parsers"|"", "pa_o.cmo" | "o" | "ocaml" | "camlp4ocamlparser.cmo") -> load [pa_r; pa_o] - | ("Parsers"|"", "pa_rp.cmo" | "rp" | "rparser" | "camlp4ocamlrevisedparserparser.cmo") -> load [pa_r; pa_rp] - | ("Parsers"|"", "pa_op.cmo" | "op" | "parser" | "camlp4ocamlparserparser.cmo") -> load [pa_r; pa_o; pa_rp; pa_op] - | ("Parsers"|"", "pa_extend.cmo" | "pa_extend_m.cmo" | "g" | "grammar" | "camlp4grammarparser.cmo") -> load [pa_g] - | ("Parsers"|"", "pa_macro.cmo" | "m" | "macro" | "camlp4macroparser.cmo") -> load [pa_m] - | ("Parsers"|"", "q" | "camlp4quotationexpander.cmo") -> load [pa_qb; pa_q] - | ("Parsers"|"", "q_mlast.cmo" | "rq" | "camlp4ocamlrevisedquotationexpander.cmo") -> load [pa_qb; pa_rq] - | ("Parsers"|"", "oq" | "camlp4ocamloriginalquotationexpander.cmo") -> load [pa_r; pa_o; pa_qb; pa_oq] - | ("Parsers"|"", "rf") -> load [pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m] - | ("Parsers"|"", "of") -> load [pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_q; pa_g; pa_l; pa_m] - | ("Parsers"|"", "comp" | "camlp4listcomprehension.cmo") -> load [pa_l] - | ("Filters"|"", "lift" | "camlp4astlifter.cmo") -> load ["Camlp4AstLifter"] - | ("Filters"|"", "exn" | "camlp4exceptiontracer.cmo") -> load ["Camlp4ExceptionTracer"] - | ("Filters"|"", "prof" | "camlp4profiler.cmo") -> load ["Camlp4Profiler"] - (* 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"] - | ("Filters"|"", "striploc" | "camlp4locationstripper.cmo") -> load ["Camlp4LocationStripper"] - | ("Printers"|"", "pr_r.cmo" | "r" | "ocamlr" | "camlp4ocamlrevisedprinter.cmo") -> - Register.enable_ocamlr_printer () - | ("Printers"|"", "pr_o.cmo" | "o" | "ocaml" | "camlp4ocamlprinter.cmo") -> - Register.enable_ocaml_printer () - | ("Printers"|"", "pr_dump.cmo" | "p" | "dumpocaml" | "camlp4ocamlastdumper.cmo") -> - Register.enable_dump_ocaml_ast_printer () - | ("Printers"|"", "d" | "dumpcamlp4" | "camlp4astdumper.cmo") -> - Register.enable_dump_camlp4_ast_printer () - | ("Printers"|"", "a" | "auto" | "camlp4autoprinter.cmo") -> - load ["Camlp4AutoPrinter"] - | _ -> - let y = "Camlp4"^n^"/"^x^objext in - real_load (try find_in_path y with [ Not_found -> x ]) ]; - rcall_callback.val (); - }; - -value print_warning = eprintf "%a:\n%s@." Loc.print; - -value rec parse_file dyn_loader name pa getdir = - let directive_handler = Some (fun ast -> - match getdir ast with - [ Some x -> - match x with - [ (_, "load", s) -> do { rewrite_and_load "" s; None } - | (_, "directory", s) -> do { DynLoader.include_dir dyn_loader s; None } - | (_, "use", s) -> Some (parse_file dyn_loader s pa getdir) - | (_, "default_quotation", s) -> do { Quotation.default.val := s; None } - | (loc, _, _) -> Loc.raise loc (Stream.Error "bad directive") ] - | None -> None ]) in - let loc = Loc.mk name - in do { - current_warning.val := print_warning; - 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 }; - clear (); - phr - }; - -value output_file = ref None; - -value process dyn_loader name pa pr clean fold_filters getdir = - let ast = parse_file dyn_loader name pa getdir in - let ast = fold_filters (fun t filter -> filter t) ast in - let ast = clean ast in - pr ?input_file:(Some name) ?output_file:output_file.val ast; - -value gind = - fun - [ <:sig_item@loc< # $n$ $str:s$ >> -> Some (loc, n, s) - | _ -> None ]; - -value gimd = - fun - [ <:str_item@loc< # $n$ $str:s$ >> -> Some (loc, n, s) - | _ -> None ]; - -value process_intf dyn_loader name = - process dyn_loader name CurrentParser.parse_interf CurrentPrinter.print_interf - (new CleanAst.clean_ast)#sig_item - AstFilters.fold_interf_filters gind; -value process_impl dyn_loader name = - process dyn_loader name CurrentParser.parse_implem CurrentPrinter.print_implem - (new CleanAst.clean_ast)#str_item - AstFilters.fold_implem_filters gimd; - -value just_print_the_version () = - do { printf "%s@." Camlp4_config.version; exit 0 }; - -value print_version () = - do { eprintf "Camlp4 version %s@." Camlp4_config.version; exit 0 }; - -value print_stdlib () = - do { printf "%s@." Camlp4_config.camlp4_standard_library; exit 0 }; - -value usage ini_sl ext_sl = - do { - eprintf "\ -Usage: camlp4 [load-options] [--] [other-options]\n\ -Options:\n\ -.ml Parse this implementation file\n\ -.mli Parse this interface file\n\ -.%s Load this module inside the Camlp4 core@." -(if DynLoader.is_native then "cmxs " else "(cmo|cma)") -; - Options.print_usage_list ini_sl; - (* loop (ini_sl @ ext_sl) where rec loop = - fun - [ [(y, _, _) :: _] when y = "-help" -> () - | [_ :: sl] -> loop sl - | [] -> eprintf " -help Display this list of options.@." ]; *) - if ext_sl <> [] then do { - eprintf "Options added by loaded object files:@."; - Options.print_usage_list ext_sl; - } - else (); - }; - -value warn_noassert () = - do { - eprintf "\ -camlp4 warning: option -noassert is obsolete\n\ -You should give the -noassert option to the ocaml compiler instead.@."; - }; - -type file_kind = - [ Intf of string - | Impl of string - | Str of string - | ModuleImpl of string - | IncludeDir of string ]; - -value search_stdlib = ref True; -value print_loaded_modules = ref False; -value (task, do_task) = - let t = ref None in - let task f x = - let () = Camlp4_config.current_input_file.val := x in - t.val := Some (if t.val = None then (fun _ -> f x) - else (fun usage -> usage ())) in - let do_task usage = match t.val with [ Some f -> f usage | None -> () ] in - (task, do_task); -value input_file x = - let dyn_loader = dyn_loader.val () in - do { - rcall_callback.val (); - 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 -> - 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 (); - }; - -value initial_spec_list = - [("-I", Arg.String (fun x -> input_file (IncludeDir x)), - " Add directory in search patch for object files."); - ("-where", Arg.Unit print_stdlib, - "Print camlp4 library directory and exit."); - ("-nolib", Arg.Clear search_stdlib, - "No automatic search for object files in library directory."); - ("-intf", Arg.String (fun x -> input_file (Intf x)), - " Parse as an interface, whatever its extension."); - ("-impl", Arg.String (fun x -> input_file (Impl x)), - " Parse as an implementation, whatever its extension."); - ("-str", Arg.String (fun x -> input_file (Str x)), - " Parse as an implementation."); - ("-unsafe", Arg.Set Camlp4_config.unsafe, - "Generate unsafe accesses to array and strings."); - ("-noassert", Arg.Unit warn_noassert, - "Obsolete, do not use this option."); - ("-verbose", Arg.Set Camlp4_config.verbose, - "More verbose in parsing errors."); - ("-loc", Arg.Set_string Loc.name, - " Name of the location variable (default: " ^ Loc.name.val ^ ")."); - ("-QD", Arg.String (fun x -> Quotation.dump_file.val := Some x), - " Dump quotation expander result in case of syntax error."); - ("-o", Arg.String (fun x -> output_file.val := Some x), - " Output on instead of standard output."); - ("-v", Arg.Unit print_version, - "Print Camlp4 version and exit."); - ("-version", Arg.Unit just_print_the_version, - "Print Camlp4 version number and exit."); - ("-vnum", Arg.Unit just_print_the_version, - "Print Camlp4 version number and exit."); - ("-no_quot", Arg.Clear Camlp4_config.quotations, - "Don't parse quotations, allowing to use, e.g. \"<:>\" as token."); - ("-loaded-modules", Arg.Set print_loaded_modules, "Print the list of loaded modules."); - ("-parser", Arg.String (rewrite_and_load "Parsers"), - " Load the parser Camlp4Parsers/.cm(o|a|xs)"); - ("-printer", Arg.String (rewrite_and_load "Printers"), - " Load the printer Camlp4Printers/.cm(o|a|xs)"); - ("-filter", Arg.String (rewrite_and_load "Filters"), - " Load the filter Camlp4Filters/.cm(o|a|xs)"); - ("-ignore", Arg.String ignore, "ignore the next argument"); - ("--", Arg.Unit ignore, "Deprecated, does nothing") -]; - -Options.init initial_spec_list; - -value anon_fun name = - input_file - (if Filename.check_suffix name ".mli" then Intf name - else if Filename.check_suffix name ".ml" then Impl name - else if Filename.check_suffix name objext then ModuleImpl name - else if Filename.check_suffix name libext then ModuleImpl name - else raise (Arg.Bad ("don't know what to do with " ^ name))); - -value main argv = - let usage () = do { usage initial_spec_list (Options.ext_spec_list ()); exit 0 } in - try do { - let dynloader = DynLoader.mk ~ocaml_stdlib:search_stdlib.val - ~camlp4_stdlib:search_stdlib.val (); - dyn_loader.val := fun () -> dynloader; - let call_callback () = - Register.iter_and_take_callbacks - (fun (name, module_callback) -> - let () = add_to_loaded_modules name in - module_callback ()); - call_callback (); - rcall_callback.val := call_callback; - match Options.parse anon_fun argv with - [ [] -> () - | ["-help"|"--help"|"-h"|"-?" :: _] -> usage () - | [s :: _] -> - do { eprintf "%s: unknown or misused option\n" s; - eprintf "Use option -help for usage@."; - exit 2 } ]; - do_task usage; - call_callback (); - if print_loaded_modules.val then do { - SSet.iter (eprintf "%s@.") loaded_modules.val; - } else () - } - with - [ Arg.Bad s -> do { eprintf "Error: %s\n" s; - eprintf "Use option -help for usage@."; - exit 2 } - | Arg.Help _ -> usage () - | exc -> do { eprintf "@[%a@]@." ErrorHandler.print exc; exit 2 } ]; - -main Sys.argv; diff -Nru ocaml-4.01.0/camlp4/Camlp4_config.ml ocaml-4.02.3/camlp4/Camlp4_config.ml --- ocaml-4.01.0/camlp4/Camlp4_config.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4_config.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,39 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -let ocaml_standard_library = Camlp4_import.Config.standard_library;; - -let camlp4_standard_library = - try Sys.getenv "CAMLP4LIB" - with Not_found -> - Filename.concat ocaml_standard_library "camlp4";; - -let version = Sys.ocaml_version;; -let program_name = ref "camlp4";; -let constructors_arity = ref true;; -let unsafe = ref false;; -let verbose = ref false;; -let antiquotations = ref false;; -let quotations = ref true;; -let inter_phrases = ref None;; -let camlp4_ast_impl_magic_number = "Camlp42006M002";; -let camlp4_ast_intf_magic_number = "Camlp42006N002";; -let ocaml_ast_intf_magic_number = Camlp4_import.Config.ast_intf_magic_number;; -let ocaml_ast_impl_magic_number = Camlp4_import.Config.ast_impl_magic_number;; -let current_input_file = ref "";; diff -Nru ocaml-4.01.0/camlp4/Camlp4_config.mli ocaml-4.02.3/camlp4/Camlp4_config.mli --- ocaml-4.01.0/camlp4/Camlp4_config.mli 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4_config.mli 1970-01-01 01:00:00.000000000 +0100 @@ -1,34 +0,0 @@ -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Daniel de Rauglaudre: initial version - * - Nicolas Pouillard: refactoring - *) - -val version : string;; -val ocaml_standard_library : string;; -val camlp4_standard_library : string;; -val ocaml_ast_impl_magic_number : string;; -val ocaml_ast_intf_magic_number : string;; -val camlp4_ast_impl_magic_number : string;; -val camlp4_ast_intf_magic_number : string;; -val program_name : string ref;; -val unsafe : bool ref;; -val verbose : bool ref;; -val quotations : bool ref;; -val antiquotations : bool ref;; -val constructors_arity : bool ref;; -val inter_phrases : (string option) ref;; -val current_input_file : string ref;; diff -Nru ocaml-4.01.0/camlp4/Camlp4Filters/Camlp4AstLifter.ml ocaml-4.02.3/camlp4/Camlp4Filters/Camlp4AstLifter.ml --- ocaml-4.01.0/camlp4/Camlp4Filters/Camlp4AstLifter.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4Filters/Camlp4AstLifter.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,44 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - - -open Camlp4; - -module Id = struct - value name = "Camlp4AstLifter"; - value version = Sys.ocaml_version; -end; - -module Make (AstFilters : Camlp4.Sig.AstFilters) = struct - open AstFilters; - - module MetaLoc = struct - module Ast = Ast; - value meta_loc_patt _loc _ = <:patt< loc >>; - value meta_loc_expr _loc _ = <:expr< loc >>; - end; - module MetaAst = Ast.Meta.Make MetaLoc; - - register_str_item_filter (fun ast -> - let _loc = Ast.loc_of_str_item ast in - <:str_item< let loc = Loc.ghost in $exp:MetaAst.Expr.meta_str_item _loc ast$ >>); - -end; - -let module M = Camlp4.Register.AstFilter Id Make in (); diff -Nru ocaml-4.01.0/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml ocaml-4.02.3/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml --- ocaml-4.01.0/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml 2012-07-17 17:31:12.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,68 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* Copyright 2006 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - - -open Camlp4; - -module Id = struct - value name = "Camlp4ExceptionTracer"; - value version = Sys.ocaml_version; -end; - -module Make (AstFilters : Camlp4.Sig.AstFilters) = struct - open AstFilters; - open Ast; - - value add_debug_expr e = - (* let _loc = Loc.make_absolute (MLast.loc_of_expr e) in *) - let _loc = Ast.loc_of_expr e in - let msg = "camlp4-debug: exc: %s at " ^ Loc.to_string _loc ^ "@." in - <:expr< - try $e$ - with - [ Stream.Failure | Exit as exc -> raise exc - | exc -> do { - if Debug.mode "exc" then - Format.eprintf $`str:msg$ (Printexc.to_string exc) else (); - raise exc - } ] >>; - - value rec map_match_case = - fun - [ <:match_case@_loc< $m1$ | $m2$ >> -> - <:match_case< $map_match_case m1$ | $map_match_case m2$ >> - | <:match_case@_loc< $p$ when $w$ -> $e$ >> -> - <:match_case@_loc< $p$ when $w$ -> $add_debug_expr e$ >> - | m -> m ]; - - value filter = object - inherit Ast.map as super; - method expr = fun - [ <:expr@_loc< fun [ $m$ ] >> -> <:expr< fun [ $map_match_case m$ ] >> - | x -> super#expr x ]; - method str_item = fun - [ <:str_item< module Debug = $_$ >> as st -> st - | st -> super#str_item st ]; - end; - - register_str_item_filter filter#str_item; - -end; - -let module M = Camlp4.Register.AstFilter Id Make in (); diff -Nru ocaml-4.01.0/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml ocaml-4.02.3/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml --- ocaml-4.01.0/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml 2013-08-30 13:39:33.000000000 +0200 +++ ocaml-4.02.3/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml 1970-01-01 01:00:00.000000000 +0100 @@ -1,609 +0,0 @@ -(* camlp4r *) -(****************************************************************************) -(* *) -(* OCaml *) -(* *) -(* INRIA Rocquencourt *) -(* *) -(* 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 OCaml *) -(* source tree. *) -(* *) -(****************************************************************************) - -(* Authors: - * - Nicolas Pouillard: initial version - *) - - -open Camlp4; - -module Id = struct - value name = "Camlp4FoldGenerator"; - value version = Sys.ocaml_version; -end; - -module Make (AstFilters : Camlp4.Sig.AstFilters) = struct - open AstFilters; - module StringMap = Map.Make String; - open Ast; - - value _loc = Loc.ghost; - - 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 - [ [] -> accu - | [x :: xs] -> - let _loc = Ast.loc_of_expr x - in apply_expr <:expr< $accu$ $x$ >> xs ]; - - value rec apply_patt accu = - fun - [ [] -> accu - | [x :: xs] -> - let _loc = Ast.loc_of_patt x - in apply_patt <:patt< $accu$ $x$ >> xs ]; - - value rec apply_ctyp accu = - fun - [ [] -> accu - | [x :: xs] -> - let _loc = Ast.loc_of_ctyp x - in apply_ctyp <:ctyp< $accu$ $x$ >> xs ]; - - value opt_map f = fun [ Some x -> Some (f x) | None -> None ]; - - value list_init f n = - let rec self m = - if m = n then [] - else [f m :: self (succ m)] - in self 0; - - 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 * 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