Added option -no-app-funct to turn off applicative functors

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

16 files changed, 30 insertions, 3 deletions

diff --git a/driver/main.ml b/driver/main.ml
index 7553b916e6..d69a53a3cd 100644
--- a/driver/main.ml
+++ b/driver/main.ml
@@ -108,6 +108,7 @@ module Options = Main_args.Make_options (struct
   let _linkall = set link_everything
   let _make_runtime () =
     custom_runtime := true; make_runtime := true; link_everything := true
+  let _no_app_funct = unset applicative_functors
   let _noassert = set noassert
   let _nolabels = set classic
   let _noautolink = set no_auto_link
diff --git a/driver/main_args.ml b/driver/main_args.ml
index bb72b79450..2d7802a1a3 100644
--- a/driver/main_args.ml
+++ b/driver/main_args.ml
@@ -33,6 +33,7 @@ module Make_options (F :
      val _labels : unit -> unit
      val _linkall : unit -> unit
      val _make_runtime : unit -> unit
+     val _no_app_funct : unit -> unit
      val _noassert : unit -> unit
      val _noautolink : unit -> unit
      val _nolabels : unit -> unit
@@ -99,6 +100,8 @@ struct
     "-make_runtime", Arg.Unit F._make_runtime,
            " (deprecated) same as -make-runtime";
     "-modern", Arg.Unit F._labels, " (deprecated) same as -labels";
+    "-no-app-funct", Arg.Unit F._no_app_funct,
+           " Deactivate applicative functors";
     "-noassert", Arg.Unit F._noassert, " Don't compile assertion checks";
     "-noautolink", Arg.Unit F._noautolink,
            " Don't automatically link C libraries specified in .cma files";
diff --git a/driver/main_args.mli b/driver/main_args.mli
index 1e4cb4944e..30ef02ecde 100644
--- a/driver/main_args.mli
+++ b/driver/main_args.mli
@@ -33,6 +33,7 @@ module Make_options (F :
       val _labels : unit -> unit
       val _linkall : unit -> unit
       val _make_runtime : unit -> unit
+      val _no_app_funct : unit -> unit
       val _noassert : unit -> unit
       val _noautolink : unit -> unit
       val _nolabels : unit -> unit
diff --git a/driver/optmain.ml b/driver/optmain.ml
index 9c464c1e58..2a37004411 100644
--- a/driver/optmain.ml
+++ b/driver/optmain.ml
@@ -132,6 +132,8 @@ let main () =
        "-labels", Arg.Clear classic, " Use commuting label mode";
        "-linkall", Arg.Set link_everything,
              " Link all modules, even unused ones";
+       "-no-app-funct", Arg.Clear applicative_functors,
+           " Deactivate applicative functors";
        "-noassert", Arg.Set noassert, " Don't compile assertion checks";
        "-noautolink", Arg.Set no_auto_link,
              " Don't automatically link C libraries specified in .cmxa files";
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 28380dbe5a..0da882783d 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -392,6 +392,7 @@ let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign =
         let l =
           match e with
             Syntaxerr.Unclosed(l,_,_,_) -> l
+          | Syntaxerr.Applicative_path l -> l
           | Syntaxerr.Other l -> l
         in
         Jg_text.tag_and_see  tw ~start:(tpos l.loc_start.Lexing.pos_cnum)
diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml
index 89366baa14..890fd195bb 100644
--- a/otherlibs/labltk/browser/typecheck.ml
+++ b/otherlibs/labltk/browser/typecheck.ml
@@ -133,6 +133,7 @@ let f txt =
           Syntaxerr.report_error Format.std_formatter err;
           begin match err with
             Syntaxerr.Unclosed(l,_,_,_) -> l
+          | Syntaxerr.Applicative_path l -> l
           | Syntaxerr.Other l -> l
           end
       | Typecore.Error (l,err) ->
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 0775f473bf..0170453c34 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -185,6 +185,12 @@ let bigarray_set arr arg newval =
                        ["", arr;
                         "", ghexp(Pexp_array coords);
                         "", newval]))
+
+let lapply p1 p2 =
+  if !Clflags.applicative_functors
+  then Lapply(p1, p2)
+  else raise (Syntaxerr.Error(Syntaxerr.Applicative_path (symbol_rloc())))
+
 %}
 
 /* Tokens */
@@ -1470,7 +1476,7 @@ mod_longident:
 mod_ext_longident:
     UIDENT                                      { Lident $1 }
   | mod_ext_longident DOT UIDENT                { Ldot($1, $3) }
-  | mod_ext_longident LPAREN mod_ext_longident RPAREN { Lapply($1, $3) }
+  | mod_ext_longident LPAREN mod_ext_longident RPAREN { lapply $1 $3 }
 ;
 mty_longident:
     ident                                       { Lident $1 }
diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml
index d96b946a87..edaabda122 100644
--- a/parsing/syntaxerr.ml
+++ b/parsing/syntaxerr.ml
@@ -18,6 +18,7 @@ open Format
 
 type error =
     Unclosed of Location.t * string * Location.t * string
+  | Applicative_path of Location.t
   | Other of Location.t
 
 exception Error of error
@@ -35,5 +36,8 @@ let report_error ppf = function
         fprintf ppf "%aThis '%s' might be unmatched"
           Location.print_error opening_loc opening
       end
+  | Applicative_path loc ->
+      fprintf ppf "%aSyntax error: applicative paths of the form F(X).t are not supported when the option -no-app-func is set."
+        Location.print_error loc
   | Other loc ->
       fprintf ppf "%aSyntax error" Location.print_error loc
diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli
index dba7f29022..4e9679926a 100644
--- a/parsing/syntaxerr.mli
+++ b/parsing/syntaxerr.mli
@@ -18,6 +18,7 @@ open Format
 
 type error =
     Unclosed of Location.t * string * Location.t * string
+  | Applicative_path of Location.t
   | Other of Location.t
 
 exception Error of error
diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml
index 25e591c9dd..6302ca5bf6 100644
--- a/tools/ocamlcp.ml
+++ b/tools/ocamlcp.ml
@@ -62,6 +62,7 @@ module Options = Main_args.Make_options (struct
   let _labels = option "-labels"
   let _linkall = option "-linkall"
   let _make_runtime = option "-make-runtime"
+  let _no_app_funct = option "-no-app-funct"
   let _noassert = option "-noassert"
   let _nolabels = option "-nolabels"
   let _noautolink = option "-noautolink"
diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml
index 4d228aba1d..b75b359987 100644
--- a/toplevel/opttopmain.ml
+++ b/toplevel/opttopmain.ml
@@ -65,6 +65,8 @@ let main () =
      "-init", Arg.String (fun s -> init_file := Some s),
            "<file>  Load <file> instead of default init file";
      "-labels", Arg.Clear classic, " Labels commute (default)";
+     "-no-app-funct", Arg.Clear applicative_functors,
+           " Deactivate applicative functors";
      "-noassert", Arg.Set noassert, " Do not compile assertion checks";
      "-nolabels", Arg.Set classic, " Ignore labels and do not commute";
      "-noprompt", Arg.Set noprompt, " Suppress all prompts";
diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
index 0129516758..bc4a576f1c 100644
--- a/toplevel/topmain.ml
+++ b/toplevel/topmain.ml
@@ -59,6 +59,8 @@ let main () =
      "-init", Arg.String (fun s -> init_file := Some s),
            "<file>  Load <file> instead of default init file";
      "-labels", Arg.Clear classic, " Labels commute (default)";
+     "-no-app-funct", Arg.Clear applicative_functors,
+           " Deactivate applicative functors";
      "-noassert", Arg.Set noassert, " Do not compile assertion checks";
      "-nolabels", Arg.Set classic, " Ignore labels and do not commute";
      "-noprompt", Arg.Set noprompt, " Suppress all prompts";
diff --git a/typing/mtype.ml b/typing/mtype.ml
index 3123e101df..7cacac807d 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -36,7 +36,7 @@ let rec strengthen env mty p =
   match scrape env mty with
     Tmty_signature sg ->
       Tmty_signature(strengthen_sig env sg p)
-  | Tmty_functor(param, arg, res) ->
+  | Tmty_functor(param, arg, res) when !Clflags.applicative_functors ->
       Tmty_functor(param, arg, strengthen env res (Papply(p, Pident param)))
   | mty ->
       mty
diff --git a/typing/typemod.ml b/typing/typemod.ml
index ef8c947e51..21e4f2a024 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -429,7 +429,7 @@ exception Not_a_path
 let rec path_of_module mexp =
   match mexp.mod_desc with
     Tmod_ident p -> p
-  | Tmod_apply(funct, arg, coercion) ->
+  | Tmod_apply(funct, arg, coercion) when !Clflags.applicative_functors ->
       Papply(path_of_module funct, path_of_module arg)
   | _ -> raise Not_a_path
 
diff --git a/utils/clflags.ml b/utils/clflags.ml
index 38445235cf..7644653302 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 applicative_functors = ref true     (* -no-app-funct *)
 and make_runtime = ref false            (* -make_runtime *)
 and gprofile = ref false                (* -p *)
 and c_compiler = ref (None: string option) (* -cc *)
diff --git a/utils/clflags.mli b/utils/clflags.mli
index af4ded9a6e..e7efafcbeb 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 applicative_functors : bool ref
 val make_runtime : bool ref
 val gprofile : bool ref
 val c_compiler : string option ref