update for trunk
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14286 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
parent
b7ab7460d5
commit
37b6979939
|
@ -1,40 +1,8 @@
|
|||
Index: parsing/pprintast.ml
|
||||
===================================================================
|
||||
--- parsing/pprintast.ml (revision 13286)
|
||||
+++ parsing/pprintast.ml (working copy)
|
||||
@@ -821,6 +821,8 @@
|
||||
| Pmty_signature (s) ->
|
||||
pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *)
|
||||
(self#list self#signature_item ) s (* FIXME wrong indentation*)
|
||||
+ | Pmty_functor ({txt="*"}, mt1, mt2) ->
|
||||
+ pp f "@[<hov2>functor () ->@ %a@]" self#module_type mt2
|
||||
| Pmty_functor (s, mt1, mt2) ->
|
||||
pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
|
||||
self#module_type mt1 self#module_type mt2
|
||||
@@ -922,6 +924,8 @@
|
||||
self#module_type mt
|
||||
| Pmod_ident (li) ->
|
||||
pp f "%a" self#longident_loc li;
|
||||
+ | Pmod_functor ({txt="*"}, mt, me) ->
|
||||
+ pp f "functor ()@;->@;%a" self#module_expr me
|
||||
| Pmod_functor (s, mt, me) ->
|
||||
pp f "functor@ (%s@ :@ %a)@;->@;%a"
|
||||
s.txt self#module_type mt self#module_expr me
|
||||
@@ -1001,7 +1005,8 @@
|
||||
| Pstr_module (s, me) ->
|
||||
let rec module_helper me = match me.pmod_desc with
|
||||
| Pmod_functor(s,mt,me) ->
|
||||
- pp f "(%s:%a)" s.txt self#module_type mt ;
|
||||
+ if s.txt = "*" then pp f "()"
|
||||
+ else pp f "(%s:%a)" s.txt self#module_type mt ;
|
||||
module_helper me
|
||||
| _ -> me in
|
||||
pp f "@[<hov2>module %s%a@]"
|
||||
Index: parsing/parser.mly
|
||||
===================================================================
|
||||
--- parsing/parser.mly (revision 13286)
|
||||
--- parsing/parser.mly (revision 14285)
|
||||
+++ parsing/parser.mly (working copy)
|
||||
@@ -532,8 +532,12 @@
|
||||
@@ -542,8 +542,12 @@
|
||||
{ unclosed "struct" 1 "end" 3 }
|
||||
| FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_expr
|
||||
{ mkmod(Pmod_functor(mkrhs $3 3, $5, $8)) }
|
||||
|
@ -47,16 +15,16 @@ Index: parsing/parser.mly
|
|||
| module_expr LPAREN module_expr error
|
||||
{ unclosed "(" 2 ")" 4 }
|
||||
| LPAREN module_expr COLON module_type RPAREN
|
||||
@@ -610,6 +614,8 @@
|
||||
@@ -641,6 +645,8 @@
|
||||
{ mkmod(Pmod_constraint($4, $2)) }
|
||||
| LPAREN UIDENT COLON module_type RPAREN module_binding
|
||||
| LPAREN UIDENT COLON module_type RPAREN module_binding_body
|
||||
{ mkmod(Pmod_functor(mkrhs $2 2, $4, $6)) }
|
||||
+ | LPAREN RPAREN module_binding
|
||||
+ | LPAREN RPAREN module_binding_body
|
||||
+ { mkmod(Pmod_functor(mkrhs "*" 1, mkmty(Pmty_signature []), $3)) }
|
||||
;
|
||||
module_rec_bindings:
|
||||
module_rec_binding { [$1] }
|
||||
@@ -631,6 +637,9 @@
|
||||
module_bindings:
|
||||
module_binding { [$1] }
|
||||
@@ -663,6 +669,9 @@
|
||||
| FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_type
|
||||
%prec below_WITH
|
||||
{ mkmty(Pmty_functor(mkrhs $3 3, $5, $8)) }
|
||||
|
@ -65,8 +33,8 @@ Index: parsing/parser.mly
|
|||
+ { mkmty(Pmty_functor(mkrhs "*" 2, mkmty(Pmty_signature []), $5)) }
|
||||
| module_type WITH with_constraints
|
||||
{ mkmty(Pmty_with($1, List.rev $3)) }
|
||||
| MODULE TYPE OF module_expr
|
||||
@@ -679,6 +688,8 @@
|
||||
| MODULE TYPE OF module_expr %prec below_LBRACKETAT
|
||||
@@ -725,6 +734,8 @@
|
||||
{ $2 }
|
||||
| LPAREN UIDENT COLON module_type RPAREN module_declaration
|
||||
{ mkmty(Pmty_functor(mkrhs $2 2, $4, $6)) }
|
||||
|
@ -75,19 +43,120 @@ Index: parsing/parser.mly
|
|||
;
|
||||
module_rec_declarations:
|
||||
module_rec_declaration { [$1] }
|
||||
Index: parsing/pprintast.ml
|
||||
===================================================================
|
||||
--- parsing/pprintast.ml (revision 14285)
|
||||
+++ parsing/pprintast.ml (working copy)
|
||||
@@ -834,6 +834,8 @@
|
||||
| Pmty_signature (s) ->
|
||||
pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *)
|
||||
(self#list self#signature_item ) s (* FIXME wrong indentation*)
|
||||
+ | Pmty_functor ({txt="*"}, mt1, mt2) ->
|
||||
+ pp f "@[<hov2>functor () ->@ %a@]" self#module_type mt2
|
||||
| Pmty_functor (s, mt1, mt2) ->
|
||||
pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
|
||||
self#module_type mt1 self#module_type mt2
|
||||
@@ -940,6 +942,8 @@
|
||||
self#module_type mt
|
||||
| Pmod_ident (li) ->
|
||||
pp f "%a" self#longident_loc li;
|
||||
+ | Pmod_functor ({txt="*"}, mt, me) ->
|
||||
+ pp f "functor ()@;->@;%a" self#module_expr me
|
||||
| Pmod_functor (s, mt, me) ->
|
||||
pp f "functor@ (%s@ :@ %a)@;->@;%a"
|
||||
s.txt self#module_type mt self#module_expr me
|
||||
@@ -1025,7 +1029,8 @@
|
||||
| Pstr_module x ->
|
||||
let rec module_helper me = match me.pmod_desc with
|
||||
| Pmod_functor(s,mt,me) ->
|
||||
- pp f "(%s:%a)" s.txt self#module_type mt ;
|
||||
+ if s.txt = "*" then pp f "()"
|
||||
+ else pp f "(%s:%a)" s.txt self#module_type mt ;
|
||||
module_helper me
|
||||
| _ -> me in
|
||||
pp f "@[<hov2>module %s%a@]"
|
||||
Index: typing/includemod.ml
|
||||
===================================================================
|
||||
--- typing/includemod.ml (revision 14285)
|
||||
+++ typing/includemod.ml (working copy)
|
||||
@@ -35,6 +35,7 @@
|
||||
Ident.t * class_declaration * class_declaration *
|
||||
Ctype.class_match_failure list
|
||||
| Unbound_modtype_path of Path.t
|
||||
+ | Impure_functor
|
||||
|
||||
type pos =
|
||||
Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
|
||||
@@ -165,6 +166,8 @@
|
||||
| (Mty_signature sig1, Mty_signature sig2) ->
|
||||
signatures env cxt subst sig1 sig2
|
||||
| (Mty_functor(param1, arg1, res1), Mty_functor(param2, arg2, res2)) ->
|
||||
+ if Ident.name param1 = "*" && Ident.name param2 <> "*" then
|
||||
+ raise (Error [cxt, env, Impure_functor]);
|
||||
let arg2' = Subst.modtype subst arg2 in
|
||||
let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in
|
||||
let cc_res =
|
||||
@@ -422,6 +425,8 @@
|
||||
Includeclass.report_error reason
|
||||
| Unbound_modtype_path path ->
|
||||
fprintf ppf "Unbound module type %a" Printtyp.path path
|
||||
+ | Impure_functor ->
|
||||
+ fprintf ppf "An impure functor cannot be made applicative"
|
||||
|
||||
let rec context ppf = function
|
||||
Module id :: rem ->
|
||||
Index: typing/includemod.mli
|
||||
===================================================================
|
||||
--- typing/includemod.mli (revision 14285)
|
||||
+++ typing/includemod.mli (working copy)
|
||||
@@ -40,6 +40,7 @@
|
||||
Ident.t * class_declaration * class_declaration *
|
||||
Ctype.class_match_failure list
|
||||
| Unbound_modtype_path of Path.t
|
||||
+ | Impure_functor
|
||||
|
||||
type pos =
|
||||
Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
|
||||
Index: typing/mtype.ml
|
||||
===================================================================
|
||||
--- typing/mtype.ml (revision 14285)
|
||||
+++ typing/mtype.ml (working copy)
|
||||
@@ -34,7 +34,8 @@
|
||||
match scrape env mty with
|
||||
Mty_signature sg ->
|
||||
Mty_signature(strengthen_sig env sg p)
|
||||
- | Mty_functor(param, arg, res) when !Clflags.applicative_functors ->
|
||||
+ | Mty_functor(param, arg, res)
|
||||
+ when !Clflags.applicative_functors && Ident.name param <> "*" ->
|
||||
Mty_functor(param, arg, strengthen env res (Papply(p, Pident param)))
|
||||
| mty ->
|
||||
mty
|
||||
Index: typing/oprint.ml
|
||||
===================================================================
|
||||
--- typing/oprint.ml (revision 14285)
|
||||
+++ typing/oprint.ml (working copy)
|
||||
@@ -344,6 +344,8 @@
|
||||
let rec print_out_module_type ppf =
|
||||
function
|
||||
Omty_abstract -> ()
|
||||
+ | Omty_functor ("*", _, mty_res) ->
|
||||
+ fprintf ppf "@[<2>functor@ () ->@ %a@]" print_out_module_type mty_res
|
||||
| Omty_functor (name, mty_arg, mty_res) ->
|
||||
fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name
|
||||
print_out_module_type mty_arg print_out_module_type mty_res
|
||||
Index: typing/typemod.ml
|
||||
===================================================================
|
||||
--- typing/typemod.ml (revision 13286)
|
||||
--- typing/typemod.ml (revision 14285)
|
||||
+++ typing/typemod.ml (working copy)
|
||||
@@ -37,6 +37,7 @@
|
||||
| Not_a_packed_module of type_expr
|
||||
| Incomplete_packed_module of type_expr
|
||||
@@ -39,6 +39,7 @@
|
||||
| Scoping_pack of Longident.t * type_expr
|
||||
| Extension of string
|
||||
| Recursive_module_require_explicit_type
|
||||
+ | Apply_impure
|
||||
|
||||
exception Error of Location.t * error
|
||||
exception Error of Location.t * Env.t * error
|
||||
|
||||
@@ -832,8 +833,10 @@
|
||||
@@ -950,8 +951,10 @@
|
||||
mod_loc = smod.pmod_loc }
|
||||
| Pmod_functor(name, smty, sbody) ->
|
||||
let mty = transl_modtype env smty in
|
||||
|
@ -100,21 +169,21 @@ Index: typing/typemod.ml
|
|||
rm { mod_desc = Tmod_functor(id, name, mty, body);
|
||||
mod_type = Mty_functor(id, mty.mty_type, body.mod_type);
|
||||
mod_env = env;
|
||||
@@ -845,6 +848,13 @@
|
||||
@@ -964,6 +967,13 @@
|
||||
type_module (sttn && path <> None) funct_body None env sfunct in
|
||||
begin match Mtype.scrape env funct.mod_type with
|
||||
Mty_functor(param, mty_param, mty_res) as mty_functor ->
|
||||
+ let impure = Ident.name param = "*" in
|
||||
+ if impure then begin
|
||||
+ if sarg.pmod_desc <> Pmod_structure [] then
|
||||
+ raise (Error (sfunct.pmod_loc, Apply_impure));
|
||||
+ raise (Error (sfunct.pmod_loc, env, Apply_impure));
|
||||
+ if funct_body then
|
||||
+ raise (Error (smod.pmod_loc, Not_allowed_in_functor_body));
|
||||
+ raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
|
||||
+ end;
|
||||
let coercion =
|
||||
try
|
||||
Includemod.modtypes env arg.mod_type mty_param
|
||||
@@ -856,6 +866,7 @@
|
||||
@@ -975,6 +985,7 @@
|
||||
Subst.modtype (Subst.add_module param path Subst.identity)
|
||||
mty_res
|
||||
| None ->
|
||||
|
@ -122,7 +191,7 @@ Index: typing/typemod.ml
|
|||
try
|
||||
Mtype.nondep_supertype
|
||||
(Env.add_module param arg.mod_type env) param mty_res
|
||||
@@ -1429,7 +1440,7 @@
|
||||
@@ -1549,7 +1560,7 @@
|
||||
Location.print_filename intf_name
|
||||
| Not_allowed_in_functor_body ->
|
||||
fprintf ppf
|
||||
|
@ -131,90 +200,24 @@ Index: typing/typemod.ml
|
|||
| With_need_typeconstr ->
|
||||
fprintf ppf
|
||||
"Only type constructors with identical parameters can be substituted."
|
||||
@@ -1446,3 +1457,5 @@
|
||||
"The type %a in this module cannot be exported.@ " longident lid;
|
||||
fprintf ppf
|
||||
"Its type contains local dependencies:@ %a" type_expr ty
|
||||
@@ -1570,6 +1581,8 @@
|
||||
fprintf ppf "Uninterpreted extension '%s'." s
|
||||
| Recursive_module_require_explicit_type ->
|
||||
fprintf ppf "Recursive modules require an explicit module type."
|
||||
+ | Apply_impure ->
|
||||
+ fprintf ppf "This functor is impure. It can only be applied to ()"
|
||||
|
||||
let report_error env ppf err =
|
||||
Printtyp.wrap_printing_env env (fun () -> report_error ppf err)
|
||||
Index: typing/typemod.mli
|
||||
===================================================================
|
||||
--- typing/typemod.mli (revision 13286)
|
||||
--- typing/typemod.mli (revision 14285)
|
||||
+++ typing/typemod.mli (working copy)
|
||||
@@ -60,6 +60,7 @@
|
||||
| Not_a_packed_module of type_expr
|
||||
| Incomplete_packed_module of type_expr
|
||||
| Scoping_pack of Longident.t * type_expr
|
||||
| Extension of string
|
||||
| Recursive_module_require_explicit_type
|
||||
+ | Apply_impure
|
||||
|
||||
exception Error of Location.t * error
|
||||
exception Error of Location.t * Env.t * error
|
||||
|
||||
Index: typing/oprint.ml
|
||||
===================================================================
|
||||
--- typing/oprint.ml (revision 13286)
|
||||
+++ typing/oprint.ml (working copy)
|
||||
@@ -343,6 +343,8 @@
|
||||
let rec print_out_module_type ppf =
|
||||
function
|
||||
Omty_abstract -> ()
|
||||
+ | Omty_functor ("*", _, mty_res) ->
|
||||
+ fprintf ppf "@[<2>functor@ () ->@ %a@]" print_out_module_type mty_res
|
||||
| Omty_functor (name, mty_arg, mty_res) ->
|
||||
fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name
|
||||
print_out_module_type mty_arg print_out_module_type mty_res
|
||||
Index: typing/includemod.ml
|
||||
===================================================================
|
||||
--- typing/includemod.ml (revision 13286)
|
||||
+++ typing/includemod.ml (working copy)
|
||||
@@ -35,6 +35,7 @@
|
||||
Ident.t * class_declaration * class_declaration *
|
||||
Ctype.class_match_failure list
|
||||
| Unbound_modtype_path of Path.t
|
||||
+ | Impure_functor
|
||||
|
||||
type pos =
|
||||
Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
|
||||
@@ -153,6 +154,8 @@
|
||||
| (Mty_signature sig1, Mty_signature sig2) ->
|
||||
signatures env cxt subst sig1 sig2
|
||||
| (Mty_functor(param1, arg1, res1), Mty_functor(param2, arg2, res2)) ->
|
||||
+ if Ident.name param1 = "*" && Ident.name param2 <> "*" then
|
||||
+ raise (Error [cxt, Impure_functor]);
|
||||
let arg2' = Subst.modtype subst arg2 in
|
||||
let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in
|
||||
let cc_res =
|
||||
@@ -404,6 +407,8 @@
|
||||
Includeclass.report_error reason
|
||||
| Unbound_modtype_path path ->
|
||||
fprintf ppf "Unbound module type %a" Printtyp.path path
|
||||
+ | Impure_functor ->
|
||||
+ fprintf ppf "An impure functor cannot be made applicative"
|
||||
|
||||
let rec context ppf = function
|
||||
Module id :: rem ->
|
||||
Index: typing/includemod.mli
|
||||
===================================================================
|
||||
--- typing/includemod.mli (revision 13286)
|
||||
+++ typing/includemod.mli (working copy)
|
||||
@@ -40,6 +40,7 @@
|
||||
Ident.t * class_declaration * class_declaration *
|
||||
Ctype.class_match_failure list
|
||||
| Unbound_modtype_path of Path.t
|
||||
+ | Impure_functor
|
||||
|
||||
type pos =
|
||||
Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
|
||||
Index: typing/mtype.ml
|
||||
===================================================================
|
||||
--- typing/mtype.ml (revision 13286)
|
||||
+++ typing/mtype.ml (working copy)
|
||||
@@ -34,7 +34,8 @@
|
||||
match scrape env mty with
|
||||
Mty_signature sg ->
|
||||
Mty_signature(strengthen_sig env sg p)
|
||||
- | Mty_functor(param, arg, res) when !Clflags.applicative_functors ->
|
||||
+ | Mty_functor(param, arg, res)
|
||||
+ when !Clflags.applicative_functors && Ident.name param <> "*" ->
|
||||
Mty_functor(param, arg, strengthen env res (Papply(p, Pident param)))
|
||||
| mty ->
|
||||
mty
|
||||
|
|
Loading…
Reference in New Issue