last commit in this branchnew-test-framework

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/new-test-framework@16464 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

14 files changed, 66 insertions, 62 deletions

diff --git a/Changes b/Changes
index d81ea6b165..a93fe65530 100644
--- a/Changes
+++ b/Changes
@@ -156,6 +156,7 @@ Bug fixes:
 - PR#6768: Typechecker overflow the stack on cyclic type
 - PR#6775: Digest.file leaks file descriptor on error
   (Valentin Gatien-Baron)
+- PR#6787: Soundness bug with polymorphic variants
 - GPR#143: fix getsockopt behaviour for boolean socket options
   (Anil Madhavapeddy and Andrew Ray)
 - ocamlbuild on cygwin cannot find ocamlfind
diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml
index c611ec7d61..0e01f9ba3f 100644
--- a/asmcomp/asmgen.ml
+++ b/asmcomp/asmgen.ml
@@ -142,7 +142,7 @@ let gen_implementation ?toplevel ppf (size, lam) =
 
 let compile_implementation ?toplevel prefixname ppf (size, lam) =
   let asmfile =
-    if !keep_asm_file
+    if !keep_asm_file || !Emitaux.binary_backend_available
     then prefixname ^ ext_asm
     else Filename.temp_file "camlasm" ext_asm
   in
diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml
index c4d80ecff2..79f657ef05 100644
--- a/asmcomp/asmlink.ml
+++ b/asmcomp/asmlink.ml
@@ -261,7 +261,7 @@ let link_shared ppf objfiles output_name =
     (List.rev !Clflags.ccobjs) in
 
   let startup =
-    if !Clflags.keep_startup_file
+    if !Clflags.keep_startup_file || !Emitaux.binary_backend_available
     then output_name ^ ".startup" ^ ext_asm
     else Filename.temp_file "camlstartup" ext_asm in
   let startup_obj = output_name ^ ".startup" ^ ext_obj in
@@ -318,7 +318,8 @@ let link ppf objfiles output_name =
   Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts;
                                                (* put user's opts first *)
   let startup =
-    if !Clflags.keep_startup_file then output_name ^ ".startup" ^ ext_asm
+    if !Clflags.keep_startup_file || !Emitaux.binary_backend_available
+    then output_name ^ ".startup" ^ ext_asm
     else Filename.temp_file "camlstartup" ext_asm in
   let startup_obj = Filename.temp_file "camlstartup" ext_obj in
   Asmgen.compile_unit
diff --git a/testsuite/num-tests b/testsuite/num-tests
index c75acbe2ff..065fd3e79c 100644
--- a/testsuite/num-tests
+++ b/testsuite/num-tests
@@ -1 +1 @@
-127
+137
diff --git a/testsuite/scripts/runtest b/testsuite/scripts/runtest
index 4c6f25b71d..61dc5cb37f 100755
--- a/testsuite/scripts/runtest
+++ b/testsuite/scripts/runtest
@@ -46,10 +46,12 @@ if [ "$ARCH" = none -o "$ASM" = none ]; then
   Pwith_opt=false
 fi
 
+# Pcustomflag is set to "-custom" (at several places in this file)
+# as soon as a custom runtime is needed.
 if $SUPPORTS_SHARED_LIBRARIES; then
-  config_custom=false
+  Pcustomflag=
 else
-  config_custom=true
+  Pcustomflag=-custom
 fi
 
 sources="$base.ml"
@@ -64,6 +66,7 @@ lexflags=-q
 yaccflags=-q
 topflags=
 cflags=
+fortranflags=
 
 exec_env=
 args=
@@ -105,24 +108,32 @@ precompile () {
     Pocamlfiles=
     for f in $sources; do
         case $f in
-            *.ml|*.mli)
-                Pocamlfiles="$Pocamlfiles $f";;
+            *.ml|*.mli) Pocamlfiles="$Pocamlfiles $f";;
             *.mly)
                 launch $Pyacc $yaccflags $f
-                Pocamlfiles="$Pocamlfiles ${f%.mly}.mli ${f%.mly}.ml";;
+                Pocamlfiles="$Pocamlfiles ${f%.mly}.mli ${f%.mly}.ml"
+                ;;
             *.mll)
                 launch $Plex $lexflags $f
-                Pocamlfiles="$Pocamlfiles ${f%.mll}.ml";;
+                Pocamlfiles="$Pocamlfiles ${f%.mll}.ml"
+                ;;
             *.c)
                 launch $NATIVECC $NATIVECCCOMPOPTS $cflags \
                     -I $CTOPDIR/byterun -c $f
                 Pcustomflag=-custom
-                Pocamlfiles="$Pocamlfiles ${f%.c}.$O";;
+                Pocamlfiles="$Pocamlfiles ${f%.c}.$O"
+                ;;
+            *.f)
+                launch $FORTRAN_COMPILER $fortranflags -c $f
+                Pcustomflag=-custom
+                Pocamlfiles="$Pocamlfiles ${f%.f}.$O"
+                ;;
             *.cmo) Pocamlfiles="$Pocamlfiles ${f%.cmo}.$cmoext";;
             *.cma) Pocamlfiles="$Pocamlfiles ${f%.cma}.$cmaext";;
             *.$O)
                 Pcustomflag=-custom
-                Pocamlfiles="$Pocamlfiles $f";;
+                Pocamlfiles="$Pocamlfiles $f"
+                ;;
             *) error "unexpected source file extension: $f";;
         esac
     done
@@ -137,16 +148,17 @@ opt_comp () {
 byte_comp () {
     preprocess
     precompile cmo cma
+    if $custom; then Pcustomflag=-custom; fi
     launch $Pocamlc $compflags $Pcustomflag $byteflags $Pocamlfiles \
         -o $byte_exec
 }
 
 top_comp () {
-    launch : no compilation
+    launch : no compilation step needed
 }
 
 top_principal_comp () {
-    launch : no compilation
+    launch : no compilation step needed
 }
 
 opt_run () {
@@ -228,7 +240,9 @@ preprocess () {
 }
 
 precheck () {
-    :
+    case "$sources " in
+        *'.f '*) test -n "$FORTRAN_COMPILER";;
+    esac
 }
 
 opt_precheck () {
@@ -280,13 +294,6 @@ cd "$Pdir"
 
 . ./$base.t
 
-# compute whether to use a custom runtime
-if $custom || ! $SUPPORTS_SHARED_LIBRARIES; then
-    Pcustomflag=-custom
-else
-    Pcustomflag=
-fi
-
 ######################################################
 
 Pexport_variables
diff --git a/testsuite/tests/lib-bigarray-2/bigarrfml.reference b/testsuite/tests/lib-bigarray-2/bigarrf.refout
index 8368d5aba0..8368d5aba0 100644
--- a/testsuite/tests/lib-bigarray-2/bigarrfml.reference
+++ b/testsuite/tests/lib-bigarray-2/bigarrf.refout
diff --git a/testsuite/tests/lib-bigarray-2/Makefile b/testsuite/tests/lib-bigarray-2/bigarrf.t
index 373ff94493..4feaf9218e 100644
--- a/testsuite/tests/lib-bigarray-2/Makefile
+++ b/testsuite/tests/lib-bigarray-2/bigarrf.t
@@ -2,18 +2,15 @@
 #                                                                       #
 #                                 OCaml                                 #
 #                                                                       #
-#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
+#                 Damien Doligez, Jane Street Capital                   #
 #                                                                       #
-#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   Copyright 2015 Institut National de Recherche en Informatique et    #
 #   en Automatique.  All rights reserved.  This file is distributed     #
 #   under the terms of the Q Public License version 1.0.                #
 #                                                                       #
 #########################################################################
 
-BASEDIR=../..
-LIBRARIES=unix bigarray
-C_FILES=bigarrfstub
-F_FILES=bigarrf
-
-include $(BASEDIR)/makefiles/Makefile.several
-include $(BASEDIR)/makefiles/Makefile.common
+sources='unix.cma bigarray.cma bigarrf.f bigarrfstub.c bigarrfml.ml'
+cflags="-I $CTOPDIR/otherlibs/bigarray"
+compflags="-I $OTOPDIR/otherlibs/bigarray -I $OTOPDIR/otherlibs/$UNIXLIB \
+           $FORTRAN_LIBRARY"
diff --git a/testsuite/tests/lib-bigarray-2/bigarrfml.ml b/testsuite/tests/lib-bigarray-2/bigarrfml.ml
index 906826fae6..d73f1555f0 100644
--- a/testsuite/tests/lib-bigarray-2/bigarrfml.ml
+++ b/testsuite/tests/lib-bigarray-2/bigarrfml.ml
@@ -39,7 +39,7 @@ let test test_number answer correct_answer =
 (* External C and Fortran functions *)
 
 external c_filltab :
-  unit -> (float, float64_elt, c_layout) Array2.t = "c_filltaab"
+  unit -> (float, float64_elt, c_layout) Array2.t = "c_filltab"
 external c_printtab :
   (float, float64_elt, c_layout) Array2.t -> unit = "c_printtab"
 external fortran_filltab :
diff --git a/testsuite/tests/lib-digest/Makefile b/testsuite/tests/lib-digest/Makefile
deleted file mode 100644
index adda276594..0000000000
--- a/testsuite/tests/lib-digest/Makefile
+++ /dev/null
@@ -1,19 +0,0 @@
-#########################################################################
-#                                                                       #
-#                                 OCaml                                 #
-#                                                                       #
-#                 Xavier Clerc, SED, INRIA Rocquencourt                 #
-#                                                                       #
-#   Copyright 2010 Institut National de Recherche en Informatique et    #
-#   en Automatique.  All rights reserved.  This file is distributed     #
-#   under the terms of the Q Public License version 1.0.                #
-#                                                                       #
-#########################################################################
-
-BASEDIR=../..
-#MODULES=
-MAIN_MODULE=md5
-ADD_COMPFLAGS=-w a
-
-include $(BASEDIR)/makefiles/Makefile.one
-include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/lib-digest/md5.reference b/testsuite/tests/lib-digest/md5.refout
index 956ac65448..956ac65448 100644
--- a/testsuite/tests/lib-digest/md5.reference
+++ b/testsuite/tests/lib-digest/md5.refout
diff --git a/testsuite/tests/typing-misc/polyvars.ml b/testsuite/tests/typing-misc/polyvars.ml
index 00dacf7540..de8cb221bb 100644
--- a/testsuite/tests/typing-misc/polyvars.ml
+++ b/testsuite/tests/typing-misc/polyvars.ml
@@ -5,3 +5,11 @@ let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);;
 
 let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *)
 let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *)
+
+(* PR#6787 *)
+let revapply x f = f x;;
+
+let f x (g : [< `Foo]) =
+  let y = `Bar x, g in
+  revapply y (fun ((`Bar i), _) -> i);;
+(* f : 'a -> [< `Foo ] -> 'a *)
diff --git a/testsuite/tests/typing-misc/polyvars.ml.principal.reference b/testsuite/tests/typing-misc/polyvars.ml.principal.reference
index bc0741abb6..6732640e9f 100644
--- a/testsuite/tests/typing-misc/polyvars.ml.principal.reference
+++ b/testsuite/tests/typing-misc/polyvars.ml.principal.reference
@@ -29,4 +29,6 @@ val f : [< `A | `B ] -> int = <fun>
 Error: This pattern matches values of type [? `C ]
        but a pattern was expected which matches values of type [ `A | `B ]
        The second variant type does not allow tag(s) `C
-# 
+#     val revapply : 'a -> ('a -> 'b) -> 'b = <fun>
+#       val f : 'a -> [< `Foo ] -> 'a = <fun>
+#   
diff --git a/testsuite/tests/typing-misc/polyvars.ml.reference b/testsuite/tests/typing-misc/polyvars.ml.reference
index 27c4cd4304..751b02fc07 100644
--- a/testsuite/tests/typing-misc/polyvars.ml.reference
+++ b/testsuite/tests/typing-misc/polyvars.ml.reference
@@ -29,4 +29,6 @@ val f : [< `A | `B ] -> int = <fun>
 Error: This pattern matches values of type [? `C ]
        but a pattern was expected which matches values of type [ `A | `B ]
        The second variant type does not allow tag(s) `C
-# 
+#     val revapply : 'a -> ('a -> 'b) -> 'b = <fun>
+#       val f : 'a -> [< `Foo ] -> 'a = <fun>
+#   
diff --git a/typing/ctype.ml b/typing/ctype.ml
index b866f86001..2e8c0602c5 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -1059,20 +1059,25 @@ let rec copy ?env ?partial ?keep_names ty =
               (* Open row if partial for pattern and contains Reither *)
               let more', row =
                 match partial with
-                  Some (free_univars, false) when row.row_closed
-                  && not row.row_fixed && TypeSet.is_empty (free_univars ty) ->
+                  Some (free_univars, false) ->
+                    let more' =
+                      if more.id != more'.id then more' else
+                      let lv = if keep then more.level else !current_level in
+                      newty2 lv (Tvar None)
+                    in
                     let not_reither (_, f) =
                       match row_field_repr f with
                         Reither _ -> false
                       | _ -> true
                     in
-                    if List.for_all not_reither row.row_fields
-                    then (more', row) else
-                    (newty2 (if keep then more.level else !current_level)
-                       (Tvar None),
-                     {row_fields = List.filter not_reither row.row_fields;
-                      row_more = more; row_bound = ();
-                      row_closed = false; row_fixed = false; row_name = None})
+                    if row.row_closed && not row.row_fixed
+                    && TypeSet.is_empty (free_univars ty)
+                    && not (List.for_all not_reither row.row_fields) then
+                      (more',
+                       {row_fields = List.filter not_reither row.row_fields;
+                        row_more = more'; row_bound = ();
+                        row_closed = false; row_fixed = false; row_name = None})
+                    else (more', row)
                 | _ -> (more', row)
               in
               (* Register new type first for recursion *)