Commits

camlspotter committed c8b9a3d Merge

merge

Comments (0)

Files changed (82)

File contents unchanged.
 34e8d4a2bd36612fbe437d550b0d119dc9f6bd1e ocaml-4.01.0+dev2-12410
 bb92dae96c700ef003251b4068aa6fc93680682f ocaml-4.00.0+beta2-12583
+98c0f8b63a312173400f43a020a2b673dddd4499 ocaml-4.00.0+beta2-12699
+73079ded8dc97ba343854cf488f2264bc43e2990 ocaml-4.00.0-rc1-12755
       savings of 28%.
     . Added support for position-independent code, natdynlink, profiling and
       exception backtraces.
-- In -g mode, generation of CFI information and a few filename/line
-  number debugging annotations, enabling in particular precise stack
-  backtraces with the gdb debugger. Currently supported for x86 32-bits
-  and 64-bits only. (PR#5487)
+- Generation of CFI information, and filename/line number debugging (with -g)
+  annotations, enabling in particular precise stack backtraces with
+  the gdb debugger. Currently supported for x86 32-bits and 64-bits only.
+  (PR#5487)
 - New tool: ocamloptp, the equivalent of ocamlcp for the native-code compiler.
 
 OCamldoc:
 - Random:
      . More random initialization (Random.self_init()), using /dev/urandom
        when available (e.g. Linux, FreeBSD, MacOS X, Solaris)
-     . Faster implementation of Random.float
+     * Faster implementation of Random.float (changes the generated sequences)
 - Scanf: new function "unescaped" (PR#3888)
 - Set and Map: more efficient implementation of "filter" and "partition"
 - String: new function "map" (PR#3888)
 - PR#5179: port OCaml to mingw-w64
 - PR#5211: updated Genlex documentation to state that camlp4 is mandatory for
   'parser' keyword and associated notation
+- PR#5214: ocamlfind plugin invokes 'cut' utility
 - PR#5218: use $(MAKE) instead of "make" in Makefiles
 - PR#5224: confusing error message in non-regular type definition
 - PR#5231: camlp4: fix parsing of <:str_item< type t = $x$ >>
   and -docflags switches
 - PR#5543: in Bigarray.map_file, try to avoid using lseek() when growing file
 - PR#5538: combining -i and -annot in ocamlc
+- PR#5648: (probably fixed) test failures in tests/lib-threads
 - PR#5551: repeated calls to find_in_path degrade performance
 - PR#5552: Mac OS X: unrecognized gcc option "-no-cpp-precomp"
 - PR#5555: add Hashtbl.reset to resize the bucket table to its initial size
 - PR#5585: typo: "explicitely"
 - PR#5587: documentation: "allows to" is not correct English
 - PR#5593: remove C file when -output-obj fails
+- PR#5597: register names for instrtrace primitives in embedded bytecode
 - PR#5598: add backslash-space support in strings in ocamllex
 - PR#5603: wrong .file debug info generated by ocamlopt -g
 - PR#5604: fix permissions of files created by ocamlbuild itself
 - PR#5644: Stream.count broken when used with Sapp or Slazy nodes
 - PR#5647: Cannot use install_printer in debugger
 - PR#5651: printer for abstract data type (camlp4 revised syntax)
+- PR#5654: self pattern variable location tweak
 - PR#5655: ocamlbuild doesn't pass cflags when building C stubs
+- PR#5657: wrong error location for abbreviated record fields
+- PR#5659: ocamlmklib -L option breaks with MSVC
 - PR#5661: fixes for the test suite
+- PR#5668: Camlp4 produces invalid syntax for "let _ = ..."
 - PR#5671: initialization of compare_ext field in caml_final_custom_operations()
 - PR#5677: do not use "value" as identifier (genprintval.ml)
+- PR#5687: dynlink broken when used from "output-obj" main program (bytecode)
 - problem with printing of string literals in camlp4 (reported on caml-list)
 - emacs mode: colorization of comments and strings now works correctly
 - problem with forall and method (reported on caml-list on 2011-07-26)
+- crash when using OCAMLRUNPARAM=a=X with invalid X (reported in private)
 
 Feature wishes:
 - PR#352: new option "-stdin" to make ocaml read stdin as a script
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile 12692 2012-07-10 15:20:34Z doligez $
+# $Id: Makefile 12750 2012-07-20 08:06:01Z doligez $
 
 # The main Makefile
 
 	cp utils/*.cm* parsing/*.cm* typing/*.cm* bytecomp/*.cm* driver/*.cm* toplevel/*.cm* $(COMPLIBDIR)
 	cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) $(COMPLIBDIR)
 	cp expunge $(LIBDIR)/expunge$(EXE)
+	cp toplevel/topdirs.cmi $(LIBDIR)
 	cd tools; $(MAKE) install
 	-cd man; $(MAKE) install
 	for i in $(OTHERLIBRARIES); do \
 #                                                                       #
 #########################################################################
 
-# $Id: Makefile.nt 12692 2012-07-10 15:20:34Z doligez $
+# $Id: Makefile.nt 12750 2012-07-20 08:06:01Z doligez $
 
 # The main Makefile
 
 	cp utils/*.cmi parsing/*.cmi typing/*.cmi bytecomp/*.cmi driver/*.cmi toplevel/*.cmi $(COMPLIBDIR)
 	cp compilerlibs/ocamlcommon.cma compilerlibs/ocamlbytecomp.cma compilerlibs/ocamltoplevel.cma $(BYTESTART) $(TOPLEVELSTART) $(COMPLIBDIR)
 	cp expunge $(LIBDIR)/expunge.exe
+	cp toplevel/topdirs.cmi $(LIBDIR)
 	cd tools ; $(MAKEREC) install
 	cd ocamldoc ; $(MAKEREC) install
 	mkdir -p $(STUBLIBDIR)
+typeloc branch: An attempt to improve unification error report.
+=================================================================
+
+This typeloc branch tries to print additional information at type unification
+errors, to indicate which parts of the source code introduce the type 
+constructors caused the errors.
+
+This is inspired from the same idea implemented for Haskell type checker 
+by Lennart Augustsson.
+
+Current status 
+---------------
+`Proof of concept' level implementation.
     Can be downloaded from http://alain.frisch.fr/flexdll.html
 
 [3] TCL/TK version 8.5.  Windows binaries are available as part of the
-    ActiveTCL distribution at http://www.activestate.com/products/ActiveTcl/
-
+    ActiveTCL distribution at http://www.activestate.com/activetcl/downloads
 
 RECOMPILATION FROM THE SOURCES:
 
 
 REQUIREMENTS:
 
-This port runs under MS Windows Vista, XP, and 2000.
+This port runs under MS Windows Seven, Vista, XP, and 2000.
 
 The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...)
 runs without any additional tools.
 
  mingw64-i686-binutils
  mingw64-i686-gcc
+ mingw64-i686-gcc-core
  mingw64-i686-runtime
 
 
-NOTE:
+NOTES:
+
+  - Do not use the Cygwin version of flexdll for this port.
+
   - There is another 32-bit gcc compiler, from the MinGW.org
     project, packaged in Cygwin under the name mingw-gcc.
     It is not currently supported by flexdll and OCaml.
 
 The LablTk GUI requires Tcl/Tk 8.5.  Windows binaries are available
 as part of the ActiveTCL distribution at
-http://www.activestate.com/products/ActiveTcl/
+  http://www.activestate.com/activetcl/downloads
 Note that you will need to install the 32-bit version of ActiveTCL,
 even if you are on a 64-bit version of Windows.
 
 RECOMPILATION FROM THE SOURCES:
 
 You will need the following software components to perform the recompilation:
-- Windows NT, 2000, XP, or Vista.
-- Cygwin: http://sourceware.cygnus.com/cygwin/
-  Install at least the following packages:
+- Windows NT, 2000, XP, Vista, or Seven.
+- Cygwin: http://cygwin.com/
+  Install at least the following packages (and their dependencies, as
+  computed by Cygwin's setup.exe):
      mingw64-i686-binutils
      mingw64-i686-gcc
+     mingw64-i686-gcc-core
      mingw64-i686-runtime
      diffutils
      make
      ncurses
-- TCL/TK version 8.5 (see above).
-- The flexdll tool (see above).
+- Tcl/Tk version 8.5 (see above).
+- The flexdll tool (see above).  Do not forget to add the flexdll directory
+  to your PATH
 
 The standalone mingw toolchain from the MinGW-w64 project
 (http://mingw-w64.sourceforge.net/) is not supported.  Please use the
 version packaged in Cygwin instead.
 
-Start a Cygwin shell and unpack the source distribution
+Start a new Cygwin shell and unpack the source distribution
 (ocaml-X.YY.Z.tar.gz) with "tar xzf".  Change to the top-level
 directory of the OCaml distribution.  Then, do
 
 Then, edit config/Makefile as needed, following the comments in this file.
 Normally, the only variables that need to be changed are
         PREFIX      where to install everything
-        TK_ROOT     where TCL/TK was installed
+        TK_ROOT     where Tcl/Tk was installed
 
 Finally, use "make -f Makefile.nt" to build the system, e.g.
 
 
 RECOMPILATION FROM THE SOURCES:
 
+Before starting, make sure that the gcc version installed by cygwin
+is not 4.5.3 (it has a bug that affects OCaml).  If needed, use cygwin's
+setup.exe to downgrade to 4.3.4.
+
 You will need to recompile (and install) flexdll from source with
 Cygwin's C compiler because the official binary version of flexdll
 doesn't handle Cygwin's symbolic links and sometimes fails to
 launch the C compiler.
 
 In order to recompile flexdll, you first need to configure, compile,
-and install OCaml without flexdll support (by following the instructions
-in file INSTALL, except the "make opt.opt" part), then modify the
+and install OCaml without flexdll support, then modify the
 flexdll Makefile to change line 51 from:
   LINKFLAGS = -ccopt "-link version_res.o"
 to:
 Then "make CHAINS=cygwin" and add the flexdll directory to your PATH.
 Make sure to add it before "/usr/bin" or you will get cygwin's flexlink.
 
-Then, OCaml's source directory, type:
+Then, in OCaml's source directory, type:
   make clean
   make distclean
 and follow the instructions for Unix machines given in the file INSTALL.
 
 NOTES:
 
-The libraries available in this port are "num", "str", "threads",
-"unix" and "labltk".  "graph" is not available.
-The replay debugger is fully supported.
-When upgrading from 3.12.0 to 3.12.1, you will need to remove
-/usr/local/bin/ocamlmktop.exe before typing "make install".
+- There is a problem with cygwin's port of gcc version 4.5.3.  You should
+  use cygwin's setup program to downgrade to 4.3.4 before compiling OCaml.
+- The replay debugger is fully supported.
+- When upgrading from 3.12.0 to 3.12.1, you will need to remove
+  /usr/local/bin/ocamlmktop.exe before typing "make install".
+- In order to use the "graph" and "labltk" libraries, you will need
+  to use Cygwin's setup.exe to install the xinit, libX11-devel, tcl,
+  and tcl-tk packages before compiling OCaml.
 
 ------------------------------------------------------------------------------
 
-4.00.0+dev20-2012-06-04+camlp4-lexer-plug+annot+p4-expand-directory+typeloc
+4.00.0+dev22_2012-07-20+camlp4-lexer-plug+annot+p4-expand-directory+typeloc
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli
 
-# $Id: VERSION 12568 2012-06-04 17:02:56Z doligez $
+# $Id: VERSION 12750 2012-07-20 08:06:01Z doligez $
Binary file modified.

boot/ocamldep

Binary file modified.

boot/ocamllex

Binary file modified.

byterun/fix_code.c

 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: fix_code.c 12227 2012-03-13 14:44:48Z xleroy $ */
+/* $Id: fix_code.c 12715 2012-07-16 10:37:03Z frisch $ */
 
 /* Handling of blocks of bytecode (endianness switch, threading). */
 
 
 /* Read the main bytecode block from a file */
 
-void caml_load_code(int fd, asize_t len)
-{
-  int i;
+void caml_init_code_fragments() {
   struct code_fragment * cf;
-
-  caml_code_size = len;
-  caml_start_code = (code_t) caml_stat_alloc(caml_code_size);
-  if (read(fd, (char *) caml_start_code, caml_code_size) != caml_code_size)
-    caml_fatal_error("Fatal error: truncated bytecode file.\n");
   /* Register the code in the table of code fragments */
   cf = caml_stat_alloc(sizeof(struct code_fragment));
   cf->code_start = (char *) caml_start_code;
   cf->digest_computed = 1;
   caml_ext_table_init(&caml_code_fragments_table, 8);
   caml_ext_table_add(&caml_code_fragments_table, cf);
+}
+
+void caml_load_code(int fd, asize_t len)
+{
+  int i;
+
+  caml_code_size = len;
+  caml_start_code = (code_t) caml_stat_alloc(caml_code_size);
+  if (read(fd, (char *) caml_start_code, caml_code_size) != caml_code_size)
+    caml_fatal_error("Fatal error: truncated bytecode file.\n");
+  caml_init_code_fragments();
   /* Prepare the code for execution */
 #ifdef ARCH_BIG_ENDIAN
   caml_fixup_endianness(caml_start_code, caml_code_size);

byterun/fix_code.h

 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: fix_code.h 12227 2012-03-13 14:44:48Z xleroy $ */
+/* $Id: fix_code.h 12715 2012-07-16 10:37:03Z frisch $ */
 
 /* Handling of blocks of bytecode (endianness switch, threading). */
 
 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);

byterun/freelist.c

 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: freelist.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id: freelist.c 12708 2012-07-13 12:03:26Z doligez $ */
 
 #define FREELIST_DEBUG 0
 #if FREELIST_DEBUG
   switch (p){
   case Policy_next_fit:
     fl_prev = Fl_head;
+    policy = p;
     break;
   case Policy_first_fit:
     flp_size = 0;
     beyond = NULL;
+    policy = p;
     break;
   default:
-    Assert (0);
     break;
   }
-  policy = p;
 }

byterun/gc_ctrl.c

 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: gc_ctrl.c 12149 2012-02-10 16:15:24Z doligez $ */
+/* $Id: gc_ctrl.c 12708 2012-07-13 12:03:26Z doligez $ */
 
 #include "alloc.h"
 #include "compact.h"
   return s;
 }
 
-static intnat norm_policy (intnat p)
-{
-  if (p >= 0 && p <= 1){
-    return p;
-  }else{
-    return 1;
-  }
-}
-
 CAMLprim value caml_gc_set(value v)
 {
   uintnat newpf, newpm;
   asize_t newheapincr;
   asize_t newminsize;
-  uintnat newpolicy;
+  uintnat oldpolicy;
 
   caml_verb_gc = Long_val (Field (v, 3));
 
     caml_gc_message (0x20, "New heap increment size: %luk bytes\n",
                      caml_major_heap_increment/1024);
   }
-  newpolicy = norm_policy (Long_val (Field (v, 6)));
-  if (newpolicy != caml_allocation_policy){
-    caml_gc_message (0x20, "New allocation policy: %d\n", newpolicy);
-    caml_set_allocation_policy (newpolicy);
+  oldpolicy = caml_allocation_policy;
+  caml_set_allocation_policy (Long_val (Field (v, 6)));
+  if (oldpolicy != caml_allocation_policy){
+    caml_gc_message (0x20, "New allocation policy: %d\n",
+                     caml_allocation_policy);
   }
 
     /* Minor heap size comes last because it will trigger a minor collection

byterun/startup.c

 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: startup.c 12687 2012-07-10 12:11:46Z doligez $ */
+/* $Id: startup.c 12715 2012-07-16 10:37:03Z frisch $ */
 
 /* Start-up code */
 
   /* Load the code */
   caml_start_code = code;
   caml_code_size = code_size;
+  caml_init_code_fragments();
   if (caml_debugger_in_use) {
     int len, i;
     len = code_size / sizeof(opcode_t);

camlp4/Camlp4/Struct/Grammar/Parser.ml

   value drop_prev_loc = Tools.drop_prev_loc;
 
   value add_loc bp parse_fun strm =
-    let count1 = Stream.count strm in
     let x = parse_fun strm in
-    let count2 = Stream.count strm in
+    let ep = loc_ep strm in
     let loc =
-      if count1 < count2 then
-        let ep = loc_ep strm in
-        Loc.merge bp ep
-      else
+      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);
 

debugger/envaux.mli

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: envaux.mli 11156 2011-07-27 14:17:02Z doligez $ *)
+(* $Id: envaux.mli 12700 2012-07-11 17:23:37Z lefessan $ *)
 
 open Format
 
 (* Convert environment summaries to environments *)
 
+val env_from_summary : Env.summary -> Subst.t -> Env.t
 val env_of_event: Instruct.debug_event option -> Env.t
 
 (* Empty the environment caches. To be called when load_path changes. *)

ocamlbuild/findlib.ml

       | Lexers.Error s ->
           error (Cannot_parse_query (name, s))
 
+let split_nl s =
+  let x = ref [] in
+  let rec go s =
+    let pos = String.index s '\n' in
+    x := (String.before s pos)::!x;
+    go (String.after s (pos + 1))
+  in
+  try
+    go s
+  with Not_found -> !x
+
+let before_space s =
+  try
+    String.before s (String.index s ' ')
+  with Not_found -> s
+
 let list () =
-  run_and_parse Lexers.blank_sep_strings "%s list | cut -d' ' -f1" ocamlfind
+  List.map before_space (split_nl & run_and_read "%s list" ocamlfind)
 
 (* The closure algorithm is easy because the dependencies are already closed
 and sorted for each package. We only have to make the union. We could also

ocamldoc/Makefile

 #(*                                                                     *)
 #(***********************************************************************)
 
-# $Id: Makefile 12692 2012-07-10 15:20:34Z doligez $
+# $Id: Makefile 12707 2012-07-13 11:23:13Z doligez $
 
 include ../config/Makefile
 
 GENERATORS_CMOS= \
 	generators/odoc_todo.cmo \
 	generators/odoc_literate.cmo
-GENERATORS_CMXS=$(GENERATORS_CMOS:.cmo=.cmxs)
+GENERATORS_CMXS_TMP1=$(GENERATORS_CMOS:.cmo=.cmxs)
+GENERATORS_CMXS_TMP2=$(NATDYNLINK:false=)
+GENERATORS_CMXS=$(GENERATORS_CMXS_TMP2:true=$(GENERATORS_CMXS_TMP1))
 
 
 # Compilation

otherlibs/labltk/support/cltkFile.c

 /*                                                                     */
 /***********************************************************************/
 
-/* $Id: cltkFile.c 11156 2011-07-27 14:17:02Z doligez $ */
-
-#ifdef __CYGWIN__
-#define _WIN32
-#endif
+/* $Id: cltkFile.c 12716 2012-07-16 20:01:36Z doligez $ */
 
 #ifdef _WIN32
 #include <wtypes.h>

testsuite/tests/lib-threads/test1.checker

-sort test1.result | diff -q test1.reference -
+LC_ALL=C sort test1.result | diff -q test1.reference -

testsuite/tests/lib-threads/test4.checker

-sort -u test4.result | diff -q test4.reference -
+LC_ALL=C sort -u test4.result | diff -q test4.reference -

testsuite/tests/lib-threads/test5.checker

-sort -u test5.result | diff -q test5.reference -
+LC_ALL=C sort -u test5.result | diff -q test5.reference -

testsuite/tests/lib-threads/test6.checker

-sort -u test6.result | diff -q test6.reference -
+LC_ALL=C sort -u test6.result | diff -q test6.reference -

testsuite/tests/lib-threads/testA.checker

-sort testA.result | diff -q testA.reference -
+LC_ALL=C sort testA.result | diff -q testA.reference -

testsuite/tests/lib-threads/testexit.checker

-sort testexit.result | diff -q testexit.reference -
+LC_ALL=C sort testexit.result | diff -q testexit.reference -

testsuite/tests/typing-gadts/pr5689.ml

+type inkind = [ `Link | `Nonlink ]
+
+type _ inline_t =
+   | Text: string -> [< inkind > `Nonlink ] inline_t
+   | Bold: 'a inline_t list -> 'a inline_t
+   | Link: string -> [< inkind > `Link ] inline_t
+   | Mref: string * [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t
+;;
+
+let uppercase seq =
+   let rec process: type a. a inline_t -> a inline_t = function
+       | Text txt       -> Text (String.uppercase txt)
+       | Bold xs        -> Bold (List.map process xs)
+       | Link lnk       -> Link lnk
+       | Mref (lnk, xs) -> Mref (lnk, List.map process xs)
+   in List.map process seq
+;;
+
+type ast_t =
+   | Ast_Text of string
+   | Ast_Bold of ast_t list
+   | Ast_Link of string
+   | Ast_Mref of string * ast_t list
+;;
+
+let inlineseq_from_astseq seq =
+   let rec process_nonlink = function
+       | Ast_Text txt  -> Text txt
+       | Ast_Bold xs   -> Bold (List.map process_nonlink xs)
+       | _             -> assert false in
+   let rec process_any = function
+       | Ast_Text txt       -> Text txt
+       | Ast_Bold xs        -> Bold (List.map process_any xs)
+       | Ast_Link lnk       -> Link lnk
+       | Ast_Mref (lnk, xs) -> Mref (lnk, List.map process_nonlink xs)
+   in List.map process_any seq
+;;
+
+(* OK *)
+type _ linkp =
+ | Nonlink : [ `Nonlink ] linkp
+ | Maylink : inkind linkp
+;;
+let inlineseq_from_astseq seq =
+ let rec process : type a. a linkp -> ast_t -> a inline_t =
+   fun allow_link ast ->
+     match (allow_link, ast) with
+     | (Maylink, Ast_Text txt)    -> Text txt
+     | (Nonlink, Ast_Text txt)    -> Text txt
+     | (x, Ast_Bold xs)           -> Bold (List.map (process x) xs)
+     | (Maylink, Ast_Link lnk)    -> Link lnk
+     | (Nonlink, Ast_Link _)      -> assert false
+     | (Maylink, Ast_Mref (lnk, xs)) ->
+         Mref (lnk, List.map (process Nonlink) xs)
+     | (Nonlink, Ast_Mref _)      -> assert false
+   in List.map (process Maylink) seq
+;;
+
+(* Bad *)
+type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
+;;
+let inlineseq_from_astseq seq =
+let rec process : type a. a linkp2 -> ast_t -> a inline_t =
+  fun allow_link ast ->
+    match (allow_link, ast) with
+    | (Kind _, Ast_Text txt)    -> Text txt
+    | (x, Ast_Bold xs)           -> Bold (List.map (process x) xs)
+    | (Kind Maylink, Ast_Link lnk)    -> Link lnk
+    | (Kind Nonlink, Ast_Link _)      -> assert false
+    | (Kind Maylink, Ast_Mref (lnk, xs)) ->
+        Mref (lnk, List.map (process (Kind Nonlink)) xs)
+    | (Kind Nonlink, Ast_Mref _)      -> assert false
+  in List.map (process (Kind Maylink)) seq
+;;

testsuite/tests/typing-gadts/pr5689.ml.principal.reference

+
+#               type inkind = [ `Link | `Nonlink ]
+type _ inline_t =
+    Text : string -> [< inkind > `Nonlink ] inline_t
+  | Bold : 'a inline_t list -> 'a inline_t
+  | Link : string -> [< inkind > `Link ] inline_t
+  | Mref : string *
+      [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t
+#                 val uppercase : 'a inline_t list -> 'a inline_t list = <fun>
+#             type ast_t =
+    Ast_Text of string
+  | Ast_Bold of ast_t list
+  | Ast_Link of string
+  | Ast_Mref of string * ast_t list
+#                         val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun>
+#           type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp
+#                           val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun>
+#       type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
+#                         Characters 272-279:
+      | (Kind Maylink, Ast_Link lnk)    -> Link lnk
+              ^^^^^^^
+Error: This pattern matches values of type inkind linkp
+       but a pattern was expected which matches values of type
+         ([< inkind ] as 'a) linkp
+       Type inkind = [ `Link | `Nonlink ] is not compatible with type
+         'a = [< `Link | `Nonlink ] 
+       Types for tag `Nonlink are incompatible
+# 

testsuite/tests/typing-gadts/pr5689.ml.reference

+
+#               type inkind = [ `Link | `Nonlink ]
+type _ inline_t =
+    Text : string -> [< inkind > `Nonlink ] inline_t
+  | Bold : 'a inline_t list -> 'a inline_t
+  | Link : string -> [< inkind > `Link ] inline_t
+  | Mref : string *
+      [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t
+#                 val uppercase : 'a inline_t list -> 'a inline_t list = <fun>
+#             type ast_t =
+    Ast_Text of string
+  | Ast_Bold of ast_t list
+  | Ast_Link of string
+  | Ast_Mref of string * ast_t list
+#                         val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun>
+#           type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp
+#                           val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun>
+#       type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2
+#                         Characters 272-279:
+      | (Kind Maylink, Ast_Link lnk)    -> Link lnk
+              ^^^^^^^
+Error: This pattern matches values of type inkind linkp
+       but a pattern was expected which matches values of type
+         ([< inkind ] as 'a) linkp
+       Type inkind = [ `Link | `Nonlink ] is not compatible with type
+         'a = [< `Link | `Nonlink ] 
+       Types for tag `Nonlink are incompatible
+# 

testsuite/tests/typing-sigsubst/sigsubst.ml

 module type PrintableComparable = sig
   include Printable
   include Comparable with type t = t
-end;;
+end;; (* Fails *)
 module type PrintableComparable = sig
   type t
   include Printable with type t := t
   sig module T : sig type exp type arg end val f : T.exp -> T.arg end;;
 module M = struct type exp = string type arg = int end;;
 module type S' = S with module T := M;;
+
+
+module type S = sig type 'a t end with type 'a t := unit;; (* Fails *)

testsuite/tests/typing-sigsubst/sigsubst.ml.reference

   sig module T : sig type exp type arg end val f : T.exp -> T.arg end
 # module M : sig type exp = string type arg = int end
 # module type S' = sig val f : M.exp -> M.arg end
+#     Characters 41-58:
+  module type S = sig type 'a t end with type 'a t := unit;; (* Fails *)
+                                         ^^^^^^^^^^^^^^^^^
+Error: Only type constructors with identical parameters can be substituted.
 # 

testsuite/typeloc/array.ml

+let _ = [ [||]; [] ] (* ok *)
+

testsuite/typeloc/array_pat.ml

+let _ = function
+  | [||] -> 1  (* ok *)
+  | [] -> 2
+
+

testsuite/typeloc/const_constant.ml

+let _ = [ [];  (* constructor use: ok *)
+          1    (* constant use: ok *)
+        ]

testsuite/typeloc/const_constant_pat.ml

+let _ = function
+  | [] -> 1  (* construct in pattern: ok *)
+  | 1 -> 2   (* const in pattern: ok *) 

testsuite/typeloc/constraint.ml

+let _ = (1 : float) (* ok *)
+ 

testsuite/typeloc/constraint_pat.ml

+let f = function (1 : float) -> 2 (* ok *)
+ 

testsuite/typeloc/exn.ml

+let _ = [Exit; 1]

testsuite/typeloc/exn_pat.ml

+let _ = function
+  | Exit -> 1
+  | 2 -> 2

testsuite/typeloc/for.ml

+let _ = for i = true to 10 do () done (* ok *)
+
+

testsuite/typeloc/for2.ml

+let _ = for i = 0 to true do () done (* ok *)
+
+

testsuite/typeloc/fun.ml

+let _ = [(fun x -> x); 1]

testsuite/typeloc/fun_app.ml

+let f = 1
+let _ = f 2 
+(* NG? : 
+File "fun_app.ml", line 2, characters 8-9:
+Error: This expression is not a function; it cannot be applied
+*)
+

testsuite/typeloc/ifthen.ml

+let _ = if true then 1 (* NG. Detected but the location is wrong *)
+ 

testsuite/typeloc/ifthenelse.ml

+let f = if 1 then 1 else 2 (* ok *)
+

testsuite/typeloc/lazy.ml

+let _ = [lazy 1; 2] (* ok *)
+

testsuite/typeloc/lazy_pat.ml

+let _ = function
+  | lazy 1 -> 1 (* ok *)
+  | 2 -> 2

testsuite/typeloc/obj_meth_call.ml

+let f x = 
+  x#m;  (* ok *)
+  [x; 1]
+

testsuite/typeloc/obj_new.ml

+class t = object end
+let _ = [ new t;  (* ok *)
+          None ]

testsuite/typeloc/obj_new2.ml

+class t = object end
+type 'a u = X of 'a * 'a
+let _ = X (new t, (* ok *)
+           1)  

testsuite/typeloc/pvar.ml

+let _ = `A + 1  (* this is tricky! ok ? *)
+

testsuite/typeloc/pvar2.ml

+let x = `A
+
+let y = [x; `B] (* ok *)
+
+let z = [y; 1]
+

testsuite/typeloc/pvar_constraint.ml

+let x = `A
+
+let y = [x; `B] (* ok *)
+
+let f : [`B] -> [`B] = fun x -> x (* ok *)
+
+let _ = f y
+

testsuite/typeloc/pvar_pat.ml

+let _ = function
+  | `A -> ()  (* ok? *)
+  | 1 -> ()

testsuite/typeloc/rec_field.ml

+type t = { x : int }
+
+let f x = (x.x,  (* ok *)
+           x + 1)
+

testsuite/typeloc/rec_field_pat.ml

+type t = { x : int }
+
+let f = function
+  | { x = x } -> x  (* ok *)
+  | 1 -> 1
+

testsuite/typeloc/record.ml

+type t = { x : int; y : int }
+
+let _ = [ { x = 1; y = 2 };  (* ok *)
+          [] ]

testsuite/typeloc/record_pat.ml

+type t = { x : int; y : int }
+
+let _ = function
+  | { x = 1; y = 2 } -> 1  (* ok *)
+  | [] -> 2

testsuite/typeloc/seq.ml

+let _ = 1; () (* ok , with -strict-sequence *)
+

testsuite/typeloc/try.ml

+let _ = try 1 with 1 -> 1 (* ok, but loc is not sure ? *)
+

testsuite/typeloc/tuple.ml

+let _ = [ (1,2);  (* tuple ok *)
+          [] ]

testsuite/typeloc/tuple_pat.ml

+let x = function
+  | (1,2) -> 3 (* ok *)
+  | [] -> 4
+ 

testsuite/typeloc/var.ml

+type t = Foo 
+
+let _ = [Foo;  (* ok *)
+         1]
+ 

testsuite/typeloc/var_pat.ml

+type t = Foo
+
+let _ = function 
+  | Foo -> 1    (* ok *)
+  | [] -> 2

testsuite/typeloc/when.ml

+let _ = function _ when 1 -> 1 (* ok? but the location is cryptic *)
+

testsuite/typeloc/while.ml

+let _ = while 1 do () done (* ok? the bool introduction location is crypting *)
+

tools/ocamlmklib.mlp

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ocamlmklib.mlp 12149 2012-02-10 16:15:24Z doligez $ *)
+(* $Id: ocamlmklib.mlp 12723 2012-07-17 18:25:54Z doligez $ *)
 
 open Printf
 open Myocamlbuild_config
 and dynlink = ref supports_shared_libraries
 and failsafe = ref false    (* whether to fall back on static build only *)
 and c_libs = ref []         (* libs to pass to mksharedlib and ocamlc -cclib *)
+and c_Lopts = ref []      (* options to pass to mksharedlib and ocamlc -cclib *)
 and c_opts = ref []      (* options to pass to mksharedlib and ocamlc -ccopt *)
 and ld_opts = ref []        (* options to pass only to the linker *)
 and ocamlc = ref (compiler_path "ocamlc")
     else if starts_with s "-l" then
       c_libs := s :: !c_libs
     else if starts_with s "-L" then
-     (c_opts := s :: !c_opts;
+     (c_Lopts := s :: !c_Lopts;
       let l = chop_prefix s "-L" in
       if not (Filename.is_relative l) then rpath := l :: !rpath)
     else if s = "-ocamlc" then
     (fun r -> r := List.rev !r)
     [ bytecode_objs; native_objs; caml_libs; caml_opts;
       c_libs; c_objs; c_opts; ld_opts; rpath ];
+(* Put -L options in front of -l options in -cclib to mimic -ccopt behavior *)
+  c_libs := !c_Lopts @ !c_libs;
 
   if !output_c = "" then output_c := !output
 
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: btype.ml 12534 2012-06-01 05:24:38Z garrigue $ *)
+(* $Id: btype.ml 12726 2012-07-18 03:34:36Z garrigue $ *)
 
 (* Basic operations on core types *)
 
   | {desc=Tvariant row'} -> row_more row'
   | ty -> ty
 
+let row_fixed row =
+  let row = row_repr row in
+  row.row_fixed ||
+  match (repr row.row_more).desc with
+    Tvar _ | Tnil -> false
+  | Tunivar _ | Tconstr _ -> true
+  | _ -> assert false
+
 let static_row row =
   let row = row_repr row in
   row.row_closed &&
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: btype.mli 12534 2012-06-01 05:24:38Z garrigue $ *)
+(* $Id: btype.mli 12726 2012-07-18 03:34:36Z garrigue $ *)
 
 (* Basic operations on core types *)
 
         (* Return the canonical representative of a row field *)
 val row_more: row_desc -> type_expr
         (* Return the extension variable of the row *)
+val row_fixed: row_desc -> bool
+        (* Return whether the row should be treated as fixed or not *)
 val static_row: row_desc -> bool
         (* Return whether the row is static or not *)
 val hash_variant: label -> int

typing/cmt_format.ml

   cmt_initial_env : Env.t;
   cmt_imports : (string * Digest.t) list;
   cmt_interface_digest : Digest.t option;
+  cmt_use_summaries : bool;
 }
 
 type error =
 let set_saved_types l = saved_types := l
 
 let save_cmt filename modname binary_annots sourcefile initial_env sg =
-  if !Clflags.binary_annotations && not !Clflags.print_types then begin
+  if !Clflags.binary_annotations
+    && not !Clflags.print_types
+    && not !Clflags.dont_write_files
+  then begin
     let imports = Env.imported_units () in
     let oc = open_out_bin filename in
     let this_crc =
           keep_only_summary initial_env else initial_env;
       cmt_imports = List.sort compare imports;
       cmt_interface_digest = this_crc;
+      cmt_use_summaries = need_to_clear_env;
     } in
     clear_env_hcons ();
     output_cmt oc cmt;

typing/cmt_format.mli

   cmt_initial_env : Env.t;
   cmt_imports : (string * Digest.t) list;
   cmt_interface_digest : Digest.t option;
+  cmt_use_summaries : bool;
 }
 
 type error =
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: ctype.ml 12604 2012-06-13 22:07:18Z garrigue $ *)
+(* $Id: ctype.ml 12726 2012-07-18 03:34:36Z garrigue $ *)
 
 (* Operations on core types *)
 
 open Types
 open Btype
 
+let typeloc_debug = try ignore (Sys.getenv "OCAML_TYPELOC_DEBUG"); true with _ -> false
+
 (*
    Type manipulation after type inference
    ======================================
       with Not_found -> false
 
 let rec unify (env:Env.t ref) t1 t2 =
+  if typeloc_debug then
+    Format.eprintf "unify @[<v>%a@ %a@]@."
+      !Btype.print_raw t1
+      !Btype.print_raw t2;
+
   (* First step: special cases (optimizations) *)
   if unify_eq !env t1 t2 then () else
   let t1 = repr t1 in
 and unify3 env t1 t1' t2 t2' =
   (* Third step: truly unification *)
   (* Assumes either [t1 == t1'] or [t2 != t2'] *)
+  if typeloc_debug then
+    Format.eprintf "unify3 @[<v>%a@ %a@]@."
+      !Btype.print_raw t1
+      !Btype.print_raw t2;
+
   let d1 = t1'.desc and d2 = t2'.desc in
   let create_recursion = (t2 != t2') && (deep_occur t1' t2) in
 
   | (Tfield _, Tfield _) -> (* special case for GADTs *)
       unify_fields env t1' t2'
   | _ ->
-    let loc1 = t1'.tyloc and loc2 = t2'.tyloc in
+    (* typeloc: t1' and t2 are linked even if the unification might fail! *)  
+    let loc1 = t1'.tyloc and loc2 = t2.tyloc in
     begin match !umode with
     | Expression ->
         occur !env t1' t2';
             () (* t2 has already been expanded by update_level *)
     with Unify trace ->
       t1'.tyloc <- loc1;
-      t2'.tyloc <- loc2;
+      t2.tyloc <- loc2;
       t1'.desc <- d1;
       raise (Unify trace)
   end
         with Not_found -> ())
       r2
   end;
+  let fixed1 = row_fixed row1 and fixed2 = row_fixed row2 in
   let more =
-    if row1.row_fixed then rm1 else
-    if row2.row_fixed then rm2 else
+    if fixed1 then rm1 else
+    if fixed2 then rm2 else
     newty2 (min rm1.level rm2.level) (Tvar None) in
-  let fixed = row1.row_fixed || row2.row_fixed
+  let fixed = fixed1 || fixed2
   and closed = row1.row_closed || row2.row_closed in
   let keep switch =
     List.for_all
       if closed then
         filter_row_fields row.row_closed rest
       else rest in
-    if rest <> [] && (row.row_closed || row.row_fixed)
-    || closed && row.row_fixed && not row.row_closed then begin
+    if rest <> [] && (row.row_closed || row_fixed row)
+    || closed && row_fixed row && not row.row_closed then begin
       let t1 = mkvariant [] true and t2 = mkvariant rest false in
       raise (Unify [if row == row1 then (t1,t2) else (t2,t1)])
     end;
     if !trace_gadt_instances && rm.desc = Tnil then () else
     if !trace_gadt_instances then
       update_level !env rm.level (newgenty (Tvariant row));
-    if row.row_fixed then
+    if row_fixed row then
       if more == rm then () else
       if is_Tvar rm then link_type rm more else unify env rm more
     else
     set_more row1 r2;
     List.iter
       (fun (l,f1,f2) ->
-        try unify_row_field env row1.row_fixed row2.row_fixed more l f1 f2
+        try unify_row_field env fixed1 fixed2 more l f1 f2
         with Unify trace ->
           raise (Unify ((mkvariant [l,f1] true,
                          mkvariant [l,f2] true) :: trace)))
   | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) ->
       if e1 == e2 then () else
       let redo =
-        (m1 || m2 ||
+        (m1 || m2 || fixed1 || fixed2 ||
          !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) &&
         begin match tl1 @ tl2 with [] -> false
         | t1 :: tl ->
       let f1' = Reither(c1 || c2, tl1', m1 || m2, e)
       and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in
       set_row_field e1 f1'; set_row_field e2 f2';
-  | Reither(_, _, false, e1), Rabsent -> set_row_field e1 f2
-  | Rabsent, Reither(_, _, false, e2) -> set_row_field e2 f1
+  | Reither(_, _, false, e1), Rabsent when not fixed1 -> set_row_field e1 f2
+  | Rabsent, Reither(_, _, false, e2) when not fixed2 -> set_row_field e2 f1
   | Rabsent, Rabsent -> ()
   | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 ->
       set_row_field e1 f2;
     | Tvariant row ->
         let row = row_repr row in
         let more = repr row.row_more in
-        if is_Tvar more && not row.row_fixed then begin
+        if is_Tvar more && not (row_fixed row) then begin
           let more' = newty2 more.level more.desc in
           let row' = {row with row_fixed=true; row_fields=[]; row_more=more'}
           in link_type more (newty2 ty.level (Tvariant row'))

typing/ctype.mli

File contents unchanged.
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: env.ml 12697 2012-07-11 09:13:03Z lefessan $ *)
+(* $Id: env.ml 12706 2012-07-13 08:49:06Z lefessan $ *)
 
 (* Environment handling *)
 
     in_signature = env.in_signature;
 }
 
+let env_of_only_summary env_from_summary env =
+  let new_env = env_from_summary env.summary Subst.identity in
+  { new_env with
+    local_constraints = env.local_constraints;
+    in_signature = env.in_signature;
+  }
+
 (* Error report *)
 
 open Format
 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: env.mli 12697 2012-07-11 09:13:03Z lefessan $ *)
+(* $Id: env.mli 12706 2012-07-13 08:49:06Z lefessan $ *)
 
 (* Environment handling *)
 
    exported in debugging information. *)
 
 val summary: t -> summary
+
+(* Return an equivalent environment where all fields have been reset,
+   except the summary. The initial environment can be rebuilt from the
+   summary, using Envaux.env_of_only_summary. *)
+
 val keep_only_summary : t -> t
+val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t
 
 
 (* Error report *)

typing/parmatch.ml

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: parmatch.ml 12520 2012-05-31 07:41:37Z garrigue $ *)
+(* $Id: parmatch.ml 12726 2012-07-18 03:34:36Z garrigue $ *)
 
 (* Detection of partial matches and unused match cases. *)
 
         env
     in
     let row = row_of_pat p in
-    if closing && not row.row_fixed then
+    if closing && not (Btype.row_fixed row) then
       (* closing=true, we are considering the variant as closed *)
       List.for_all
         (fun (tag,f) ->
             begin match constrs, tdefs with
               ({pat_desc=Tpat_variant _} as p,_):: _, Some env ->
                 let row = row_of_pat p in
-                if row.row_fixed
+                if Btype.row_fixed row
                 || pressure_variants None (filter_extra pss) then ()
                 else close_variant env row
             | _ -> ()

typing/printtyp.ml

   (if t == t' then type_expr ppf t else
    let t' = if proxy t == proxy t' then unalias t' else t' in
    fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t');
+(*
   match t.tyloc with
   | Some loc -> fprintf ppf " introduced at %a" Location.print loc
   | _ -> ()
+*)
+  ()
+
+let differing_types ppf (t, t') =
+  let typ ppf t = match t.tyloc with
+    | Some loc -> 
+        fprintf ppf "@[<v2>  %a : introduced at %a@]" 
+          type_expr t
+          Location.print_loc loc
+    | None -> 
+        fprintf ppf "@[<2>  %a : introduced at unknown place@]" 
+          type_expr t
+  in
+  fprintf ppf "@[<v>The differing types are:@ %a@ %a@]"
+    typ t
+    typ t'
 
 let rec trace fst txt ppf = function
   | (t1, t1') :: (t2, t2') :: rem ->
           @[%t@;<1 2>%a@ \
             %t@;<1 2>%a\
           @]%a%t\
-         @]"
+         @]\
+         @;%a"
         txt1 (type_expansion t1) t1'
         txt2 (type_expansion t2) t2'
         (trace false "is not compatible with type") tr
-        (explanation unif mis);
+        (explanation unif mis)
+        differing_types (t1, t2);
       print_labels := true
     with exn ->
       print_labels := true;

typing/subst.ml

File contents unchanged.

typing/typecore.ml

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typecore.ml 12681 2012-07-10 08:33:16Z garrigue $ *)
+(* $Id: typecore.ml 12726 2012-07-18 03:34:36Z garrigue $ *)
 
 (* Typechecking for the core language *)
 
 open Btype
 open Ctype
 
+let typeloc_debug = try ignore (Sys.getenv "OCAML_TYPELOC_DEBUG"); true with _ -> false
+
 type error =
     Polymorphic_label of Longident.t
   | Constructor_arity_mismatch of Longident.t * int * int
           begin match opat with None -> assert false
           | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl)
           end
-      | Reither (c, l, true, e) when not row.row_fixed ->
+      | Reither (c, l, true, e) when not (row_fixed row) ->
           set_row_field e (Reither (c, [], false, ref None))
       | _ -> ()
       end;
   unify_vars p1_vs p2_vs
 
 let rec build_as_type env p =
+  let loc = p.pat_loc in
   match p.pat_desc with
     Tpat_alias(p1,_, _) -> build_as_type env p1
   | Tpat_tuple pl ->
       let tyl = List.map (build_as_type env) pl in
-      newty (Ttuple tyl)
+      copy_with_loc loc (newty (Ttuple tyl))
   | Tpat_construct(_, _, cstr, pl,_) ->
+      (* CR jfuruse: typeloc todo *)
       let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in
       if keep then p.pat_type else
       let tyl = List.map (build_as_type env) pl in
         (List.combine pl tyl) ty_args;
       ty_res
   | Tpat_variant(l, p', _) ->
+      (* CR jfuruse: typeloc todo *)
       let ty = may_map (build_as_type env) p' in
       newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
                       row_bound=(); row_name=None;
                       row_fixed=false; row_closed=false})
   | Tpat_record (lpl,_) ->
+      (* CR jfuruse: typeloc todo *)
       let lbl = thd4 (List.hd lpl) in
       if lbl.lbl_private = Private then p.pat_type else
       let ty = newvar () in
         pat_type = expected_ty;
         pat_env = !env }
   | Ppat_unpack name ->
+      (* CR jfuruse: typeloc todo *)
       let id = enter_variable loc name expected_ty ~is_module:true in
       rp {
         pat_desc = Tpat_var (id, name);
   | Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=lloc},
                     ({ptyp_desc=Ptyp_poly _} as sty)) ->
       (* explicitly polymorphic type *)
-      let cty, force = Typetexp.transl_simple_type_delayed !env sty in
+      let cty, force = Typetexp.transl_simple_type_delayed !env sty in (* typeloc done *)
       let ty = cty.ctyp_type in
       unify_pat_types lloc !env ty expected_ty;
       pattern_force := force :: !pattern_force;
       let (ty_args, ty_res) =
         instance_constructor ~in_pattern:(env, get_newtype_level ()) constr
       in
-      (* let ty_res = copy_with_loc loc ty_res in ??? *)
+      (* CR jfuruse: typeloc todo for args. Probably unsafe (but why?) *)
+      let ty_res = copy_with_loc loc ty_res in (* CR jfuruse: world ok, but not checked yet *)
       if constr.cstr_generalized && mode = Normal then
         unify_pat_types_gadt loc env ty_res expected_ty
       else
         pat_type = expected_ty;
         pat_env = !env }
   | Ppat_variant(l, sarg) ->
+      (* CR jfuruse: typeloc todo for sarg *)
       let arg = may_map (fun p -> type_pat p (newvar())) sarg in
       let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type]  in
       let row = { row_fields =
                   row_more = newvar ();
                   row_fixed = false;
                   row_name = None } in
-      unify_pat_types loc !env (newty (Tvariant row)) expected_ty;
+      unify_pat_types loc !env (copy_with_loc loc (newty (Tvariant row))) expected_ty;
       rp {
         pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()});
         pat_loc = loc; pat_extra=[];
         pat_type =  expected_ty;
         pat_env = !env }
   | Ppat_record(lid_sp_list, closed) ->
+      (* CR jfuruse: typeloc todo check *)
       let type_label_pat (label_path, label_lid, label, sarg) =
         begin_def ();
         let (vars, ty_arg, ty_res) = instance_label false label in
+        let ty_res = copy_with_loc loc ty_res in
         if vars = [] then end_def ();
-(* fails ocamldoc? (not sure yet)
         let ty_arg = copy_with_loc loc ty_arg in
-*)
         begin try
           unify_pat_types loc !env ty_res expected_ty
         with Unify trace ->
       (* Separate when not already separated by !principal *)
       let separate = true in
       if separate then begin_def();
-      let cty, force = Typetexp.transl_simple_type_delayed !env sty in
+      let cty, force = Typetexp.transl_simple_type_delayed !env sty in (* tyloc is done here *)
+
       let ty = cty.ctyp_type in
       let ty, expected_ty' =
         if separate then begin
           instance !env ty, instance !env ty
         end else ty, ty
       in
-      (* let ty = copy_with_loc loc ty in *) (* CR jfuruse: fails at Camlp4.ml *)
       unify_pat_types loc !env ty expected_ty;
       let p = type_pat sp expected_ty' in
       (*Format.printf "%a@.%a@."
                 pat_extra = (Tpat_constraint cty,loc) :: p.pat_extra}
       else p
   | Ppat_type lid ->
+      (* CR jfuruse: typeloc todo check *)
       let (path, p,ty) = build_or_pat !env loc lid.txt in
       let ty = copy_with_loc loc ty in
       unify_pat_types loc !env ty expected_ty;
 let unify_exp env exp expected_ty =
   (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
     Printtyp.raw_type_expr expected_ty; *)
-    unify_exp_types exp.exp_loc env exp.exp_type expected_ty
+  unify_exp_types exp.exp_loc env exp.exp_type expected_ty
 
 let rec type_exp env sexp =
   (* We now delegate everything to type_expect *)
   let loc = sexp.pexp_loc in
   (* Record the expression type before unifying it with the expected type *)
   let rue exp =
+if typeloc_debug then Format.eprintf "@[<v>RUE: expected: %a@ RUE: exp: %a@]@." Printtyp.raw_type_expr ty_expected Printtyp.raw_type_expr exp.exp_type;
+ 
     Cmt_format.add_saved_type (Cmt_format.Partial_expression exp);
     Stypes.record (Stypes.Ti_expr exp);
     unify_exp env exp (instance env ty_expected);
+
+if typeloc_debug then Format.eprintf "@[<v>RUE: unif exp: %a@]@." Printtyp.raw_type_expr exp.exp_type;
+
     exp
   in
   match sexp.pexp_desc with
   | Pexp_ident lid ->
+      (* CR jfuruse: typeloc todo *)
       begin
         if !Clflags.annotations then begin
           try let (path, annot) = Env.lookup_annot lid.txt env in
       end_def ();
       lower_args [] ty;
       begin_def ();
-      let (args, ty_res) = type_application env funct sargs in
+      let (args, ty_res) = type_application env funct sargs in (* typeloc is done here *)
       end_def ();
       unify_var env (newvar()) funct.exp_type;
       rue {
         exp_type = body.exp_type;
         exp_env = env }
   | Pexp_tuple sexpl ->
+      (* typeloc: type_expected and the exp_type are different types, for some unknown reason.
+         So we need set loc twice. *)
       let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
       let to_unify = copy_with_loc loc (newgenty (Ttuple subtypes)) in
       unify_exp_types loc env to_unify ty_expected;
         exp_loc = loc; exp_extra = [];
         (* Keep sharing *)
         exp_type = copy_with_loc loc (newty (Ttuple (List.map (fun e -> e.exp_type) expl)));
-        (* CR jfuruse: why exp_type is not equal to ty_expected? *)
         exp_env = env }
   | Pexp_construct(lid, sarg, explicit_arity) ->
       type_construct env loc lid sarg explicit_arity ty_expected
   | Pexp_variant(l, sarg) ->
+      (* CR jfuruse: tyloc todo for sarg *)
       (* Keep sharing *)
       let ty_expected0 = instance env ty_expected in
       begin try match
           begin match row_field_repr (List.assoc l row.row_fields),
           row_field_repr (List.assoc l row0.row_fields) with
             Rpresent (Some ty), Rpresent (Some ty0) ->
+              (* tyloc: l is already in the type, so no need of introduce tyloc *)
               let arg = type_argument env sarg ty ty0 in
               re { exp_desc = Texp_variant(l, Some arg);
                    exp_loc = loc; exp_extra = [];
         rue {
           exp_desc = Texp_variant(l, arg);
           exp_loc = loc; exp_extra = [];
-          exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
+          exp_type= copy_with_loc loc 
+                    (newty (Tvariant{row_fields = [l, Rpresent arg_type];
                                     row_more = newvar ();
                                     row_bound = ();
                                     row_closed = false;
                                     row_fixed = false;
-                                    row_name = None});
+                                    row_name = None}));
           exp_env = env }
       end
   | Pexp_record(lid_sexp_list, opt_sexp) ->
+      (* CR jfuruse: typeloc todo *)
       let lbl_exp_list =
         type_label_a_list env (type_label_exp true env loc ty_expected)
           lid_sexp_list in
         exp_type = set_loc loc (instance env ty_expected); (* set_loc enforces loc unification *)
         exp_env = env }
   | Pexp_field(sarg, lid) ->
+      (* CR jfuruse: typeloc todo *)
       let arg = type_exp env sarg in
       let (label_path,label) = Typetexp.find_label env loc lid.txt in
       let (_, ty_arg, ty_res) = instance_label false label in
+      let ty_res = copy_with_loc lid.Location.loc ty_res in
 (* WRONG
       let ty_arg = copy_with_loc loc ty_arg 
-      and ty_res = copy_with_loc loc ty_res
       in
 *)
       unify_exp env arg ty_res;
         exp_type = ty_arg;
         exp_env = env }
   | Pexp_setfield(srecord, lid, snewval) ->
+      (* CR jfuruse: typeloc todo *)
       let record = type_exp env srecord in
       let (label_path, label) = Typetexp.find_label env loc lid.txt in
       let (label_path, label_loc, label, newval) =
             (arg, arg.exp_type,None,None)
         | (Some sty, None) ->
             if separate then begin_def ();
-            let cty = Typetexp.transl_simple_type env false sty in
+            let cty = Typetexp.transl_simple_type env false sty in (* tyloc is done here *)
             let ty = cty.ctyp_type in
             if separate then begin
               end_def ();
               (type_argument env sarg ty ty, ty, Some cty, None)
         | (None, Some sty') ->
             let (cty', force) =
-              Typetexp.transl_simple_type_delayed env sty'
+              Typetexp.transl_simple_type_delayed env sty' (* tyloc is done here *)
             in
             let ty' = cty'.ctyp_type in
             if separate then begin_def ();
         | (Some sty, Some sty') ->
             if separate then begin_def ();
             let (cty, force) =
-              Typetexp.transl_simple_type_delayed env sty
+              Typetexp.transl_simple_type_delayed env sty (* tyloc is done here *)
             and (cty', force') =
-              Typetexp.transl_simple_type_delayed env sty'
+              Typetexp.transl_simple_type_delayed env sty'(* tyloc is done here *)
             in
             let ty = cty.ctyp_type in
             let ty' = cty'.ctyp_type in
       rue {
         exp_desc = arg.exp_desc;
         exp_loc = arg.exp_loc;
-        exp_type = (* copy_with_loc arg.exp_loc WRONG? *) ty';
+        exp_type = ty';
         exp_env = env;
         exp_extra = (Texp_constraint (cty, cty'), loc) :: arg.exp_extra;
       }
   | Pexp_when(scond, sbody) ->
-      let cond = type_expect env scond (copy_with_loc scond.pexp_loc Predef.type_bool) in
+      let cond = type_expect env scond (copy_with_loc loc Predef.type_bool) in (* CR jfuruse: bad location *)
       let body = type_expect env sbody ty_expected in
       re {
         exp_desc = Texp_when(cond, body);
   | Pexp_send (e, met) ->
       if !Clflags.principal then begin_def ();
       let obj = type_exp env e in
+      (* tyloc: obj is required to have an object type *)
+      ignore (set_loc loc obj.exp_type);
       begin try
         let (meth, exp, typ) =
           match obj.exp_desc with
         raise(Error(e.pexp_loc, Undefined_method (obj.exp_type, met)))
       end
   | Pexp_new cl ->
+      (* CR jfuruse: typeloc *)
       let (cl_path, cl_decl) = Typetexp.find_class env loc cl.txt in
         begin match cl_decl.cty_new with
           None ->
             rue {
               exp_desc = Texp_new (cl_path, cl, cl_decl);
               exp_loc = loc; exp_extra = [];
-              exp_type = instance_def ty;
+              exp_type = copy_with_loc loc (instance_def ty);
               exp_env = env }
         end
   | Pexp_setinstvar (lab, snewval) ->
+      (* CR jfuruse: typeloc *)
       begin try
         let (path, desc) = Env.lookup_value (Longident.Lident lab.txt) env in
         match desc.val_kind with
           raise(Error(loc, Unbound_instance_variable lab.txt))
       end
   | Pexp_override lst ->
+      (* CR jfuruse: typeloc? *)
       let _ =
        List.fold_right
         (fun (lab, _) l ->
       re {
         exp_desc = Texp_assertfalse;
         exp_loc = loc; exp_extra = [];
-        exp_type = copy_with_loc loc (instance env ty_expected);
+        exp_type = instance env ty_expected;
         exp_env = env;
       }
   | Pexp_lazy e ->
         exp_env = env;
       }
   | Pexp_poly(sbody, sty) ->
+      (* CR jfuruse: typeloc todo *)
       if !Clflags.principal then begin_def ();
       let ty, cty =
         match sty with None -> repr ty_expected, None
       rue { body with exp_loc = loc; exp_type = ety;
             exp_extra = (Texp_newtype name, loc) :: body.exp_extra }
   | Pexp_pack m ->
+      (* CR jfuruse: typeloc todo *)
       let (p, nl, tl) =
         match Ctype.expand_head env (instance env ty_expected) with
           {desc = Tpackage (p, nl, tl)} ->
   let separate = !Clflags.principal || Env.has_local_constraints env in
   if separate then (begin_def (); begin_def ());
   let (ty_args, ty_res) = instance_constructor constr in
-(* WRONG
-  let ty_args = List.map (copy_with_loc loc) ty_args in 
-  let ty_res = copy_with_loc loc ty_res in
-*)
+  (* CR jfuruse: todo how about the args? the following is not correct. *)
+  (* let ty_args = List.map (copy_with_loc loc) ty_args in *)
+  let ty_res = copy_with_loc loc ty_res in (* tyloc. this should be safe *)
   let texp =
     re {
       exp_desc = Texp_construct(path, lid, constr, [],explicit_arity);

typing/typemod.ml

 (*                                                                     *)
 (***********************************************************************)
 
-(* $Id: typemod.ml 12542 2012-06-01 14:06:31Z frisch $ *)
+(* $Id: typemod.ml 12755 2012-07-21 01:19:45Z garrigue $ *)
 
 open Misc
 open Longident
           match !real_id with None -> assert false | Some id -> id in
         let lid =
           try match sdecl.ptype_manifest with
-          | Some {ptyp_desc = Ptyp_constr (lid, stl)} ->
+          | Some {ptyp_desc = Ptyp_constr (lid, stl)}
+            when List.length stl = List.length sdecl.ptype_params ->
               let params =
                 List.map
                   (function {ptyp_desc=Ptyp_var s} -> s | _ -> raise Exit)

typing/typetexp.ml

 	    in
 	    { field_desc = desc; field_loc = pf.pfield_loc })
 	  fields in
-      let ty = newobj (transl_fields env policy [] fields) in (* CR jfuruse: typloc todo *)
+      let ty = copy_with_loc loc (newobj (transl_fields env policy [] fields)) in
 	ctyp (Ttyp_object fields) ty env loc
   | Ptyp_class(lid, stl, present) ->
       let (path, decl, is_variant) =
              raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace))))
         (List.combine stl args) params;
 	let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in
-      let ty = (* CR jfuruse: typloc todo *)
+      let ty =
         try Ctype.expand_head env (newconstr path ty_args)
         with Unify trace ->
           raise (Error(styp.ptyp_loc, Type_mismatch trace))
             else if policy <> Univars then row
             else { row with row_more = new_pre_univar () }
           in
-          newty (Tvariant row)
+          copy_with_loc loc (newty (Tvariant row))
       | Tobject (fi, _) ->
           let _, tv = flatten_fields fi in
           if policy = Univars then pre_univars := tv :: !pre_univars;
-          ty
+          ty  (* CR jfuruse: typloc todo *)
       | _ ->
           assert false
       in
         else if policy <> Univars then row
         else { row with row_more = new_pre_univar () }
       in
-      let ty = newty (Tvariant row) in (* CR jfuruse: tyloc todo *)
+      let ty = copy_with_loc loc (newty (Tvariant row)) in
       ctyp (Ttyp_variant (tfields, closed, present)) ty env loc
    | Ptyp_poly(vars, st) ->
       begin_def();
             end else tyl)
           [] new_univars
       in
-       (* CR jfuruse: tyloc todo *)
-      let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in
+      (* CR jfuruse: tyloc not sure *)
+      let ty' = copy_with_loc loc (Btype.newgenty (Tpoly(ty, List.rev ty_list))) in
       unify_var env (newvar()) ty';
       ctyp (Ttyp_poly (vars, cty)) ty' env loc
   | Ptyp_package (p, l) ->