Adding the -strict-sequence option.

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

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.

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

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

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,

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

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";

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"

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";

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

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 _ ->

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

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