diff options
| -rw-r--r-- | driver/main.ml | 1 | ||||
| -rw-r--r-- | driver/main_args.ml | 3 | ||||
| -rw-r--r-- | driver/main_args.mli | 1 | ||||
| -rw-r--r-- | driver/optmain.ml | 2 | ||||
| -rw-r--r-- | otherlibs/labltk/browser/searchpos.ml | 1 | ||||
| -rw-r--r-- | otherlibs/labltk/browser/typecheck.ml | 1 | ||||
| -rw-r--r-- | parsing/parser.mly | 8 | ||||
| -rw-r--r-- | parsing/syntaxerr.ml | 4 | ||||
| -rw-r--r-- | parsing/syntaxerr.mli | 1 | ||||
| -rw-r--r-- | tools/ocamlcp.ml | 1 | ||||
| -rw-r--r-- | toplevel/opttopmain.ml | 2 | ||||
| -rw-r--r-- | toplevel/topmain.ml | 2 | ||||
| -rw-r--r-- | typing/mtype.ml | 2 | ||||
| -rw-r--r-- | typing/typemod.ml | 2 | ||||
| -rw-r--r-- | utils/clflags.ml | 1 | ||||
| -rw-r--r-- | utils/clflags.mli | 1 |
16 files changed, 30 insertions, 3 deletions
diff --git a/driver/main.ml b/driver/main.ml index 7553b916e..d69a53a3c 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 bb72b7945..2d7802a1a 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 1e4cb4944..30ef02ecd 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 9c464c1e5..2a3700441 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 28380dbe5..0da882783 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 89366baa1..890fd195b 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 0775f473b..0170453c3 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 d96b946a8..edaabda12 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 dba7f2902..4e9679926 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 25e591c9d..6302ca5bf 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 4d228aba1..b75b35998 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 012951675..bc4a576f1 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 3123e101d..7cacac807 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 ef8c947e5..21e4f2a02 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 38445235c..764465330 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 af4ded9a6..e7efafcbe 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 |