Adding the -strict-sequence option.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@9464 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

15 files changed, 21 insertions, 1 deletions

diff --git a/Changes b/Changes
index 89b5c0d473..d5e4510ff2 100644
--- a/Changes
+++ b/Changes
@@ -35,6 +35,8 @@ Compilers and toplevel:
   are not listed in the pattern.
 - Better error report in case of unbound qualified identifier: if the module
   is unbound this error is reported in the first place.
+- Added option '-strict-sequence' to force left hand part of sequence to have
+  type unit.
 - Added option '-no-app-funct' to turn applicative functors off.
   This option can help working around mysterious type incompatibilities
   caused by the incomplete comparison of applicative paths F(X).t.
diff --git a/VERSION b/VERSION
index 5e8c49cd56..858f084136 100644
--- a/VERSION
+++ b/VERSION
@@ -1,4 +1,4 @@
-3.12.0+dev11 (2009-12-01)
+3.12.0+dev12 (2009-12-01)
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli
diff --git a/boot/ocamlc b/boot/ocamlc
index 18002552fd..dc7017f092 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamldep b/boot/ocamldep
index 572eea7046..178d8e4e8e 100755
--- a/boot/ocamldep
+++ b/boot/ocamldep
diff --git a/boot/ocamllex b/boot/ocamllex
index 0bb44ed19c..0db47b20f4 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/driver/main.ml b/driver/main.ml
index d69a53a3cd..566df0a093 100644
--- a/driver/main.ml
+++ b/driver/main.ml
@@ -119,6 +119,7 @@ module Options = Main_args.Make_options (struct
   let _pp s = preprocessor := Some s
   let _principal = set principal
   let _rectypes = set recursive_types
+  let _strict_sequence = set strict_sequence
   let _thread = set use_threads
   let _vmthread = set use_vmthreads
   let _unsafe = set fast
diff --git a/driver/main_args.ml b/driver/main_args.ml
index b1c9718699..7256c35836 100644
--- a/driver/main_args.ml
+++ b/driver/main_args.ml
@@ -44,6 +44,7 @@ module Make_options (F :
      val _pp : string -> unit
      val _principal : unit -> unit
      val _rectypes : unit -> unit
+     val _strict_sequence : unit -> unit
      val _thread : unit -> unit
      val _vmthread : unit -> unit
      val _unsafe : unit -> unit
@@ -118,6 +119,8 @@ struct
     "-principal", Arg.Unit F._principal,
            " Check principality of type inference";
     "-rectypes", Arg.Unit F._rectypes, " Allow arbitrary recursive types";
+    "-strict-sequence", Arg.Unit F._strict_sequence,
+           " Left hand part of a sequence must have type unit";
     "-thread", Arg.Unit F._thread,
            " Generate code that supports the system threads library";
     "-unsafe", Arg.Unit F._unsafe,
diff --git a/driver/main_args.mli b/driver/main_args.mli
index 30ef02ecde..6097a48169 100644
--- a/driver/main_args.mli
+++ b/driver/main_args.mli
@@ -44,6 +44,7 @@ module Make_options (F :
       val _pp : string -> unit
       val _principal : unit -> unit
       val _rectypes : unit -> unit
+      val _strict_sequence : unit -> unit
       val _thread : unit -> unit
       val _vmthread : unit -> unit
       val _unsafe : unit -> unit
diff --git a/driver/optmain.ml b/driver/optmain.ml
index 2680966671..7a6a038591 100644
--- a/driver/optmain.ml
+++ b/driver/optmain.ml
@@ -157,6 +157,8 @@ let main () =
              " Check principality of type inference";
        "-rectypes", Arg.Set recursive_types,
              " Allow arbitrary recursive types";
+       "-strict-sequence", Arg.Set strict_sequence,
+             " Left hand part of a sequence must have type unit";
        "-shared", Arg.Unit (fun () -> shared := true; dlcode := true),
              " Produce a dynlinkable plugin";
        "-S", Arg.Set keep_asm_file, " Keep intermediate assembly file";
diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml
index 6302ca5bf6..2255320bd2 100644
--- a/tools/ocamlcp.ml
+++ b/tools/ocamlcp.ml
@@ -73,6 +73,7 @@ module Options = Main_args.Make_options (struct
   let _pp s = incompatible "-pp"
   let _principal = option "-principal"
   let _rectypes = option "-rectypes"
+  let _strict_sequence = option "-strict-sequence"
   let _thread () = option "-thread" ()
   let _vmthread () = option "-vmthread" ()
   let _unsafe = option "-unsafe"
diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml
index b75b359987..4e08353ec5 100644
--- a/toplevel/opttopmain.ml
+++ b/toplevel/opttopmain.ml
@@ -74,6 +74,8 @@ let main () =
            " do not add default directory to the list of include directories";
      "-principal", Arg.Set principal, " Check principality of type inference";
      "-rectypes", Arg.Set recursive_types, " Allow arbitrary recursive types";
+     "-strict-sequence", Arg.Set strict_sequence,
+           " Left hand part of a sequence must have type unit";
      "-S", Arg.Set keep_asm_file, " Keep intermediate assembly file";
      "-unsafe", Arg.Set fast, " No bound checking on array and string access";
      "-version", Arg.Unit print_version, " Print version and exit";
diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
index bc4a576f1c..a8cab01ddb 100644
--- a/toplevel/topmain.ml
+++ b/toplevel/topmain.ml
@@ -68,6 +68,8 @@ let main () =
            " do not add default directory to the list of include directories";
      "-principal", Arg.Set principal, " Check principality of type inference";
      "-rectypes", Arg.Set recursive_types, " Allow arbitrary recursive types";
+     "-strict-sequence", Arg.Set recursive_types,
+           " Left hand part of a sequence must have type unit";
      "-unsafe", Arg.Set fast, " No bound checking on array and string access";
      "-version", Arg.Unit print_version, " Print version and exit";
      "-w", Arg.String (Warnings.parse_options false),
diff --git a/typing/typecore.ml b/typing/typecore.ml
index e4c64cb315..21ee81a5fe 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -2145,6 +2145,10 @@ and type_statement env sexp =
   begin_def();
   let exp = type_exp env sexp in
   end_def();
+  if !Clflags.strict_sequence then
+    let expected_type = instance Predef.type_unit in
+    unify env expected_type exp.exp_type;
+    exp else
   let ty = expand_head env exp.exp_type and tv = newvar() in
   begin match ty.desc with
   | Tarrow _ ->
diff --git a/utils/clflags.ml b/utils/clflags.ml
index 7644653302..1074d3628c 100644
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -44,6 +44,7 @@ and use_prims = ref ""                  (* -use-prims ... *)
 and use_runtime = ref ""                (* -use-runtime ... *)
 and principal = ref false               (* -principal *)
 and recursive_types = ref false         (* -rectypes *)
+and strict_sequence = ref false         (* -strict-sequence *)
 and applicative_functors = ref true     (* -no-app-funct *)
 and make_runtime = ref false            (* -make_runtime *)
 and gprofile = ref false                (* -p *)
diff --git a/utils/clflags.mli b/utils/clflags.mli
index e7efafcbeb..d5357ef396 100644
--- a/utils/clflags.mli
+++ b/utils/clflags.mli
@@ -41,6 +41,7 @@ val use_prims : string ref
 val use_runtime : string ref
 val principal : bool ref
 val recursive_types : bool ref
+val strict_sequence : bool ref
 val applicative_functors : bool ref
 val make_runtime : bool ref
 val gprofile : bool ref