Commits

HongboZhang committed ad934ef Merge

Merge remote-tracking branch 'le/origin'

Comments (0)

Files changed (123)

     parsing/location.cmi parsing/lexer.cmi
 parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \
     parsing/location.cmx parsing/lexer.cmi
-parsing/linenum.cmo : utils/misc.cmi
-parsing/linenum.cmx : utils/misc.cmx
 parsing/location.cmo : utils/warnings.cmi utils/terminfo.cmi \
     parsing/location.cmi
 parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx \
 typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/subst.cmi \
     typing/path.cmi parsing/longident.cmi parsing/location.cmi \
     typing/ident.cmi utils/consistbl.cmi typing/annot.cmi
-typing/envaux.cmi : typing/path.cmi bytecomp/instruct.cmi typing/env.cmi
+typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi
 typing/ident.cmi :
 typing/includeclass.cmi : typing/types.cmi typing/env.cmi typing/ctype.cmi
 typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \
     typing/cmi_format.cmx utils/clflags.cmx typing/btype.cmx \
     parsing/asttypes.cmi typing/annot.cmi typing/env.cmi
 typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \
-    typing/path.cmi typing/mtype.cmi utils/misc.cmi bytecomp/instruct.cmi \
-    typing/env.cmi typing/envaux.cmi
+    typing/path.cmi typing/mtype.cmi utils/misc.cmi typing/env.cmi \
+    typing/envaux.cmi
 typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \
-    typing/path.cmx typing/mtype.cmx utils/misc.cmx bytecomp/instruct.cmx \
-    typing/env.cmx typing/envaux.cmi
+    typing/path.cmx typing/mtype.cmx utils/misc.cmx typing/env.cmx \
+    typing/envaux.cmi
 typing/ident.cmo : typing/ident.cmi
 typing/ident.cmx : typing/ident.cmi
 typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \
     asmcomp/mach.cmx asmcomp/linearize.cmx asmcomp/emitaux.cmx \
     asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
     asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emit.cmi
-asmcomp/emitaux.cmo : asmcomp/debuginfo.cmi utils/config.cmi \
-    utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi
-asmcomp/emitaux.cmx : asmcomp/debuginfo.cmx utils/config.cmx \
-    utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi
+asmcomp/emitaux.cmo : asmcomp/linearize.cmi asmcomp/debuginfo.cmi \
+    utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi
+asmcomp/emitaux.cmx : asmcomp/linearize.cmx asmcomp/debuginfo.cmx \
+    utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi
 asmcomp/interf.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
     asmcomp/interf.cmi
 asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
     asmcomp/reloadgen.cmi
 asmcomp/reloadgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
     asmcomp/reloadgen.cmi
-asmcomp/schedgen.cmo : asmcomp/reg.cmi asmcomp/mach.cmi \
+asmcomp/schedgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \
     asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
     asmcomp/schedgen.cmi
-asmcomp/schedgen.cmx : asmcomp/reg.cmx asmcomp/mach.cmx \
+asmcomp/schedgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \
     asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
     asmcomp/schedgen.cmi
 asmcomp/scheduling.cmo : asmcomp/schedgen.cmi asmcomp/scheduling.cmi
 
 Compilers:
 - PR#5634: parsetree rewriter (-ppx flag)
+- ocamldep now supports -absname
 
 Bug fixes:
+- PR#4762: ?? is not used at all, but registered as a lexer token
+- PR#4994: ocaml-mode doesn't work with xemacs21
 - PR#5327: (Windows) Unix.select blocks if same socket listed in first and
   third arguments
+- PR#5468: ocamlbuild should preserve order of parametric tags
 - PR#5551: Avoid repeated lookups for missing cmi files
+- PR#5552: try to use camlp4.opt if it's possible
+- PR#5611: avoid clashes betwen .cmo files and output files during linking
 - PR#5662: typo in md5.c
 - PR#5695: remove warnings on sparc code emitter
 - PR#5697: better location for warnings on statement expressions
 - PR#5698: remove harcoded limit of 200000 labels in emitaux.ml
-- PR#4762: ?? is not used at all, but registered as a lexer token
 - PR#5708: catch Failure"int_of_string" in ocamldebug
+- PR#5731: instruction scheduling forgot to account for destroyed registers
+- PR#5734: improved Win32 implementation of Unix.gettimeofday
+- PR#5735: %apply and %revapply not first class citizens
+- PR#5738: first class module patterns not handled by ocamldep
+- PR#5747: 'unused open' warning not given when compiling with -annot
+- PR#5758: Compiler bug when matching on floats
+- PR#5763: ocamlbuild does not give correct flags when running menhir
 
 Internals:
 - Moved debugger/envaux.ml to typing/envaux.ml to publish env_of_only_summary
    as part of compilerlibs, to be used on bin-annot files.
 
+Feature wishes:
+- PR#5597: add instruction trace option 't' to OCAMLRUNPARAM
+
+OCaml 4.00.1:
+-------------
+
+Bug fixes:
+- PR#4019: better documentation of Str.matched_string
+- PR#5563: harden Unix.select against file descriptors above FD_SETSIZE
+- PR#5700: crash with native-code stack backtraces under MacOS 10.8 x86-64
+- PR#5707: AMD64 code generator: do not use r10 and r11 for parameter passing,
+  as these registers can be destroyed by the dynamic loader
+- PR#5712: some documentation problems
+- PR#5719: ocamlyacc generates code that is not warning 33-compliant
+- PR#5727: emacs caml-mode indents shebang line in toplevel scripts
+- PR#5731: instruction scheduling forgot to account for destroyed registers
+- PR#5735: %apply and %revapply not first class citizens
+- PR#5738: first class module patterns not handled by ocamldep
+- PR#5742: missing bound checks in Array.sub
+- PR#5757: GC compaction bug (crash)
+- PR#5761: Incorrect bigarray custom block size
+
+
 OCaml 4.00.0:
 -------------
 
 	@echo "Please refer to the installation instructions in file INSTALL."
 	@echo "If you've just unpacked the distribution, something like"
 	@echo "	./configure"
-	@echo "	make world"
-	@echo "	make opt"
+	@echo "	make world.opt"
 	@echo "	make install"
 	@echo "should work.  But see the file INSTALL for more details."
 
 world.opt:
 	$(MAKE) coldstart
 	$(MAKE) opt.opt
-	$(MAKE) ocamltoolsopt
 
 # Hard bootstrap how-to:
 # (only necessary in some cases, for example if you remove some primitive)
 # Native-code versions of the tools
 opt.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \
 	 $(DEBUGGER) ocamldoc ocamlbuild.byte $(CAMLP4OUT) \
-	 ocamlopt.opt otherlibrariesopt ocamllex.opt ocamltoolsopt.opt \
-	 ocamldoc.opt ocamlbuild.native $(CAMLP4OPT)
+	 ocamlopt.opt otherlibrariesopt ocamllex.opt \
+	 ocamltoolsopt ocamltoolsopt.opt ocamldoc.opt ocamlbuild.native \
+	 $(CAMLP4OPT)
 
 base.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \
 	 ocamlbuild.byte $(CAMLP4OUT) $(DEBUGGER) ocamldoc ocamlopt.opt \
 .PHONY: partialclean beforedepend alldepend cleanboot coldstart
 .PHONY: compare core coreall
 .PHONY: coreboot defaultentry depend distclean install installopt
-.PHONY: library library-cross libraryopt ocamlbuild-mixed-boot
+.PHONY: library library-cross libraryopt
 .PHONY: ocamlbuild.byte ocamlbuild.native ocamldebugger ocamldoc
 .PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltoolsopt
 .PHONY: ocamltoolsopt.opt ocamlyacc opt-core opt opt.opt otherlibraries

Upgrading

-
-      FAQ: how to upgrade from Objective Caml 3.02 to 3.03
-
-I Installation
-
-Q1: When compiling the distribution, I am getting strange linking
-    errors in "otherlibraries".
-
-A1: This is probably a problem with dynamic linking. You can disable
-    it with ./configure -no-shared-libs. If you really want to use
-    shared libraries, look in the manual pages of your system for how
-    to get some debugging output from the dynamic linker.
-
-II Non-label changes
-
-Q2: I get a syntax error when I try to compile a program using stream
-    parsers.
-
-A2: Stream parser now require camlp4. It is included in the
-    distribution, and you just need to use "ocamlc -pp camlp4o" in
-    place of "ocamlc". You can also use it under the toplevel with
-    #load"camlp4o.cma".
-
-Q3: I get a warning when I use the syntax "#variant" inside type
-    expressions.
-
-A3: The new syntax is [< variant], which just a special case of
-    the more general new syntax, which allows type expressions like
-    [ variant1 | variant2] or [> variant]. See the reference manual
-    for details.
-
-III Label changes
-
-Q4: I was using labels before, and now I get lots of type errors.
-
-A4: The handling of labels changed with 3.03-alpha. The new default
-    is a more flexible version of the commuting label mode, allowing
-    one to omit labels in total applications. There is still a
-    -nolabels mode, but it does not allow non-optional labels in
-    applications (this was unsound).
-    To keep full compatibility with Objective Caml 2, labels were
-    removed from the standard libraries. Some labelized libraries are
-    kept as StdLabels (contains Array, List and String), MoreLabels
-    (contains Hashtbl, Map and Set), and UnixLabels.
-    Note that MoreLabels' status is not yet decided.
-
-Q5: Why isn't there a ThreadUnixLabels module ?
-
-A5: ThreadUnix is deprecated. It only calls directly the Unix module.
-
-Q6: I was using commuting label mode, how can I upgrade ?
-
-A6: The new behaviour is compatible with commuting label mode, but
-    standard libraries have no labels. You can add the following
-    lines at the beginning of your files (according to your needs):
-          open Stdlabels
-          open MoreLabels
-          module Unix = UnixLabels
-    Alternatively, if you already have a common module opened by
-    everybody, you can add these:
-          include StdLabels
-          include MoreLabels
-          module Unix = UnixLabels
-
-    You will then need to remove labels in functions from other modules.
-    This can be automated by using the scrapelabels tool, installed
-    in the Objective Caml library directory, which both removes labels
-    and inserts needed `open' clauses (see -help for details).
-          $CAMLLIB/scrapelabels -keepstd *.ml
-    or
-          $CAMLLIB/scrapelabels -keepmore *.ml
-    Note that scrapelabels is not guaranteed to be sound for commuting
-    label programs, since it will just remove labels, and not reorder
-    arguments.
-
-Q7: I was using a few labels in classic mode, and now I get all these
-    errors. I just want to get rid of all these silly labels.
-
-A7: scrapelabels will do it for you.
-          $CAMLLIB/scrapelabels [-all] *.ml
-          $CAMLLIB/scrapelabels -intf *.mli
-    You should specify the -all option only if you are sure that your
-    sources do not contain calls to functions with optional
-    parameters, as those labels would also be removed.
-
-Q8: I was using labels in classic mode, and I was actually pretty fond
-    of them. How much more labels will I have to write now ? How can I
-    convert my programs and libraries ?
-
-A8: The new default mode is more flexible than the original commuting
-    mode, so that you shouldn't see too much differences when using
-    labeled libraries. Labels are only compulsory in partial
-    applications (including the special case of function with an
-    unknown return type), or if you wrote some of them.
-
-    On the other hand, for definitions, labels present in the
-    interface must also be present in the implementation.
-    The addlabels tool can help you to do that. Suppose that you have
-    mymod.ml and mymod.mli, where mymod.mli adds some labels. Then
-    doing
-          $CAMLLIB/addlabels mymod.ml
-    will insert labels from the interface inside the implementation.
-    It also takes care of inserting them in recursive calls, as
-    the return type of the function is not known while typing it.
-
-    If you used labels from standard libraries, you will also have
-    problems with them. You can proceed as described in A6. Since you
-    used classic mode, you do not need to bother about changed
-    argument order.
-4.01.0+dev6_2012-07-30
+4.01.0+dev8_2012-09-10
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli

asmcomp/amd64/emit.mlp

 
 let reg_low_8_name =
   [| "%al"; "%bl"; "%dil"; "%sil"; "%dl"; "%cl"; "%r8b"; "%r9b";
-     "%r10b"; "%r11b"; "%bpl"; "%r12b"; "%r13b" |]
+     "%r12b"; "%r13b"; "%bpl"; "%r10b"; "%r11b" |]
 let reg_low_16_name =
   [| "%ax"; "%bx"; "%di"; "%si"; "%dx"; "%cx"; "%r8w"; "%r9w";
-     "%r10w"; "%r11w"; "%bp"; "%r12w"; "%r13w" |]
+     "%r12w"; "%r13w"; "%bp"; "%r10w"; "%r11w" |]
 let reg_low_32_name =
   [| "%eax"; "%ebx"; "%edi"; "%esi"; "%edx"; "%ecx"; "%r8d"; "%r9d";
-     "%r10d"; "%r11d"; "%ebp"; "%r12d"; "%r13d" |]
+     "%r12d"; "%r13d"; "%ebp"; "%r10d"; "%r11d" |]
 
 let emit_subreg tbl r =
   match r.loc with
   match Config.system with
   | "linux" | "gnu" ->
       (* mcount preserves rax, rcx, rdx, rsi, rdi, r8, r9 explicitly
-         and rbx, rbp, r12-r15 like all C functions.
-         We need to preserve r10 and r11 ourselves, since OCaml can
-         use them for argument passing. *)
+         and rbx, rbp, r12-r15 like all C functions.  This includes
+         all the registers used for argument passing, so we don't
+         need to preserve other regs.  We do need to initialize rbp
+         like mcount expects it, though. *)
       `	pushq	%r10\n`;
       `	movq	%rsp, %rbp\n`;
-      `	pushq	%r11\n`;
       `	{emit_call "mcount"}\n`;
-      `	popq	%r11\n`;
       `	popq	%r10\n`
   | _ ->
       () (*unsupported yet*)

asmcomp/amd64/emit_nt.mlp

 
 let reg_low_8_name =
   [| "al"; "bl"; "dil"; "sil"; "dl"; "cl"; "r8b"; "r9b";
-     "r10b"; "r11b"; "bpl"; "r12b"; "r13b" |]
+     "r12b"; "r13b"; "bpl"; "r10b"; "r11b" |]
 let reg_low_16_name =
   [| "ax"; "bx"; "di"; "si"; "dx"; "cx"; "r8w"; "r9w";
-     "r10w"; "r11w"; "bp"; "r12w"; "r13w" |]
+     "r12w"; "r13w"; "bp"; "r10w"; "r11w" |]
 let reg_low_32_name =
   [| "eax"; "ebx"; "edi"; "esi"; "edx"; "ecx"; "r8d"; "r9d";
-     "r10d"; "r11d"; "ebp"; "r12d"; "r13d" |]
+     "r12d"; "r13d"; "ebp"; "r10d"; "r11d" |]
 
 let emit_subreg tbl pref r =
   match r.loc with

asmcomp/amd64/proc.ml

     rcx         5
     r8          6
     r9          7
-    r10         8
-    r11         9
+    r12         8
+    r13         9
     rbp         10
-    r12         11
-    r13         12
+    r10         11
+    r11         12
     r14         trap pointer
     r15         allocation pointer
 
   xmm0 - xmm15  100 - 115  *)
 
 (* Conventions:
-     rax - r11: OCaml function arguments
+     rax - r13: OCaml function arguments
      rax: OCaml and C function results
      xmm0 - xmm9: OCaml function arguments
      xmm0: OCaml and C function results
      xmm0 - xmm3: C function arguments
      rbx, rbp, rsi, rdi r12-r15 are preserved by C
      xmm6-xmm15 are preserved by C
+   Note (PR#5707): r11 should not be used for parameter passing, as it
+     can be destroyed by the dynamic loader according to SVR4 ABI.
+     Linux's dynamic loader also destroys r10.
 *)
 
 let int_reg_name =
   match Config.ccomp_type with
   | "msvc" ->
       [| "rax"; "rbx"; "rdi"; "rsi"; "rdx"; "rcx"; "r8"; "r9";
-         "r10"; "r11"; "rbp"; "r12"; "r13" |]
+         "r12"; "r13"; "rbp"; "r10"; "r11" |]
   | _ ->
       [| "%rax"; "%rbx"; "%rdi"; "%rsi"; "%rdx"; "%rcx"; "%r8"; "%r9";
-         "%r10"; "%r11"; "%rbp"; "%r12"; "%r13" |]
+         "%r12"; "%r13"; "%rbp"; "%r10"; "%r11" |]
 
 let float_reg_name =
   match Config.ccomp_type with
   if win64 then
     (* Win64: rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 preserved *)
     Array.of_list(List.map phys_reg
-      [0;4;5;6;7;8;9;
+      [0;4;5;6;7;11;12;
        100;101;102;103;104;105])
   else
     (* Unix: rbp, rbx, r12-r15 preserved *)
     Array.of_list(List.map phys_reg
-      [0;2;3;4;5;6;7;8;9;
+      [0;2;3;4;5;6;7;11;12;
        100;101;102;103;104;105;106;107;
        108;109;110;111;112;113;114;115])
 

asmcomp/arm/arch.ml

 
 (* Specific operations for the ARM processor *)
 
-open Misc
 open Format
 
 type abi = EABI | EABI_VFP

asmcomp/arm/emit.mlp

 
 (* Emission of ARM assembly code *)
 
-open Location
 open Misc
 open Cmm
 open Arch

asmcomp/arm/selection.ml

 (* Instruction selection for the ARM processor *)
 
 open Arch
+open Proc
 open Cmm
 open Mach
-open Misc
-open Proc
-open Reg
 
 let is_offset chunk n =
   match chunk with

asmcomp/schedgen.ml

 
 let add_edge_after son ancestor = add_edge ancestor son 0
 
+(* Add edges from all instructions that define a pseudoregister [arg] being used
+   as argument to node [node] (RAW dependencies *)
+
+let add_RAW_dependencies node arg =
+  try
+    let ancestor = Hashtbl.find code_results arg.loc in
+    add_edge ancestor node ancestor.delay
+  with Not_found ->
+    ()
+
+(* Add edges from all instructions that use a pseudoregister [res] that is
+   defined by node [node] (WAR dependencies). *)
+
+let add_WAR_dependencies node res =
+  let ancestors = Hashtbl.find_all code_uses res.loc in
+  List.iter (add_edge_after node) ancestors
+
+(* Add edges from all instructions that have already defined a pseudoregister
+   [res] that is defined by node [node] (WAW dependencies). *)
+
+let add_WAW_dependencies node res =
+  try
+    let ancestor = Hashtbl.find code_results res.loc in
+    add_edge ancestor node 0
+  with Not_found ->
+    ()
+
 (* Compute length of longest path to a result.
    For leafs of the DAG, see whether their result is used in the instruction
    immediately following the basic block (a "critical" output). *)
   | Lreloadretaddr -> self#reload_retaddr_issue_cycles
   | _ -> assert false
 
+(* Pseudoregisters destroyed by an instruction *)
+
+method private destroyed_by_instr instr =
+  match instr.desc with
+  | Lop op -> Proc.destroyed_at_oper (Iop op)
+  | Lreloadretaddr -> [||]
+  | _ -> assert false
+
 (* Add an instruction to the code dag *)
 
 method private add_instruction ready_queue instr =
   let delay = self#instr_latency instr in
+  let destroyed = self#destroyed_by_instr instr in
   let node =
     { instr = instr;
       delay = delay;
       emitted_ancestors = 0 } in
   (* Add edges from all instructions that define one of the registers used
      (RAW dependencies) *)
-  for i = 0 to Array.length instr.arg - 1 do
-    try
-      let ancestor = Hashtbl.find code_results instr.arg.(i).loc in
-      add_edge ancestor node ancestor.delay
-    with Not_found ->
-      ()
-  done;
+  Array.iter (add_RAW_dependencies node) instr.arg;
   (* Also add edges from all instructions that use one of the result regs
-     of this instruction (WAR dependencies). *)
-  for i = 0 to Array.length instr.res - 1 do
-    let ancestors = Hashtbl.find_all code_uses instr.res.(i).loc in
-    List.iter (add_edge_after node) ancestors
-  done;
+     of this instruction, or a reg destroyed by this instruction
+     (WAR dependencies). *)
+  Array.iter (add_WAR_dependencies node) instr.res;
+  Array.iter (add_WAR_dependencies node) destroyed;   (* PR#5731 *)
   (* Also add edges from all instructions that have already defined one
-     of the results of this instruction (WAW dependencies). *)
-  for i = 0 to Array.length instr.res - 1 do
-    try
-      let ancestor = Hashtbl.find code_results instr.res.(i).loc in
-      add_edge ancestor node 0
-    with Not_found ->
-      ()
-  done;
+     of the results of this instruction, or a reg destroyed by
+     this instruction (WAW dependencies). *)
+  Array.iter (add_WAW_dependencies node) instr.res;
+  Array.iter (add_WAW_dependencies node) destroyed;   (* PR#5731 *)
   (* If this is a load, add edges from the most recent store viewed so
      far (if any) and remember the load.  Also add edges from the most
      recent checkbound and forget that checkbound. *)
   for i = 0 to Array.length instr.res - 1 do
     Hashtbl.add code_results instr.res.(i).loc node
   done;
+  for i = 0 to Array.length destroyed - 1 do
+    Hashtbl.add code_results destroyed.(i).loc node  (* PR#5731 *)
+  done;
   for i = 0 to Array.length instr.arg - 1 do
     Hashtbl.add code_uses instr.arg.(i).loc node
   done;
         addq    $32768, %rsp
 #endif
     /* Build array of registers, save it into caml_gc_regs */
-        pushq   %r13; CFI_ADJUST (8);
-        pushq   %r12; CFI_ADJUST (8);
-        pushq   %rbp; CFI_ADJUST (8);
         pushq   %r11; CFI_ADJUST (8);
         pushq   %r10; CFI_ADJUST (8);
+        pushq   %rbp; CFI_ADJUST (8);
+        pushq   %r13; CFI_ADJUST (8);
+        pushq   %r12; CFI_ADJUST (8);
         pushq   %r9; CFI_ADJUST (8);
         pushq   %r8; CFI_ADJUST (8);
         pushq   %rcx; CFI_ADJUST (8);
         popq    %rcx; CFI_ADJUST(-8)
         popq    %r8; CFI_ADJUST(-8)
         popq    %r9; CFI_ADJUST(-8)
-        popq    %r10; CFI_ADJUST(-8)
-        popq    %r11; CFI_ADJUST(-8)
-        popq    %rbp; CFI_ADJUST(-8)
         popq    %r12; CFI_ADJUST(-8)
         popq    %r13; CFI_ADJUST(-8)
+        popq    %rbp; CFI_ADJUST(-8)
+        popq    %r10; CFI_ADJUST(-8)
+        popq    %r11; CFI_ADJUST(-8)
     /* Return to caller */
         ret
 CFI_ENDPROC
 LBL(110):
         movq    %rax, %r12            /* Save exception bucket */
         movq    %rax, C_ARG_1         /* arg 1: exception bucket */
-        movq    0(%rsp), C_ARG_2      /* arg 2: pc of raise */
-        leaq    8(%rsp), C_ARG_3      /* arg 3: sp of raise */
+        popq    C_ARG_2               /* arg 2: pc of raise */
+        movq    %rsp, C_ARG_3         /* arg 3: sp at raise */
         movq    %r14, C_ARG_4         /* arg 4: sp of handler */
+	/* PR#5700: thanks to popq above, stack is now 16-aligned */
         PREPARE_FOR_C_CALL            /* no need to cleanup after */
         call    GCALL(caml_stash_backtrace)
         movq    %r12, %rax            /* Recover exception bucket */
         LOAD_VAR(caml_last_return_address,C_ARG_2)   /* arg 2: pc of raise */
         LOAD_VAR(caml_bottom_of_stack,C_ARG_3)       /* arg 3: sp of raise */
         LOAD_VAR(caml_exception_pointer,C_ARG_4)     /* arg 4: sp of handler */
+        subq    $8, %rsp              /* PR#5700: maintain stack alignment */
         PREPARE_FOR_C_CALL            /* no need to cleanup after */
         call    GCALL(caml_stash_backtrace)
         movq    %r12, %rax            /* Recover exception bucket */

asmrun/amd64nt.asm

         mov     caml_young_ptr, r15
         mov     caml_exception_pointer, r14
     ; Build array of registers, save it into caml_gc_regs
-        push    r13
-        push    r12
-        push    rbp
         push    r11
         push    r10
+        push    rbp
+        push    r13
+        push    r12
         push    r9
         push    r8
         push    rcx
         pop     rcx
         pop     r8
         pop     r9
-        pop     r10
-        pop     r11
-        pop     rbp
         pop     r12
         pop     r13
+        pop     rbp
+        pop     r10
+        pop     r11
     ; Restore caml_young_ptr, caml_exception_pointer
         mov     r15, caml_young_ptr
         mov     r14, caml_exception_pointer

boot/myocamlbuild.boot

Binary file modified.
Binary file modified.

boot/ocamldep

Binary file modified.

boot/ocamllex

Binary file modified.

build/camlp4-bootstrap-recipe.txt

+#########################################################################
+#                                                                       #
+#                                 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

build/new-build-system

+#########################################################################
+#                                                                       #
+#                                 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

bytecomp/bytelink.ml

 type error =
     File_not_found of string
   | Not_an_object_file of string
+  | Wrong_object_name of string
   | Symbol_error of string * Symtable.error
   | Inconsistent_import of string * string * string
   | Custom_runtime
 (* Create a bytecode executable file *)
 
 let link_bytecode ppf tolink exec_name standalone =
+  (* Avoid the case where the specified exec output file is the same as
+     one of the objects to be linked *)
+  List.iter (function
+    | Link_object(file_name, _) when file_name = exec_name ->
+      raise (Error (Wrong_object_name exec_name));
+    | _ -> ()) tolink;
   Misc.remove_file exec_name; (* avoid permission problems, cf PR#1911 *)
   let outchan =
     open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary]
   | Not_an_object_file name ->
       fprintf ppf "The file %a is not a bytecode object file"
         Location.print_filename name
+  | Wrong_object_name name ->
+      fprintf ppf "The output file %s has a wrong name. The extension implies object file when the link step was requested" name
   | Symbol_error(name, err) ->
       fprintf ppf "Error while linking %a:@ %a" Location.print_filename name
       Symtable.report_error err

bytecomp/bytelink.mli

 type error =
     File_not_found of string
   | Not_an_object_file of string
+  | Wrong_object_name of string
   | Symbol_error of string * Symtable.error
   | Inconsistent_import of string * string * string
   | Custom_runtime

bytecomp/matching.ml

       | _ -> raise NoMatch)
   | Tpat_constant cst ->
       (fun q rem -> match q.pat_desc with
-      | Tpat_constant cst' when cst=cst' ->
+      | Tpat_constant cst' when const_compare cst cst' = 0 ->
           p,rem
       | Tpat_any -> p,rem
       | _ -> raise NoMatch)
     add jumps
 
 
-let rec jumps_union env1 env2 = match env1,env2 with
+let rec jumps_union (env1:(int*ctx list)list) env2 = match env1,env2 with
 | [],_ -> env2
 | _,[] -> env1
 | ((i1,pss1) as x1::rem1), ((i2,pss2) as x2::rem2) ->
 (* A slight attempt to identify semantically equivalent lambda-expressions *)
 exception Not_simple
 
-let rec raw_rec env = function
+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
               simplify rem
           | Tpat_record (lbls, closed) ->
               let all_lbls = all_record_args lbls in
-              let full_pat = {pat with pat_desc=Tpat_record (all_lbls, closed)} in
+              let full_pat =
+                {pat with pat_desc=Tpat_record (all_lbls, closed)} in
               (full_pat::patl,action)::
               simplify rem
           | Tpat_or _ ->
   ctx : ctx list ;
   pat : pattern}
 
-let add make_matching_fun division key patl_action args =
+let add make_matching_fun division eq_key key patl_action args =
   try
-    let cell = List.assoc key division in
+    let (_,cell) = List.find (fun (k,_) -> eq_key key k) division in
     cell.pm.cases <- patl_action :: cell.pm.cases;
     division
   with Not_found ->
     (key, cell) :: division
 
 
-let divide make get_key get_args ctx pm =
+let divide make eq_key get_key get_args ctx pm =
 
   let rec divide_rec = function
     | (p::patl,action) :: rem ->
         let this_match = divide_rec rem in
         add
           (make p pm.default ctx)
-          this_match (get_key p) (get_args p patl,action) pm.args
+          this_match eq_key (get_key p) (get_args p patl,action) pm.args
     | _ -> [] in
 
   divide_rec pm.cases
       matcher_const cst p1 rem with
     | NoMatch -> matcher_const cst p2 rem
     end
-| Tpat_constant c1 when c1=cst -> rem
-| Tpat_any                     -> rem
+| Tpat_constant c1 when const_compare c1 cst = 0 -> rem
+| Tpat_any    -> rem
 | _ -> raise NoMatch
 
 let get_key_constant caller = function
 
 let divide_constant ctx m =
   divide
-    make_constant_matching (get_key_constant "divide")
+    make_constant_matching
+    (fun c d -> const_compare c d = 0) (get_key_constant "divide")
     get_args_constant
     ctx m
 
         | None, Some r2 -> r2
         | Some (a1::rem1), Some (a2::_) ->
             {a1 with
-pat_loc = Location.none ;
-pat_desc = Tpat_or (a1, a2, None)}::
+             pat_loc = Location.none ;
+             pat_desc = Tpat_or (a1, a2, None)}::
             rem
         | _, _ -> assert false
         end
-    | Tpat_construct (_, _, cstr1, [arg],_) when cstr.cstr_tag = cstr1.cstr_tag ->
-        arg::rem
+    | Tpat_construct (_, _, cstr1, [arg],_)
+      when cstr.cstr_tag = cstr1.cstr_tag -> arg::rem
     | Tpat_any -> omega::rem
     | _ -> raise NoMatch in
     matcher_rec
     fun q rem -> match q.pat_desc with
     | Tpat_or (_,_,_) -> raise OrPat
     | Tpat_construct (_, _, cstr1, args,_)
-        when cstr.cstr_tag = cstr1.cstr_tag -> args @ rem
+      when cstr.cstr_tag = cstr1.cstr_tag -> args @ rem
     | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem
     | _        -> raise NoMatch
 
 let divide_constructor ctx pm =
   divide
     make_constr_matching
-    get_key_constr get_args_constr
+    (=) get_key_constr get_args_constr
     ctx pm
 
 (* Matching against a variant *)
           match pato with
             None ->
               add (make_variant_matching_constant p lab def ctx) variants
-                (Cstr_constant tag) (patl, action) al
+                (=) (Cstr_constant tag) (patl, action) al
           | Some pat ->
               add (make_variant_matching_nonconst p lab def ctx) variants
-                (Cstr_block tag) (pat :: patl, action) al
+                (=) (Cstr_block tag) (pat :: patl, action) al
         end
     | cl -> []
   in
 let divide_array kind ctx pm =
   divide
     (make_array_matching kind)
-    get_key_array get_args_array ctx pm
+    (=) get_key_array get_args_array ctx pm
 
 (* To combine sub-matchings together *)
 
-let float_compare s1 s2 =
-  let f1 = float_of_string s1 and f2 = float_of_string s2 in
-  Pervasives.compare f1 f2
-
 let sort_lambda_list l =
-  List.sort
-    (fun (x,_) (y,_) -> match x,y with
-    | Const_float f1, Const_float f2 -> float_compare f1 f2
-    | _, _ -> Pervasives.compare x y)
-    l
+  List.sort (fun (x,_) (y,_) -> const_compare x y) l
 
 let rec cut n l =
   if n = 0 then [],l
 
 
 
-let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = match next_matchs with
+let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs =
+  match next_matchs with
   | [] -> comp_fun partial ctx arg first_match
   | rem ->
       let rec c_rec body total_body = function
 
 
 (* verbose version of do_compile_matching, for debug *)
+
 (*
 and do_compile_matching_pr repr partial ctx arg x =
   prerr_string "COMPILE: " ;
   pretty_jumps jumps ;
   r
 *)
+
 and do_compile_matching repr partial ctx arg pmh = match pmh with
 | Pm pm ->
   let pat = what_is_cases pm.cases in

bytecomp/translcore.ml

   { prim_name = "caml_obj_dup"; prim_arity = 1; prim_alloc = true;
     prim_native_name = ""; prim_native_float = false }
 
+let find_primitive loc prim_name =
+  match prim_name with
+      "%revapply" -> Prevapply loc
+    | "%apply" -> Pdirapply loc
+    | name -> Hashtbl.find primitives_table name
+
 let transl_prim loc prim args =
   let prim_name = prim.prim_name in
   try
     end
   with Not_found ->
   try
-    let p =
-      match prim_name with
-          "%revapply" -> Prevapply loc
-        | "%apply" -> Pdirapply loc
-        | name -> Hashtbl.find primitives_table name in
+    let p = find_primitive loc prim_name in
     (* Try strength reduction based on the type of the argument *)
     begin match (p, args) with
         (Psetfield(n, _), [arg1; arg2]) -> Psetfield(n, maybe_pointer arg2)
 
 (* Eta-expand a primitive without knowing the types of its arguments *)
 
-let transl_primitive p =
+let transl_primitive loc p =
   let prim =
     try
       let (gencomp, _, _, _, _, _, _, _) =
       gencomp
     with Not_found ->
     try
-      Hashtbl.find primitives_table p.prim_name
+      find_primitive loc p.prim_name
     with Not_found ->
       Pccall p in
   match prim with
         Lfunction(Curried, [obj; meth; cache; pos],
                   Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc))
       else
-        transl_primitive p
+        transl_primitive e.exp_loc p
   | Texp_ident(path, _, {val_kind = Val_anc _}) ->
       raise(Error(e.exp_loc, Free_super_var))
   | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) ->

bytecomp/translcore.mli

                   -> Location.t -> lambda
 val transl_let:
       rec_flag -> (pattern * expression) list -> lambda -> lambda
-val transl_primitive: Primitive.description -> lambda
+val transl_primitive: Location.t -> Primitive.description -> lambda
 val transl_exception:
       Ident.t -> Path.t option -> exception_declaration -> lambda
 

bytecomp/translmod.ml

             (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)],
                     Location.none))))
   | Tcoerce_primitive p ->
-      transl_primitive p
+      transl_primitive Location.none p
 
 and apply_coercion_field id (pos, cc) =
   apply_coercion cc (Lprim(Pfield pos, [Lvar id]))
                 List.map
                   (fun (pos, cc) ->
                     match cc with
-                      Tcoerce_primitive p -> transl_primitive p
+                      Tcoerce_primitive p -> transl_primitive Location.none p
                     | _ -> apply_coercion cc (Lvar v.(pos)))
                   pos_cc_list)
       | _ ->
 
   and store_primitive (pos, prim) cont =
     Lsequence(Lprim(Psetfield(pos, false),
-                    [Lprim(Pgetglobal glob, []); transl_primitive prim]),
+                    [Lprim(Pgetglobal glob, []);
+                     transl_primitive Location.none prim]),
               cont)
 
   in List.fold_right store_primitive prims (transl_store !transl_store_subst str)

byterun/compact.c

         word q = *p;
         if (Color_hd (q) == Caml_white){
           size_t sz = Bhsize_hd (q);
-          char *newadr = compact_allocate (sz);  Assert (newadr <= (char *)p);
+          char *newadr = compact_allocate (sz);
           memmove (newadr, p, sz);
           p += Wsize_bsize (sz);
         }else{
     while (ch != NULL){
       if (Chunk_size (ch) > Chunk_alloc (ch)){
         caml_make_free_blocks ((value *) (ch + Chunk_alloc (ch)),
-                               Wsize_bsize (Chunk_size(ch)-Chunk_alloc(ch)), 1);
+                               Wsize_bsize (Chunk_size(ch)-Chunk_alloc(ch)), 1,
+                               Caml_white);
       }
       ch = Chunk_next (ch);
     }
 
 void caml_compact_heap (void)
 {
-  uintnat target_size, live;
+  uintnat target_words, target_size, live;
 
   do_compaction ();
   /* Compaction may fail to shrink the heap to a reasonable size
      See PR#5389
   */
   /* We compute:
-     freewords = caml_fl_cur_size          (exact)
-     heapsize = caml_heap_size             (exact)
-     live = heap_size - freewords
-     target_size = live * (1 + caml_percent_free / 100)
-                 = live / 100 * (100 + caml_percent_free)
-     We add 1 to live/100 to make sure it isn't 0.
+     freewords = caml_fl_cur_size                  (exact)
+     heapwords = Wsize_bsize (caml_heap_size)      (exact)
+     live = heapwords - freewords
+     wanted = caml_percent_free * (live / 100 + 1) (same as in do_compaction)
+     target_words = live + wanted
+     We add one page to make sure a small difference in counting sizes
+     won't make [do_compaction] keep the second block (and break all sorts
+     of invariants).
 
      We recompact if target_size < heap_size / 2
   */
-  live = caml_stat_heap_size - Bsize_wsize (caml_fl_cur_size);
-  target_size = (live / 100 + 1) * (100 + caml_percent_free);
-  target_size = caml_round_heap_chunk_size (target_size);
+  live = Wsize_bsize (caml_stat_heap_size) - caml_fl_cur_size;
+  target_words = live + caml_percent_free * (live / 100 + 1)
+                 + Wsize_bsize (Page_size);
+  target_size = caml_round_heap_chunk_size (Bsize_wsize (target_words));
   if (target_size < caml_stat_heap_size / 2){
     char *chunk;
 
-    /* round it up to a page size */
+    caml_gc_message (0x10, "Recompacting heap (target=%luk)\n",
+                     target_size / 1024);
+
     chunk = caml_alloc_for_heap (target_size);
     if (chunk == NULL) return;
+    /* PR#5757: we need to make the new blocks blue, or they won't be
+       recognized as free by the recompaction. */
     caml_make_free_blocks ((value *) chunk,
-                           Wsize_bsize (Chunk_size (chunk)), 0);
+                           Wsize_bsize (Chunk_size (chunk)), 0, Caml_blue);
     if (caml_page_table_add (In_heap, chunk, chunk + Chunk_size (chunk)) != 0){
       caml_free_for_heap (chunk);
       return;
     do_compaction ();
     Assert (caml_stat_heap_chunks == 1);
     Assert (Chunk_next (caml_heap_start) == NULL);
+    Assert (caml_stat_heap_size == Chunk_size (chunk));
   }
 }
 

byterun/freelist.c

    p: pointer to the first word of the block
    size: size of the block (in words)
    do_merge: 1 -> do merge; 0 -> do not merge
+   color: which color to give to the pieces; if [do_merge] is 1, this
+          is overridden by the merge code, but we have historically used
+          [Caml_white].
 */
-void caml_make_free_blocks (value *p, mlsize_t size, int do_merge)
+void caml_make_free_blocks (value *p, mlsize_t size, int do_merge, int color)
 {
   mlsize_t sz;
 
     }else{
       sz = size;
     }
-    *(header_t *)p = Make_header (Wosize_whsize (sz), 0, Caml_white);
+    *(header_t *)p = Make_header (Wosize_whsize (sz), 0, color);
     if (do_merge) caml_fl_merge_block (Bp_hp (p));
     size -= sz;
     p += sz;

byterun/freelist.h

 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);
+void caml_make_free_blocks (value *, mlsize_t, int, int);
 void caml_set_allocation_policy (uintnat);
 
 
     Assert(intern_dest <= end_extra_block);
     if (intern_dest < end_extra_block){
       caml_make_free_blocks ((value *) intern_dest,
-                             end_extra_block - intern_dest, 0);
+                             end_extra_block - intern_dest, 0, Caml_white);
     }
     caml_allocated_words +=
       Wsize_bsize ((char *) intern_dest - intern_extra_block);

byterun/major_gc.c

 
   caml_fl_init_merge ();
   caml_make_free_blocks ((value *) caml_heap_start,
-                         Wsize_bsize (caml_stat_heap_size), 1);
+                         Wsize_bsize (caml_stat_heap_size), 1, Caml_white);
   caml_gc_phase = Phase_idle;
   gray_vals_size = 2048;
   gray_vals = (value *) malloc (gray_vals_size * sizeof (value));
   }
   remain = malloc_request;
   prev = hp = mem;
-  /* XXX find a way to do this with a call to caml_make_free_blocks */
+  /* FIXME find a way to do this with a call to caml_make_free_blocks */
   while (Wosize_bhsize (remain) > Max_wosize){
     Hd_hp (hp) = Make_header (Max_wosize, 0, Caml_blue);
 #ifdef DEBUG

byterun/startup.c

       case 'b': caml_record_backtrace(Val_true); break;
       case 'p': caml_parser_trace = 1; break;
       case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break;
+#ifdef DEBUG
+      case 't': caml_trace_flag = 1; break;
+#endif
       }
     }
   }

config/auto-aux/tryassemble

 #!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2012 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.   #
+#                                                                       #
+#########################################################################
+
 if test "$verbose" = yes; then
 echo "tryassemble: $aspp -o tst $*" >&2
 $aspp -o tst $* || exit 100

driver/main_args.ml

 ;;
 
 let mk_absname f =
-  "-absname", Arg.Unit f, "  Show absolute filenames in error message"
+  "-absname", Arg.Unit f, "  Show absolute filenames in error messages"
 ;;
 
 let mk_annot f =
 	      (byte-compile-file "inf-caml.el") \
 	      (byte-compile-file "caml-help.el") \
 	      (byte-compile-file "caml-types.el") \
+	      (byte-compile-file "caml-font.el") \
 	      (byte-compile-file "camldebug.el"))
 
 install:
 	$(EMACS) --batch --eval '$(COMPILECMD)'
 
 clean:
-	rm -f ocamltags *~ #*# *.elc
+	rm -f ocamltags *~ \#*# *.elc

emacs/caml-font.el

+;(***********************************************************************)
+;(*                                                                     *)
+;(*                                OCaml                                *)
+;(*                                                                     *)
+;(*         Jacques Garrigue, Ian T Zimmerman, Damien Doligez           *)
+;(*                                                                     *)
+;(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
+;(*  en Automatique.  All rights reserved.  This file is distributed    *)
+;(*  under the terms of the GNU General Public License.                 *)
+;(*                                                                     *)
+;(***********************************************************************)
+
 ;; caml-font: font-lock support for OCaml files
 ;; now with perfect parsing of comments and strings
 
   "Syntax table in use in Caml mode buffers.")
 (if caml-mode-syntax-table
     ()
-  (setq caml-mode-syntax-table (make-syntax-table))
-  ; backslash is an escape sequence
-  (modify-syntax-entry ?\\ "\\" caml-mode-syntax-table)
-  ; ( is first character of comment start
-  (modify-syntax-entry ?\( "()1n" caml-mode-syntax-table)
-  ; * is second character of comment start,
-  ; and first character of comment end
-  (modify-syntax-entry ?*  ". 23n" caml-mode-syntax-table)
-  ; ) is last character of comment end
-  (modify-syntax-entry ?\) ")(4" caml-mode-syntax-table)
-  ; backquote was a string-like delimiter (for character literals)
-  ; (modify-syntax-entry ?` "\"" caml-mode-syntax-table)
-  ; quote and underscore are part of words
-  (modify-syntax-entry ?' "w" caml-mode-syntax-table)
-  (modify-syntax-entry ?_ "w" caml-mode-syntax-table)
-  ; ISO-latin accented letters and EUC kanjis are part of words
-  (let ((i 160))
-    (while (< i 256)
-      (modify-syntax-entry i "w" caml-mode-syntax-table)
-      (setq i (1+ i)))))
+  (let ((n (if (string-match "XEmacs" (emacs-version)) "" "n")))
+    (setq caml-mode-syntax-table (make-syntax-table))
+    ; backslash is an escape sequence
+    (modify-syntax-entry ?\\ "\\" caml-mode-syntax-table)
+    ; ( is first character of comment start
+    (modify-syntax-entry ?\( (concat "()1" n) caml-mode-syntax-table)
+    ; * is second character of comment start,
+    ; and first character of comment end
+    (modify-syntax-entry ?*  (concat ". 23" n) caml-mode-syntax-table)
+    ; ) is last character of comment end
+    (modify-syntax-entry ?\) ")(4" caml-mode-syntax-table)
+    ; backquote was a string-like delimiter (for character literals)
+    ; (modify-syntax-entry ?` "\"" caml-mode-syntax-table)
+    ; quote and underscore are part of words
+    (modify-syntax-entry ?' "w" caml-mode-syntax-table)
+    (modify-syntax-entry ?_ "w" caml-mode-syntax-table)
+    ; ISO-latin accented letters and EUC kanjis are part of words
+    (let ((i 160))
+      (while (< i 256)
+        (modify-syntax-entry i "w" caml-mode-syntax-table)
+        (setq i (1+ i))))))
 
 (defvar caml-mode-abbrev-table nil
   "Abbrev table used for Caml mode buffers.")
   "^[ A-\377]+ \"\\([^\"\n]+\\)\", [A-\377]+ \\([0-9]+\\)[-,:]"
   "Regular expression matching the error messages produced by camlc.")
 
+;; Newer emacs versions support line/char ranges
+;; We will adapt OCaml to output error messages in a compatible format.
+;; In the meantime we add the new format here in addition to the old one.
+(defconst caml-error-regexp-newstyle
+  "^[ A-\377]+ \"\\([^\"\n]+\\)\", line \\([0-9]+\\), char \\([0-9]+\\) to line \\([0-9]+\\), char \\([0-9]+\\):"
+  "Regular expression matching the error messages produced by ocamlc/ocamlopt.")
+
 (if (boundp 'compilation-error-regexp-alist)
-    (or (assoc caml-error-regexp
-               compilation-error-regexp-alist)
-        (setq compilation-error-regexp-alist
-              (cons (list caml-error-regexp 1 2)
-               compilation-error-regexp-alist))))
+    (progn
+      (or (assoc caml-error-regexp
+                 compilation-error-regexp-alist)
+          (setq compilation-error-regexp-alist
+                (cons (list caml-error-regexp 1 2)
+                      compilation-error-regexp-alist)))
+      (or (assoc caml-error-regexp-newstyle
+                 compilation-error-regexp-alist)
+          (setq compilation-error-regexp-alist
+                (cons (list caml-error-regexp-newstyle 1 '(2 . 4) '(3 . 5))
+                      compilation-error-regexp-alist)))))
 
 ;; A regexp to extract the range info
 
 (defconst caml-kwop-regexps (make-vector 9 nil)
   "Array of regexps representing caml keywords of different priorities.")
 
+(defun caml-in-shebang-line ()
+  (save-excursion
+    (beginning-of-line)
+    (and (= 1 (point)) (looking-at "#!"))))
+
 (defun caml-in-expr-p ()
   (let ((pos (point)) (in-expr t))
     (caml-find-kwop
              caml-matching-kw-regexp "\\|"
              (aref caml-kwop-regexps caml-max-indent-priority)))
     (cond
+     ; special case for #! at beginning of file
+     ((caml-in-shebang-line) (setq in-expr nil))
      ; special case for ;;
      ((and (> (point) 1) (= (preceding-char) ?\;) (= (following-char) ?\;))
       (setq in-expr nil))

experimental/frisch/ast_mapper.ml

 let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
 let map_opt f = function None -> None | Some x -> Some (f x)
 
-module SI = struct
-  (* Structure items *)
-
-  let mk ?(loc = Location.none) x = {pstr_desc = x; pstr_loc = loc}
-  let eval ?loc e = mk ?loc (Pstr_eval e)
-  let value ?loc r pel = mk ?loc (Pstr_value (r, pel))
-  let primitive ?loc name vd = mk ?loc (Pstr_primitive (name, vd))
-  let typ ?loc tdecls = mk ?loc (Pstr_type tdecls)
-  let exn ?loc name edecl = mk ?loc (Pstr_exception (name, edecl))
-  let exn_rebind ?loc name lid = mk ?loc (Pstr_exn_rebind (name, lid))
-  let module_ ?loc s m = mk ?loc (Pstr_module (s, m))
-  let rec_module ?loc rm = mk ?loc (Pstr_recmodule rm)
-  let modtype ?loc s mty = mk ?loc (Pstr_modtype (s, mty))
-  let open_ ?loc lid = mk ?loc (Pstr_open lid)
-  let class_ ?loc l = mk ?loc (Pstr_class l)
-  let class_type ?loc l = mk ?loc (Pstr_class_type l)
-  let include_ ?loc me = mk ?loc (Pstr_include me)
-
-  let map sub {pstr_loc = loc; pstr_desc = desc} =
+module T = struct
+  (* Type expressions for the core language *)
+
+  let mk ?(loc = Location.none) x = {ptyp_desc = x; ptyp_loc = loc}
+  let any ?loc () = mk ?loc Ptyp_any
+  let var ?loc a = mk ?loc (Ptyp_var a)
+  let arrow ?loc a b c = mk ?loc (Ptyp_arrow (a, b, c))
+  let tuple ?loc a = mk ?loc (Ptyp_tuple a)
+  let constr ?loc a b = mk ?loc (Ptyp_constr (a, b))
+  let object_ ?loc a = mk ?loc (Ptyp_object a)
+  let class_ ?loc a b c = mk ?loc (Ptyp_class (a, b, c))
+  let alias ?loc a b = mk ?loc (Ptyp_alias (a, b))
+  let variant ?loc a b c = mk ?loc (Ptyp_variant (a, b, c))
+  let poly ?loc a b = mk ?loc (Ptyp_poly (a, b))
+  let package ?loc a b = mk ?loc (Ptyp_package (a, b))
+
+  let field_type ?(loc = Location.none) x = {pfield_desc = x; pfield_loc = loc}
+  let field ?loc s t =
+    let t =
+      (* The type-checker expects the field to be a Ptyp_poly. Maybe
+         it should wrap the type automatically... *)
+      match t.ptyp_desc with
+      | Ptyp_poly _ -> t
+      | _ -> poly ?loc [] t
+    in
+    field_type ?loc (Pfield (s, t))
+  let field_var ?loc () = field_type ?loc Pfield_var
+
+  let core_field_type sub = function
+    | {pfield_desc = Pfield (s, d); pfield_loc = loc} -> field ~loc s (sub # typ d)
+    | x -> x
+
+  let row_field sub = function
+    | Rtag (l, b, tl) -> Rtag (l, b, List.map (sub # typ) tl)
+    | Rinherit t -> Rinherit (sub # typ t)
+
+  let map sub {ptyp_desc = desc; ptyp_loc = loc} =
+    match desc with
+    | Ptyp_any -> any ~loc ()
+    | Ptyp_var s -> var ~loc s
+    | Ptyp_arrow (lab, t1, t2) -> arrow ~loc lab (sub # typ t1) (sub # typ t2)
+    | Ptyp_tuple tyl -> tuple ~loc (List.map (sub # typ) tyl)
+    | Ptyp_constr (lid, tl) -> constr ~loc lid (List.map (sub # typ) tl)
+    | Ptyp_object l -> object_ ~loc (List.map (core_field_type sub) l)
+    | Ptyp_class (lid, tl, ll) -> class_ ~loc lid (List.map (sub # typ) tl) ll
+    | Ptyp_alias (t, s) -> alias ~loc (sub # typ t) s
+    | Ptyp_variant (rl, b, ll) -> variant ~loc (List.map (row_field sub) rl) b ll
+    | Ptyp_poly (sl, t) -> poly ~loc sl (sub # typ t)
+    | Ptyp_package (lid, l) -> package ~loc lid (List.map (map_snd (sub # typ)) l)
+
+  let map_type_declaration sub td =
+    {td with
+     ptype_cstrs =
+     List.map
+       (fun (ct1, ct2, loc) -> sub # typ ct1, sub # typ ct2, loc)
+       td.ptype_cstrs;
+     ptype_kind = sub # type_kind td.ptype_kind;
+     ptype_manifest = map_opt (sub # typ) td.ptype_manifest;
+    }
+
+  let map_type_kind sub = function
+    | Ptype_abstract -> Ptype_abstract
+    | Ptype_variant l -> Ptype_variant (List.map (fun (s, tl, t, loc) -> (s, List.map (sub # typ) tl, map_opt (sub # typ) t, loc)) l)
+    | Ptype_record l -> Ptype_record (List.map (fun (s, flags, t, loc) -> (s, flags, sub # typ t, loc)) l)
+end
+
+module CT = struct
+  (* Type expressions for the class language *)
+
+  let mk ?(loc = Location.none) x = {pcty_loc = loc; pcty_desc = x}
+
+  let constr ?loc a b = mk ?loc (Pcty_constr (a, b))
+  let signature ?loc a = mk ?loc (Pcty_signature a)
+  let fun_ ?loc a b c = mk ?loc (Pcty_fun (a, b, c))
+
+  let map sub {pcty_loc = loc; pcty_desc = desc} =
+    match desc with
+    | Pcty_constr (lid, tys) -> constr ~loc lid (List.map (sub # typ) tys)
+    | Pcty_signature x -> signature ~loc (sub # class_signature x)
+    | Pcty_fun (lab, t, ct) ->
+        fun_ ~loc lab
+          (sub # typ t)
+          (sub # class_type ct)
+
+  let mk_field ?(loc = Location.none) x = {pctf_desc = x; pctf_loc = loc}
+
+  let inher ?loc a = mk_field ?loc (Pctf_inher a)
+  let val_ ?loc a b c d = mk_field ?loc (Pctf_val (a, b, c, d))
+  let virt ?loc a b c = mk_field ?loc (Pctf_virt (a, b, c))
+  let meth ?loc a b c = mk_field ?loc (Pctf_meth (a, b, c))
+  let cstr ?loc a b = mk_field ?loc (Pctf_cstr (a, b))
+
+  let map_field sub {pctf_desc = desc; pctf_loc = loc} =
+    match desc with
+    | Pctf_inher ct -> inher ~loc (sub # class_type ct)
+    | Pctf_val (s, m, v, t) -> val_ ~loc s m v (sub # typ t)
+    | Pctf_virt (s, p, t) -> virt ~loc s p (sub # typ t)
+    | Pctf_meth (s, p, t) -> meth ~loc s p (sub # typ t)
+    | Pctf_cstr (t1, t2) -> cstr ~loc (sub # typ t1) (sub # typ t2)
+
+  let map_signature sub {pcsig_self; pcsig_fields; pcsig_loc} =
+    {
+     pcsig_self = sub # typ pcsig_self;
+     pcsig_fields = List.map (sub # class_type_field) pcsig_fields;
+     pcsig_loc;
+    }
+end
+
+module MT = struct
+  (* Type expressions for the module language *)
+
+  let mk ?(loc = Location.none) x = {pmty_desc = x; pmty_loc = loc}
+  let ident ?loc a = mk ?loc (Pmty_ident a)
+  let signature ?loc a = mk ?loc (Pmty_signature a)
+  let functor_ ?loc a b c = mk ?loc (Pmty_functor (a, b, c))
+  let with_ ?loc a b = mk ?loc (Pmty_with (a, b))
+  let typeof_ ?loc a = mk ?loc (Pmty_typeof a)
+
+  let map sub {pmty_desc = desc; pmty_loc = loc} =
+    match desc with
+    | Pmty_ident s -> ident ~loc s
+    | Pmty_signature sg -> signature ~loc (sub # signature sg)
+    | Pmty_functor (s, mt1, mt2) -> functor_ ~loc s (sub # module_type mt1) (sub # module_type mt2)
+    | Pmty_with (mt, l) -> with_ ~loc (sub # module_type mt) (List.map (map_snd (sub # with_constraint)) l)
+    | Pmty_typeof me -> typeof_ ~loc (sub # module_expr me)
+
+  let map_with_constraint sub = function
+    | Pwith_type d -> Pwith_type (sub # type_declaration d)
+    | Pwith_module s -> Pwith_module s
+    | Pwith_typesubst d -> Pwith_typesubst (sub # type_declaration d)
+    | Pwith_modsubst s -> Pwith_modsubst s
+
+  let mk_item ?(loc = Location.none) x = {psig_desc = x; psig_loc = loc}
+
+  let value ?loc a b = mk_item ?loc (Psig_value (a, b))
+  let type_ ?loc a = mk_item ?loc (Psig_type a)
+  let exception_ ?loc a b = mk_item ?loc (Psig_exception (a, b))
+  let module_ ?loc a b = mk_item ?loc (Psig_module (a, b))
+  let rec_module ?loc a = mk_item ?loc (Psig_recmodule a)
+  let modtype ?loc a b = mk_item ?loc (Psig_modtype (a, b))
+  let open_ ?loc a = mk_item ?loc (Psig_open a)
+  let include_ ?loc a = mk_item ?loc (Psig_include a)
+  let class_ ?loc a = mk_item ?loc (Psig_class a)
+  let class_type ?loc a = mk_item ?loc (Psig_class_type a)
+
+  let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
+    match desc with
+    | Psig_value (s, vd) -> value ~loc s (sub # value_description vd)
+    | Psig_type l -> type_ ~loc (List.map (map_snd (sub # type_declaration)) l)
+    | Psig_exception (s, ed) -> exception_ ~loc s (sub # exception_declaration ed)
+    | Psig_module (s, mt) -> module_ ~loc s (sub # module_type mt)
+    | Psig_recmodule l -> rec_module ~loc (List.map (map_snd (sub # module_type)) l)
+    | Psig_modtype (s, Pmodtype_manifest mt) -> modtype ~loc s (Pmodtype_manifest  (sub # module_type mt))
+    | Psig_modtype (s, Pmodtype_abstract) -> modtype ~loc s Pmodtype_abstract
+    | Psig_open s -> open_ ~loc s
+    | Psig_include mt -> include_ ~loc (sub # module_type mt)
+    | Psig_class l -> class_ ~loc (List.map (sub # class_description) l)
+    | Psig_class_type l -> class_type ~loc (List.map (sub # class_type_declaration) l)
+
+end
+
+
+module M = struct
+  (* Value expressions for the module language *)
+
+  let mk ?(loc = Location.none) x = {pmod_desc = x; pmod_loc = loc}
+  let ident ?loc x = mk ?loc (Pmod_ident x)
+  let structure ?loc x = mk ?loc (Pmod_structure x)
+  let functor_ ?loc arg arg_ty body = mk ?loc (Pmod_functor (arg, arg_ty, body))
+  let apply ?loc m1 m2 = mk ?loc (Pmod_apply (m1, m2))
+  let constraint_ ?loc m mty = mk ?loc (Pmod_constraint (m, mty))
+  let unpack ?loc e = mk ?loc (Pmod_unpack e)
+
+  let map sub {pmod_loc = loc; pmod_desc = desc} =
+    match desc with
+    | Pmod_ident x -> ident ~loc x
+    | Pmod_structure str -> structure ~loc (sub # structure str)
+    | Pmod_functor (arg, arg_ty, body) -> functor_ ~loc arg (sub # module_type arg_ty) (sub # module_expr body)
+    | Pmod_apply (m1, m2) -> apply ~loc (sub # module_expr m1) (sub # module_expr m2)
+    | Pmod_constraint (m, mty) -> constraint_ ~loc (sub # module_expr m) (sub # module_type mty)
+    | Pmod_unpack e -> unpack ~loc (sub # expr e)
+
+  let mk_item ?(loc = Location.none) x = {pstr_desc = x; pstr_loc = loc}
+  let eval ?loc a = mk_item ?loc (Pstr_eval a)
+  let value ?loc a b = mk_item ?loc (Pstr_value (a, b))
+  let primitive ?loc a b = mk_item ?loc (Pstr_primitive (a, b))
+  let type_ ?loc a = mk_item ?loc (Pstr_type a)
+  let exception_ ?loc a b = mk_item ?loc (Pstr_exception (a, b))
+  let exn_rebind ?loc a b = mk_item ?loc (Pstr_exn_rebind (a, b))
+  let module_ ?loc a b = mk_item ?loc (Pstr_module (a, b))
+  let rec_module ?loc a = mk_item ?loc (Pstr_recmodule a)
+  let modtype ?loc a b = mk_item ?loc (Pstr_modtype (a, b))
+  let open_ ?loc a = mk_item ?loc (Pstr_open a)
+  let class_ ?loc a = mk_item ?loc (Pstr_class a)
+  let class_type ?loc a = mk_item ?loc (Pstr_class_type a)
+  let include_ ?loc a = mk_item ?loc (Pstr_include a)
+
+  let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
     match desc with
     | Pstr_eval x -> eval ~loc (sub # expr x)
     | Pstr_value (r, pel) -> value ~loc r (List.map (map_tuple (sub # pat) (sub # expr)) pel)
     | Pstr_primitive (name, vd) -> primitive ~loc name (sub # value_description vd)
-    | Pstr_type l -> typ ~loc (List.map (fun (s, d) -> (s, sub # type_declaration d)) l)
-    | Pstr_exception (name, ed) -> exn ~loc name (List.map (sub # typ) ed)
+    | Pstr_type l -> type_ ~loc (List.map (fun (s, d) -> (s, sub # type_declaration d)) l)
+    | Pstr_exception (name, ed) -> exception_ ~loc name (sub # exception_declaration ed)
     | Pstr_exn_rebind (s, lid) -> exn_rebind ~loc s lid
     | Pstr_module (s, m) -> module_ ~loc s (sub # module_expr m)
     | Pstr_recmodule l -> rec_module ~loc (List.map (fun (s, mty, me) -> (s, sub # module_type mty, sub # module_expr me)) l)
 end
 
 module E = struct
-  (* Expressions *)
+  (* Value expressions for the core language *)
 
   let mk ?(loc = Location.none) x = {pexp_desc = x; pexp_loc = loc}
 
   let ident ?loc a = mk ?loc (Pexp_ident a)
-  let const ?loc a = mk ?loc (Pexp_constant a)
+  let constant ?loc a = mk ?loc (Pexp_constant a)
   let let_ ?loc a b c = mk ?loc (Pexp_let (a, b, c))
-  let func ?loc a b c = mk ?loc (Pexp_function (a, b, c))
-  let apply_with_labels ?loc a b = mk ?loc (Pexp_apply (a, b))
+  let function_ ?loc a b c = mk ?loc (Pexp_function (a, b, c))
+  let apply ?loc a b = mk ?loc (Pexp_apply (a, b))
   let match_ ?loc a b = mk ?loc (Pexp_match (a, b))
   let try_ ?loc a b = mk ?loc (Pexp_try (a, b))
   let tuple ?loc a = mk ?loc (Pexp_tuple a)
-  let constr ?loc a b c = mk ?loc (Pexp_construct (a, b, c))
+  let construct ?loc a b c = mk ?loc (Pexp_construct (a, b, c))
   let variant ?loc a b = mk ?loc (Pexp_variant (a, b))
   let record ?loc a b = mk ?loc (Pexp_record (a, b))
   let field ?loc a b = mk ?loc (Pexp_field (a, b))
   let open_ ?loc a b = mk ?loc (Pexp_open (a, b))
 
   let lid ?(loc = Location.none) lid = ident ~loc (mkloc (Longident.parse lid) loc)
-  let apply ?loc f el = apply_with_labels ?loc f (List.map (fun e -> ("", e)) el)
-  let strconst ?loc x = const ?loc (Const_string x)
+  let apply_nolabs ?loc f el = apply ?loc f (List.map (fun e -> ("", e)) el)
+  let strconst ?loc x = constant ?loc (Const_string x)
 
   let map sub {pexp_loc = loc; pexp_desc = desc} =
     match desc with
     | Pexp_ident x -> ident ~loc x
-    | Pexp_constant x -> const ~loc x
+    | Pexp_constant x -> constant ~loc x
     | Pexp_let (r, pel, e) -> let_ ~loc r (List.map (map_tuple (sub # pat) (sub # expr)) pel) (sub # expr e)
-    | Pexp_function (lab, def, pel) -> func ~loc lab (map_opt (sub # expr) def) (List.map (map_tuple (sub # pat) (sub # expr)) pel)
-    | Pexp_apply (e, l) -> apply_with_labels ~loc (sub # expr e) (List.map (map_snd (sub # expr)) l)
+    | Pexp_function (lab, def, pel) -> function_ ~loc lab (map_opt (sub # expr) def) (List.map (map_tuple (sub # pat) (sub # expr)) pel)
+    | Pexp_apply (e, l) -> apply ~loc (sub # expr e) (List.map (map_snd (sub # expr)) l)
     | Pexp_match (e, l) -> match_ ~loc (sub # expr e) (List.map (map_tuple (sub # pat) (sub # expr)) l)
     | Pexp_try (e, l) -> try_ ~loc (sub # expr e) (List.map (map_tuple (sub # pat) (sub # expr)) l)
     | Pexp_tuple el -> tuple ~loc (List.map (sub # expr) el)
-    | Pexp_construct (lid, arg, b) -> constr ~loc lid (map_opt (sub # expr) arg) b
+    | Pexp_construct (lid, arg, b) -> construct ~loc lid (map_opt (sub # expr) arg) b
     | Pexp_variant (lab, eo) -> variant ~loc lab (map_opt (sub # expr) eo)
-    | Pexp_record (l, eo) -> record ~loc (List.map (map_snd (sub # expr)) l) (map_opt (sub # expr) eo)
+    | Pexp_record (l, eo) -> record ~loc (List.map (fun (id, e) -> (id, sub # expr e)) l) (map_opt (sub # expr) eo)
     | Pexp_field (e, lid) -> field ~loc (sub # expr e) lid
     | Pexp_setfield (e1, lid, e2) -> setfield ~loc (sub # expr e1) lid (sub # expr e2)
     | Pexp_array el -> array ~loc (List.map (sub # expr) el)
     | Pexp_open (lid, e) -> open_ ~loc lid (sub # expr e)
 end
 
-module T = struct
-  (* Core types *)
-
-  let mk ?(loc = Location.none) x = {ptyp_desc = x; ptyp_loc = loc}
-  let any ?loc () = mk ?loc Ptyp_any
-  let var ?loc a = mk ?loc (Ptyp_var a)
-  let arrow ?loc a b c = mk ?loc (Ptyp_arrow (a, b, c))
-  let tuple ?loc a = mk ?loc (Ptyp_tuple a)
-  let constr ?loc a b = mk ?loc (Ptyp_constr (a, b))
-  let object_ ?loc a = mk ?loc (Ptyp_object a)
-  let class_ ?loc a b c = mk ?loc (Ptyp_class (a, b, c))
-  let alias ?loc a b = mk ?loc (Ptyp_alias (a, b))
-  let variant ?loc a b c = mk ?loc (Ptyp_variant (a, b, c))
-  let poly ?loc a b = mk ?loc (Ptyp_poly (a, b))
-  let package ?loc a b = mk ?loc (Ptyp_package (a, b))
-
-  let field_type ?(loc = Location.none) x = {pfield_desc = x; pfield_loc = loc}
-  let field ?loc s t =
-    let t =
-      (* The type-checker expects the field to be a Ptyp_poly. Maybe
-         it should wrap the type automatically... *)
-      match t.ptyp_desc with
-      | Ptyp_poly _ -> t
-      | _ -> poly ?loc [] t
-    in
-    field_type ?loc (Pfield (s, t))
-  let field_var ?loc () = field_type ?loc Pfield_var
-
-  let core_field_type sub = function
-    | {pfield_desc = Pfield (s, d); pfield_loc = loc} -> field ~loc s (sub # typ d)
-    | x -> x
-
-  let row_field sub = function
-    | Rtag (l, b, tl) -> Rtag (l, b, List.map (sub # typ) tl)
-    | Rinherit t -> Rinherit (sub # typ t)
-
-  let map sub {ptyp_desc = desc; ptyp_loc = loc} =
-    match desc with
-    | Ptyp_any -> any ~loc ()
-    | Ptyp_var s -> var ~loc s
-    | Ptyp_arrow (lab, t1, t2) -> arrow ~loc lab (sub # typ t1) (sub # typ t2)
-    | Ptyp_tuple tyl -> tuple ~loc (List.map (sub # typ) tyl)
-    | Ptyp_constr (lid, tl) -> constr ~loc lid (List.map (sub # typ) tl)
-    | Ptyp_object l -> object_ ~loc (List.map (core_field_type sub) l)
-    | Ptyp_class (lid, tl, ll) -> class_ ~loc lid (List.map (sub # typ) tl) ll
-    | Ptyp_alias (t, s) -> alias ~loc (sub # typ t) s
-    | Ptyp_variant (rl, b, ll) -> variant ~loc (List.map (row_field sub) rl) b ll
-    | Ptyp_poly (sl, t) -> poly ~loc sl (sub # typ t)
-    | Ptyp_package (lid, l) -> package ~loc lid (List.map (map_snd (sub # typ)) l)
-end
-
 module P = struct
   (* Patterns *)
 
   let alias ?loc a b = mk ?loc (Ppat_alias (a, b))
   let constant ?loc a = mk ?loc (Ppat_constant a)
   let tuple ?loc a = mk ?loc (Ppat_tuple a)
-  let constr ?loc a b c = mk ?loc (Ppat_construct (a, b, c))
+  let construct ?loc a b c = mk ?loc (Ppat_construct (a, b, c))
   let variant ?loc a b = mk ?loc (Ppat_variant (a, b))
   let record ?loc a b = mk ?loc (Ppat_record (a, b))
   let array ?loc a = mk ?loc (Ppat_array a)
   let type_ ?loc a = mk ?loc (Ppat_type a)
   let lazy_ ?loc a = mk ?loc (Ppat_lazy a)
   let unpack ?loc a = mk ?loc (Ppat_unpack a)
-end
-
-module M = struct
-  (* Module expressions *)
-
-  let mk ?(loc = Location.none) x = {pmod_desc = x; pmod_loc = loc}
-  let ident ?loc x = mk ?loc (Pmod_ident x)
-  let structure ?loc x = mk ?loc (Pmod_structure x)
-  let funct ?loc arg arg_ty body = mk ?loc (Pmod_functor (arg, arg_ty, body))
-  let apply ?loc m1 m2 = mk ?loc (Pmod_apply (m1, m2))
-  let constr ?loc m mty = mk ?loc (Pmod_constraint (m, mty))
-  let unpack ?loc e = mk ?loc (Pmod_unpack e)
 
-  let map sub {pmod_loc = loc; pmod_desc = desc} =
+  let map sub {ppat_desc = desc; ppat_loc = loc} =
     match desc with
-    | Pmod_ident x -> ident ~loc x
-    | Pmod_structure str -> structure ~loc (sub # structure str)
-    | Pmod_functor (arg, arg_ty, body) -> funct ~loc arg (sub # module_type arg_ty) (sub # module_expr body)
-    | Pmod_apply (m1, m2) -> apply ~loc (sub # module_expr m1) (sub # module_expr m2)
-    | Pmod_constraint (m, mty) -> constr ~loc (sub # module_expr m) (sub # module_type mty)
-    | Pmod_unpack e -> unpack ~loc (sub # expr e)
+    | Ppat_any -> any ~loc ()
+    | Ppat_var s -> var ~loc s
+    | Ppat_alias (p, s) -> alias ~loc (sub # pat p) s
+    | Ppat_constant c -> constant ~loc c
+    | Ppat_tuple pl -> tuple ~loc (List.map (sub # pat) pl)
+    | Ppat_construct (l, p, b) -> construct ~loc l (map_opt (sub # pat) p) b
+    | Ppat_variant (l, p) -> variant ~loc l (map_opt (sub # pat) p)
+    | Ppat_record (lpl, cf) ->
+        (*record ~loc (List.map (map_snd (sub # pat)) lpl) cf*)
+        record ~loc
+          (List.map (fun (s, p) -> (s, sub # pat p)) lpl) cf
+    | Ppat_array pl -> array ~loc (List.map (sub # pat) pl)
+    | Ppat_or (p1, p2) -> or_ ~loc (sub # pat p1) (sub # pat p2)
+    | Ppat_constraint (p, t) -> constraint_ ~loc (sub # pat p) (sub # typ t)
+    | Ppat_type s -> type_ ~loc s
+    | Ppat_lazy p -> lazy_ ~loc (sub # pat p)
+    | Ppat_unpack s -> unpack ~loc s
 end
 
+module CE = struct
+  (* Value expressions for the class language *)
 
+  let mk ?(loc = Location.none) x = {pcl_loc = loc; pcl_desc = x}
 
+  let constr ?loc a b = mk ?loc (Pcl_constr (a, b))
+  let structure ?loc a = mk ?loc (Pcl_structure a)
+  let fun_ ?loc a b c d = mk ?loc (Pcl_fun (a, b, c, d))
+  let apply ?loc a b = mk ?loc (Pcl_apply (a, b))
+  let let_ ?loc a b c = mk ?loc (Pcl_let (a, b, c))
+  let constraint_ ?loc a b = mk ?loc (Pcl_constraint (a, b))
+
+  let map sub {pcl_loc = loc; pcl_desc = desc} =
+    match desc with
+    | Pcl_constr (lid, tys) -> constr ~loc lid (List.map (sub # typ) tys)
+    | Pcl_structure s ->
+        structure ~loc (sub # class_structure s)
+    | Pcl_fun (lab, e, p, ce) ->
+        fun_ ~loc lab
+          (map_opt (sub # expr) e)
+          (sub # pat p)
+          (sub # class_expr ce)
+    | Pcl_apply (ce, l) ->
+        apply ~loc (sub # class_expr ce) (List.map (map_snd (sub # expr)) l)
+    | Pcl_let (r, pel, ce) ->
+        let_ ~loc r
+          (List.map (map_tuple (sub # pat) (sub # expr)) pel)
+          (sub # class_expr ce)
+    | Pcl_constraint (ce, ct) ->
+        constraint_ ~loc (sub # class_expr ce) (sub # class_type ct)
+
+
+  let mk_field ?(loc = Location.none) x = {pcf_desc = x; pcf_loc = loc}
+
+  let inher ?loc a b c = mk_field ?loc (Pcf_inher (a, b, c))
+  let valvirt ?loc a b c = mk_field ?loc (Pcf_valvirt (a, b, c))
+  let val_ ?loc a b c d = mk_field ?loc (Pcf_val (a, b, c, d))
+  let virt ?loc a b c = mk_field ?loc (Pcf_virt (a, b, c))
+  let meth ?loc a b c d = mk_field ?loc (Pcf_meth (a, b, c, d))
+  let constr ?loc a b = mk_field ?loc (Pcf_constr (a, b))
+  let init ?loc a = mk_field ?loc (Pcf_init a)
+
+  let map_field sub {pcf_desc = desc; pcf_loc = loc} =
+    match desc with
+    | Pcf_inher (o, ce, s) -> inher ~loc o (sub # class_expr ce) s
+    | Pcf_valvirt (s, m, t) -> valvirt ~loc s m (sub # typ t)
+    | Pcf_val (s, m, o, e) -> val_ ~loc s m o (sub # expr e)
+    | Pcf_virt (s, p, t) -> virt ~loc s p (sub # typ t)
+    | Pcf_meth (s, p, o, e) -> meth ~loc s p o (sub # expr e)
+    | Pcf_constr (t1, t2) -> constr ~loc (sub # typ t1) (sub # typ t2)
+    | Pcf_init e -> init ~loc (sub # expr e)
+
+  let map_structure sub {pcstr_pat; pcstr_fields} =
+    {
+     pcstr_pat = sub # pat pcstr_pat;
+     pcstr_fields = List.map (sub # class_field) pcstr_fields;
+    }
+end
 
 (* Now, a generic AST mapper class, to be extended to cover all kinds
    and cases of the OCaml grammar.  The default behavior of the mapper
     method implementation (input_name : string) ast = (input_name, this # structure ast)
     method interface (input_name: string) ast = (input_name, this # signature ast)
     method structure l = map_flatten (this # structure_item) l
-    method structure_item si = [ SI.map this si ]
+    method structure_item si = [ M.map_structure_item this si ]
     method module_expr = M.map this
 
     method signature l = map_flatten (this # signature_item) l
-    method signature_item (x : signature_item) = [ x ] (* todo *)
-    method module_type x = x (* todo *)
-
-    method class_declaration x = x (* todo *)
-    method class_type_declaration x = x (* todo *)
-    method class_structure {pcstr_pat; pcstr_fields} =
-      {
-       pcstr_pat = this # pat pcstr_pat;
-       pcstr_fields = List.map (this # class_field) pcstr_fields;
-      }
-    method class_field x = x (* ... *)
-
-    method type_declaration x = x (* todo *)
+    method signature_item si = [ MT.map_signature_item this si ]
+    method module_type = MT.map this
+    method with_constraint c = MT.map_with_constraint this c
+
+    method class_declaration decl = {decl with pci_expr = this # class_expr decl.pci_expr}
+    method class_expr = CE.map this
+    method class_field = CE.map_field this
+    method class_structure = CE.map_structure this
+
+    method class_type = CT.map this
+    method class_type_field = CT.map_field this
+    method class_signature = CT.map_signature this
+
+    method class_type_declaration decl = {decl with pci_expr = this # class_type decl.pci_expr}
+    method class_description decl = {decl with pci_expr = this # class_type decl.pci_expr}
+
+    method type_declaration = T.map_type_declaration this
+    method type_kind = T.map_type_kind this
     method typ = T.map this
 
-    method value_description vd =
-      {vd with pval_type = this # typ vd.pval_type}
-    method pat p = p (* todo *)
+    method value_description vd = {vd with pval_type = this # typ vd.pval_type}
+    method pat = P.map this
     method expr = E.map this
+
+    method exception_declaration tl = List.map (this # typ) tl
   end
 
 

experimental/frisch/js_syntax.ml

 
 (* A few local helper functions to simplify the creation of AST nodes. *)
 let constr_ c l = T.constr (mknoloc (Longident.parse c)) l
-let apply_ f l = E.apply (E.lid f) l
+let apply_ f l = E.apply_nolabs (E.lid f) l
 let oobject l = T.object_ (List.map (fun (s, t) -> T.field s t) l @ [T.field_var ()])
 let eident x = E.ident (mknoloc (Lident x))
 let pvar x = P.var (mknoloc x)
 
 
 let rnd = Random.State.make [|0x513511d4|]
-let random_var () = Format.sprintf "a%08Lx" (Random.State.int64 rnd 0x100000000L)
+let random_var () = Format.sprintf "a%08Lx" (Random.State.int64 rnd 0x100000000L : Int64.t)
 let fresh_type () = T.var (random_var ())
 
 let unescape lab =
   let obj = annot e T.(constr_ "Js.t" [alias (oobject []) obj_type]) in
   let y = random_var () in
   let o = annot (eident y) (T.var obj_type) in
-  let constr = func "" None [pvar y, annot (send o m) m_typ] in
+  let constr = function_ "" None [pvar y, annot (send o m) m_typ] in
   let e = let_ Nonrecursive [pvar x, obj; P.any (), constr] (f (eident x)) in
   (set_loc loc) # expr e
 
     method! expr e =
       let loc = e.pexp_loc in
       match e.pexp_desc with
-      | Pexp_open ({txt = Lident "JS"}, e) ->
+      | Pexp_open ({txt = Lident "JVS"; loc = _}, e) ->
           {< js = true >} # expr e
 
-      | Pexp_field (o, {txt = Lident meth}) when js ->
+      | Pexp_field (o, {txt = Lident meth; loc = _}) when js ->
           let o = this # expr o in
           let prop_type = fresh_type () in
           let meth_type = constr_ "Js.gen_prop" [oobject ["get", prop_type]] in
           access_object loc o meth meth_type
             (fun x -> annot (apply_ "Js.Unsafe.get" [x; method_literal meth]) prop_type)
 
-      | Pexp_setfield (o, {txt = Lident meth}, e) when js ->
+      | Pexp_setfield (o, {txt = Lident meth; loc = _}, e) when js ->
           let o = this # expr o and e = this # expr e in
           let prop_type = fresh_type () in
           let meth_type = constr_ "Js.gen_prop" [oobject ["set", T.arrow "" prop_type (constr_ "unit" [])]] in
             (fun x -> apply_ "Js.Unsafe.set" [x; method_literal meth; annot e prop_type])
 
       | Pexp_apply ({pexp_desc = Pexp_send (o, meth); pexp_loc = loc}, args) when js ->
-          method_call loc o meth (List.map snd args)
+          method_call loc o meth (List.map (this # expr) (List.map snd args))
 
       | Pexp_send (o, meth) when js ->
           method_call loc o meth []

experimental/frisch/test_js.ml

 end
 
 let foo1 o =
-  if JS.(o.bar) then JS.(o.foo1.foo2) else JS.(o.foo2)
+  if JVS.(o.bar) then JVS.(o.foo1.foo2) else JVS.(o.