Commits

camlspotter committed 7d9004b Merge

merged with ocaml-4.00.0-rc1-12755

Comments (0)

Files changed (40)

       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)
     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.

Binary file modified.

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

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 *)
 
         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'))
 (*                                                                     *)
 (***********************************************************************)
 
-(* $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/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 *)
 
           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;

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)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.