diff options
34 files changed, 592 insertions, 46 deletions
diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex ce31ae955..091d4699b 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 3d79fab7a..4edc94b44 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 81e593950..e379a87af 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -322,6 +322,9 @@ let transl_class ids cl_id arity pub_meths cl = let class_stub = Lprim(Pmakeblock(0, Mutable), [lambda_unit; lambda_unit; lambda_unit]) +let dummy_class undef_fn = + Lprim(Pmakeblock(0, Mutable), [undef_fn; undef_fn; oo_prim "dummy_table"]) + (* Error report *) open Format diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli index dd6d4ef6e..a546b8afc 100644 --- a/bytecomp/translclass.mli +++ b/bytecomp/translclass.mli @@ -16,6 +16,7 @@ open Typedtree open Lambda val class_stub : lambda +val dummy_class : lambda -> lambda val transl_class : Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;; diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index e49a049d1..a9407e2aa 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -20,11 +20,17 @@ open Asttypes open Path open Types open Typedtree +open Primitive open Lambda open Translobj open Translcore open Translclass +type error = + Circular_dependency of Ident.t + +exception Error of Location.t * error + (* Compile a coercion *) let rec apply_coercion restr arg = @@ -87,6 +93,149 @@ let field_path path field = None -> None | Some p -> Some(Pdot(p, Ident.name field, Path.nopos)) +(* Utilities for compiling "module rec" definitions *) + +let undefined_exception loc = + (* Confer Translcore.assert_failed *) + let fname = match loc.Location.loc_start.Lexing.pos_fname with + | "" -> !Location.input_name + | x -> x in + let pos = loc.Location.loc_start in + let line = pos.Lexing.pos_lnum in + let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in + Lprim(Pmakeblock(0, Immutable), + [transl_path Predef.path_undefined_recursive_module; + Lconst(Const_block(0, + [Const_base(Const_string fname); + Const_base(Const_int line); + Const_base(Const_int char)]))]) + +let undefined_function exn_id = + Lfunction(Curried, [Ident.create "undef"], Lprim(Praise, [Lvar exn_id])) + +let init_value modl = + let undef_exn_id = Ident.create "undef_exception" in + let undef_function_id = Ident.create "undef_function" in + let rec init_value_mod env mty = + match Mtype.scrape env mty with + Tmty_ident _ -> + raise Not_found + | Tmty_signature sg -> + Lprim(Pmakeblock(0, Mutable), init_value_struct env sg) + | Tmty_functor(id, arg, res) -> + raise Not_found (* to be fixed? *) + and init_value_struct env sg = + match sg with + [] -> [] + | Tsig_value(id, vdesc) :: rem -> + let init_v = + match Ctype.expand_head env vdesc.val_type with + {desc = Tarrow(_,_,_,_)} -> + Lvar undef_function_id + | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t -> + Lprim(Pmakeblock(Config.lazy_tag, Immutable), + [Lvar undef_function_id]) + | _ -> raise Not_found in + init_v :: init_value_struct env rem + | Tsig_type(id, tdecl) :: rem -> + init_value_struct (Env.add_type id tdecl env) rem + | Tsig_exception(id, edecl) :: rem -> + Lvar undef_exn_id :: init_value_struct env rem + | Tsig_module(id, mty) :: rem -> + init_value_mod env mty :: + init_value_struct (Env.add_module id mty env) rem + | Tsig_modtype(id, minfo) :: rem -> + init_value_struct (Env.add_modtype id minfo env) rem + | Tsig_class(id, cdecl) :: rem -> + Translclass.dummy_class (Lvar undef_function_id) :: + init_value_struct env rem + | Tsig_cltype(id, ctyp) :: rem -> + init_value_struct env rem + in + try + Some(Llet(Alias, undef_exn_id, undefined_exception modl.mod_loc, + Llet(Alias, undef_function_id, undefined_function undef_exn_id, + init_value_mod modl.mod_env modl.mod_type))) + with Not_found -> + None + +(* Reorder bindings to honor dependencies. *) + +type binding_status = Undefined | Inprogress | Defined + +let reorder_rec_bindings bindings = + let id = Array.of_list (List.map (fun (id,_,_,_) -> id) bindings) + and loc = Array.of_list (List.map (fun (_,loc,_,_) -> loc) bindings) + and init = Array.of_list (List.map (fun (_,_,init,_) -> init) bindings) + and rhs = Array.of_list (List.map (fun (_,_,_,rhs) -> rhs) bindings) in + let fv = Array.map Lambda.free_variables rhs in + let num_bindings = Array.length id in + let status = Array.create num_bindings Undefined in + let res = ref [] in + let rec emit_binding i = + match status.(i) with + Defined -> () + | Inprogress -> raise(Error(loc.(i), Circular_dependency id.(i))) + | Undefined -> + if init.(i) = None then begin + status.(i) <- Inprogress; + for j = 0 to num_bindings - 1 do + if IdentSet.mem id.(j) fv.(i) then emit_binding j + done + end; + res := (id.(i), init.(i), rhs.(i)) :: !res; + status.(i) <- Defined in + for i = 0 to num_bindings - 1 do + match status.(i) with + Undefined -> emit_binding i + | Inprogress -> assert false + | Defined -> () + done; + List.rev !res + +(* Generate lambda-code for a reordered list of bindings *) + +let prim_update = + { prim_name = "update_dummy"; + prim_arity = 2; + prim_alloc = true; + prim_native_name = ""; + prim_native_float = false } + +let eval_rec_bindings bindings cont = + let rec bind_inits = function + [] -> + bind_strict bindings + | (id, None, rhs) :: rem -> + bind_inits rem + | (id, Some init, rhs) :: rem -> + Llet(Strict, id, init, bind_inits rem) + and bind_strict = function + [] -> + patch_forwards bindings + | (id, None, rhs) :: rem -> + Llet(Strict, id, rhs, bind_strict rem) + | (id, Some init, rhs) :: rem -> + bind_strict rem + and patch_forwards = function + [] -> + cont + | (id, None, rhs) :: rem -> + patch_forwards rem + | (id, Some init, rhs) :: rem -> + Lsequence(Lprim(Pccall prim_update, [Lvar id; rhs]), patch_forwards rem) + in + bind_inits bindings + +let compile_recmodule compile_rhs bindings cont = + eval_rec_bindings + (reorder_rec_bindings + (List.map + (fun (id, modl) -> + (id, modl.mod_loc, init_value modl, compile_rhs id modl)) + bindings)) + cont + (* Compile a module expression *) let rec transl_module cc rootpath mexp = @@ -158,6 +307,12 @@ and transl_structure fields cc rootpath = function Llet(Strict, id, transl_module Tcoerce_none (field_path rootpath id) modl, transl_structure (id :: fields) cc rootpath rem) + | Tstr_recmodule bindings :: rem -> + compile_recmodule + (fun id modl -> + transl_module Tcoerce_none (field_path rootpath id) modl) + bindings + (transl_structure (map_end fst bindings fields) cc rootpath rem) | Tstr_modtype(id, decl) :: rem -> transl_structure fields cc rootpath rem | Tstr_open path :: rem -> @@ -245,6 +400,16 @@ let transl_store_structure glob map prims str = (add_ident true adds id -> Pgetglobal... to subst). *) Llet(Strict, id, subst_lambda subst lam, Lsequence(store_ident id, transl_store(add_ident true id subst) rem)) + | Tstr_recmodule bindings :: rem -> + let ids = List.map fst bindings in + compile_recmodule + (fun id modl -> + subst_lambda subst + (transl_module Tcoerce_none + (field_path (global_path glob) id) modl)) + bindings + (Lsequence(store_idents ids, + transl_store (add_idents true ids subst) rem)) | Tstr_modtype(id, decl) :: rem -> transl_store subst rem | Tstr_open path :: rem -> @@ -317,6 +482,7 @@ let rec defined_idents = function | Tstr_exception(id, decl) :: rem -> id :: defined_idents rem | Tstr_exn_rebind(id, path) :: rem -> id :: defined_idents rem | Tstr_module(id, modl) :: rem -> id :: defined_idents rem + | Tstr_recmodule decls :: rem -> List.map fst decls @ defined_idents rem | Tstr_modtype(id, decl) :: rem -> defined_idents rem | Tstr_open path :: rem -> defined_idents rem | Tstr_class cl_list :: rem -> @@ -423,6 +589,12 @@ let transl_toplevel_item = function set_toplevel_unique_name id; toploop_setvalue id (transl_module Tcoerce_none (Some(Pident id)) modl) + | Tstr_recmodule bindings -> + let idents = List.map fst bindings in + compile_recmodule + (fun id modl -> transl_module Tcoerce_none (Some(Pident id)) modl) + bindings + (make_sequence toploop_setvalue_id idents) | Tstr_modtype(id, decl) -> lambda_unit | Tstr_open path -> @@ -498,3 +670,13 @@ let transl_store_package component_names target_name coercion = apply_coercion cc (Lprim(Pgetglobal id.(src), []))])) 0 pos_cc_list) | _ -> assert false + +(* Error report *) + +open Format + +let report_error ppf = function + Circular_dependency id -> + fprintf ppf + "@[Cannot safely evaluate the definition@ of the recursively-defined module %a@]" + Printtyp.ident id diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli index bd9a5dfd9..14ef3bb92 100644 --- a/bytecomp/translmod.mli +++ b/bytecomp/translmod.mli @@ -29,3 +29,10 @@ val transl_store_package: val toplevel_name: Ident.t -> string val primitive_declarations: string list ref + +type error = + Circular_dependency of Ident.t + +exception Error of Location.t * error + +val report_error: Format.formatter -> error -> unit diff --git a/byterun/fail.h b/byterun/fail.h index 75e05d25d..75edec7bf 100644 --- a/byterun/fail.h +++ b/byterun/fail.h @@ -34,6 +34,7 @@ #define STACK_OVERFLOW_EXN 8 /* "Stack_overflow" */ #define SYS_BLOCKED_IO 9 /* "Sys_blocked_io" */ #define ASSERT_FAILURE_EXN 10 /* "Assert_failure" */ +#define UNDEFINED_RECURSIVE_MODULE_EXN 11 /* "Undefined_recursive_module" */ #ifdef POSIX_SIGNALS struct longjmp_buffer { diff --git a/driver/errors.ml b/driver/errors.ml index a58b9a938..03cd5690c 100644 --- a/driver/errors.ml +++ b/driver/errors.ml @@ -40,12 +40,18 @@ let report_error ppf exn = Location.print ppf loc; Typetexp.report_error ppf err | Typedecl.Error(loc, err) -> Location.print ppf loc; Typedecl.report_error ppf err + | Typeclass.Error(loc, err) -> + Location.print ppf loc; Typeclass.report_error ppf err | Includemod.Error err -> Includemod.report_error ppf err | Typemod.Error(loc, err) -> Location.print ppf loc; Typemod.report_error ppf err | Translcore.Error(loc, err) -> Location.print ppf loc; Translcore.report_error ppf err + | Translclass.Error(loc, err) -> + Location.print ppf loc; Translclass.report_error ppf err + | Translmod.Error(loc, err) -> + Location.print ppf loc; Translmod.report_error ppf err | Symtable.Error code -> Symtable.report_error ppf code | Bytelink.Error code -> @@ -56,10 +62,6 @@ let report_error ppf exn = Bytepackager.report_error ppf code | Sys_error msg -> fprintf ppf "I/O error: %s" msg - | Typeclass.Error(loc, err) -> - Location.print ppf loc; Typeclass.report_error ppf err - | Translclass.Error(loc, err) -> - Location.print ppf loc; Translclass.report_error ppf err | Warnings.Errors (n) -> fprintf ppf "@.Error: %d error-enabled warnings occurred." n | x -> fprintf ppf "@]"; raise x in diff --git a/driver/opterrors.ml b/driver/opterrors.ml index 8826b6719..a59e6f265 100644 --- a/driver/opterrors.ml +++ b/driver/opterrors.ml @@ -33,19 +33,25 @@ let report_error ppf exn = Env.report_error ppf err | Ctype.Tags(l, l') -> fprintf ppf "In this program,@ variant constructors@ `%s and `%s@ \ - have the same hash value." l l' + have the same hash value.@ Change one of them." l l' | Typecore.Error(loc, err) -> Location.print ppf loc; Typecore.report_error ppf err | Typetexp.Error(loc, err) -> Location.print ppf loc; Typetexp.report_error ppf err | Typedecl.Error(loc, err) -> Location.print ppf loc; Typedecl.report_error ppf err + | Typeclass.Error(loc, err) -> + Location.print ppf loc; Typeclass.report_error ppf err | Includemod.Error err -> Includemod.report_error ppf err | Typemod.Error(loc, err) -> Location.print ppf loc; Typemod.report_error ppf err | Translcore.Error(loc, err) -> Location.print ppf loc; Translcore.report_error ppf err + | Translclass.Error(loc, err) -> + Location.print ppf loc; Translclass.report_error ppf err + | Translmod.Error(loc, err) -> + Location.print ppf loc; Translmod.report_error ppf err | Compilenv.Error code -> Compilenv.report_error ppf code | Asmgen.Error code -> @@ -58,10 +64,6 @@ let report_error ppf exn = Asmpackager.report_error ppf code | Sys_error msg -> fprintf ppf "I/O error: %s" msg - | Typeclass.Error(loc, err) -> - Location.print ppf loc; Typeclass.report_error ppf err - | Translclass.Error(loc, err) -> - Location.print ppf loc; Translclass.report_error ppf err | Warnings.Errors (n) -> fprintf ppf "@.Error: %d error-enabled warnings occurred." n | x -> fprintf ppf "@]"; raise x in diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index 3c6fa92d2..337592c85 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -66,6 +66,8 @@ module Typedtree_search = match tt with | Typedtree.Tstr_module (ident, _) -> Hashtbl.add table (M (Name.from_ident ident)) tt + | Typedtree.Tstr_recmodule bindings -> + assert false (* to be fixed *) | Typedtree.Tstr_modtype (ident, _) -> Hashtbl.add table (MT (Name.from_ident ident)) tt | Typedtree.Tstr_exception (ident, _) -> @@ -1104,6 +1106,9 @@ module Analyser = raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name)) ) + | Parsetree.Pstr_recmodule bindings -> + assert false (* to be fixed *) + | Parsetree.Pstr_modtype (name, modtype) -> let complete_name = Name.concat current_module_name name in let tt_module_type = diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index f59d9a9b0..59bdbcdad 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -707,6 +707,9 @@ module Analyser = in (maybe_more, new_env2, [ Element_module new_module ]) + | Parsetree.Psig_recmodule decls -> + assert false (* to be fixed *) + | Parsetree.Psig_modtype (name, Parsetree.Pmodtype_abstract) -> let sig_mtype = try Signature_search.search_module_type table name diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index 6f2657fa1..614f62cef 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -207,6 +207,8 @@ let rec search_pos_signature l ~pos ~env = add_found_sig (`Type, Lident "exn") ~env ~loc:pt.psig_loc | Psig_module (_, t) -> search_pos_module t ~pos ~env + | Psig_recmodule decls -> + assert false (* to be fixed *) | Psig_modtype (_, Pmodtype_manifest t) -> search_pos_module t ~pos ~env | Psig_modtype _ -> () @@ -664,6 +666,7 @@ let rec search_pos_structure ~pos str = | Tstr_exception _ -> () | Tstr_exn_rebind(_, _) -> () | Tstr_module (_, m) -> search_pos_module_expr m ~pos + | Tstr_recmodule bindings -> assert false (* to be fixed *) | Tstr_modtype _ -> () | Tstr_open _ -> () | Tstr_class l -> diff --git a/parsing/parser.mly b/parsing/parser.mly index 574112f1d..6f673e9e8 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -326,7 +326,8 @@ The precedences must be listed from low to high. %nonassoc IN %nonassoc below_SEMI %nonassoc SEMI /* below EQUAL ({lbl=...; lbl=...}) */ -%nonassoc LET /* above SEMI ( ...; let ... in ...) */ +%nonassoc LET AND /* above SEMI ( ...; let ... in ...) */ + /* below WITH (module rec A: SIG with ... and ...) */ %nonassoc below_WITH %nonassoc FUNCTION WITH /* below BAR (match ... with ...) */ %nonassoc THEN /* below ELSE (if ... then ...) */ @@ -455,6 +456,8 @@ structure_item: { mkstr(Pstr_exn_rebind($2, $4)) } | MODULE UIDENT module_binding { mkstr(Pstr_module($2, $3)) } + | MODULE REC module_rec_bindings + { mkstr(Pstr_recmodule(List.rev $3)) } | MODULE TYPE ident EQUAL module_type { mkstr(Pstr_modtype($3, $5)) } | OPEN mod_longident @@ -474,6 +477,13 @@ module_binding: | LPAREN UIDENT COLON module_type RPAREN module_binding { mkmod(Pmod_functor($2, $4, $6)) } ; +module_rec_bindings: + module_rec_binding { [$1] } + | module_rec_bindings AND module_rec_binding { $3 :: $1 } +; +module_rec_binding: + UIDENT COLON module_type EQUAL module_expr { ($1, $3, $5) } +; /* Module types */ @@ -510,6 +520,8 @@ signature_item: { mksig(Psig_exception($2, $3)) } | MODULE UIDENT module_declaration { mksig(Psig_module($2, $3)) } + | MODULE REC module_rec_declarations + { mksig(Psig_recmodule(List.rev $3)) } | MODULE TYPE ident { mksig(Psig_modtype($3, Pmodtype_abstract)) } | MODULE TYPE ident EQUAL module_type @@ -530,6 +542,13 @@ module_declaration: | LPAREN UIDENT COLON module_type RPAREN module_declaration { mkmty(Pmty_functor($2, $4, $6)) } ; +module_rec_declarations: + module_rec_declaration { [$1] } + | module_rec_declarations AND module_rec_declaration { $3 :: $1 } +; +module_rec_declaration: + UIDENT COLON module_type { ($1, $3) } +; /* Class expressions */ diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 69763d256..10c7bcd2d 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -209,6 +209,7 @@ and signature_item_desc = | Psig_type of (string * type_declaration) list | Psig_exception of string * exception_declaration | Psig_module of string * module_type + | Psig_recmodule of (string * module_type) list | Psig_modtype of string * modtype_declaration | Psig_open of Longident.t | Psig_include of module_type @@ -250,6 +251,7 @@ and structure_item_desc = | Pstr_exception of string * exception_declaration | Pstr_exn_rebind of string * Longident.t | Pstr_module of string * module_expr + | Pstr_recmodule of (string * module_type * module_expr) list | Pstr_modtype of string * module_type | Pstr_open of Longident.t | Pstr_class of class_declaration list diff --git a/parsing/printast.ml b/parsing/printast.ml index 5ea5d4e0d..9cc166d44 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -494,6 +494,9 @@ and signature_item i ppf x = | Psig_module (s, mt) -> line i ppf "Psig_module \"%s\"\n" s; module_type i ppf mt; + | Psig_recmodule decls -> + line i ppf "Psig_recmodule\n"; + list i string_x_module_type ppf decls; | Psig_modtype (s, md) -> line i ppf "Psig_modtype \"%s\"\n" s; modtype_declaration i ppf md; @@ -569,6 +572,9 @@ and structure_item i ppf x = | Pstr_module (s, me) -> line i ppf "Pstr_module \"%s\"\n" s; module_expr i ppf me; + | Pstr_recmodule bindings -> + line i ppf "Pstr_type\n"; + list i string_x_modtype_x_module ppf bindings; | Pstr_modtype (s, mt) -> line i ppf "Pstr_modtype \"%s\"\n" s; module_type i ppf mt; @@ -587,6 +593,15 @@ and string_x_type_declaration i ppf (s, td) = string i ppf s; type_declaration (i+1) ppf td; +and string_x_module_type i ppf (s, mty) = + string i ppf s; + module_type (i+1) ppf mty; + +and string_x_modtype_x_module i ppf (s, mty, modl) = + string i ppf s; + module_type (i+1) ppf mty; + module_expr (i+1) ppf modl; + and longident_x_with_constraint i ppf (li, wc) = line i ppf "%a\n" fmt_longident li; with_constraint (i+1) ppf wc; diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml index dcf23dd6f..8d5c3cb6a 100644 --- a/stdlib/camlinternalOO.ml +++ b/stdlib/camlinternalOO.ml @@ -257,6 +257,16 @@ type table = mutable vars: vars; mutable initializers: (obj -> unit) list } +let dummy_table = + { buckets = [| |]; + methods_by_name = Meths.empty; + methods_by_label = Labs.empty; + previous_states = []; + hidden_meths = []; + vars = Vars.empty; + initializers = []; + size = initial_object_size } + let table_count = ref 0 let new_table () = diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli index 83586a7f3..5e945f931 100644 --- a/stdlib/camlinternalOO.mli +++ b/stdlib/camlinternalOO.mli @@ -37,6 +37,7 @@ val set_method : table -> label -> meth -> unit val narrow : table -> string list -> string list -> string list -> unit val widen : table -> unit val add_initializer : table -> (obj -> unit) -> unit +val dummy_table : table val create_table : string list -> table val init_class : table -> unit diff --git a/stdlib/sys.ml b/stdlib/sys.ml index 1a12fca48..2f1cda152 100644 --- a/stdlib/sys.ml +++ b/stdlib/sys.ml @@ -78,4 +78,4 @@ let catch_break on = (* OCaml version string, must be in the format described in sys.mli. *) -let ocaml_version = "3.06+34 (2003-05-21)";; +let ocaml_version = "3.06+35 (2003-06-16)";; diff --git a/tools/depend.ml b/tools/depend.ml index 7b343a852..96e825e50 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -186,6 +186,10 @@ and add_sig_item bv item = List.iter (add_type bv) args; bv | Psig_module(id, mty) -> add_modtype bv mty; StringSet.add id bv + | Psig_recmodule decls -> + let bv' = List.fold_right StringSet.add (List.map fst decls) bv in + List.iter (fun (id, mty) -> add_modtype bv' mty) decls; + bv' | Psig_modtype(id, mtyd) -> begin match mtyd with Pmodtype_abstract -> () @@ -232,6 +236,14 @@ and add_struct_item bv item = add bv l; bv | Pstr_module(id, modl) -> add_module bv modl; StringSet.add id bv + | Pstr_recmodule bindings -> + let bv' = + List.fold_right StringSet.add + (List.map (fun (id,_,_) -> id) bindings) bv in + List.iter + (fun (id, mty, modl) -> add_modtype bv' mty; add_module bv' modl) + bindings; + bv' | Pstr_modtype(id, mty) -> add_modtype bv mty; bv | Pstr_open l -> diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 9b760e63d..a257663ce 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -83,7 +83,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct let outval_of_untyped_exception bucket = let name = (O.obj(O.field(O.field bucket 0) 0) : string) in let args = - if (name = "Match_failure" || name = "Assert_failure") + if (name = "Match_failure" + || name = "Assert_failure" + || name = "Undefined_recursive_module") && O.size bucket = 2 && O.tag(O.field bucket 1) = 0 then outval_of_untyped_exception_args (O.field bucket 1) 0 diff --git a/typing/ctype.ml b/typing/ctype.ml index 8237fb726..4a33d0c4d 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -1106,6 +1106,10 @@ let rec try_expand_head env ty = let _ = try_expand_head' := try_expand_head +(* Expand once the head of a type *) +let expand_head_once env ty = + try expand_abbrev env (repr ty) with Cannot_expand -> assert false + (* Fully expand the head of a type. *) let rec expand_head env ty = try try_expand_head env ty with Cannot_expand -> repr ty @@ -2888,20 +2892,20 @@ let rec arity ty = | _ -> 0 (* Check whether an abbreviation expands to itself. *) -let rec cyclic_abbrev env id ty = - let ty = repr ty in - match ty.desc with - Tconstr (Path.Pident id', _, _) when Ident.same id id' -> - true - | Tconstr (p, tl, abbrev) -> - begin try - cyclic_abbrev env id (try_expand_head env ty) - with Cannot_expand -> +let cyclic_abbrev env id ty = + let rec check_cycle seen ty = + let ty = repr ty in + match ty.desc with + Tconstr (p, tl, abbrev) -> + if List.exists (Path.same p) seen then true else begin + try + check_cycle (p :: seen) (expand_abbrev env ty) + with Cannot_expand -> + false + end + | _ -> false - end - | _ -> - false - + in check_cycle [Path.Pident id] ty (* Normalize a type before printing, saving... *) let rec normalize_type_rec env ty = diff --git a/typing/ctype.mli b/typing/ctype.mli index e0da260fc..c7c93e109 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -127,6 +127,7 @@ val apply: the parameters [pi] and returns the corresponding instance of [t]. Exception [Cannot_apply] is raised in case of failure. *) +val expand_head_once: Env.t -> type_expr -> type_expr val expand_head: Env.t -> type_expr -> type_expr val full_expand: Env.t -> type_expr -> type_expr diff --git a/typing/mtype.ml b/typing/mtype.ml index d984a32a3..193799345 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -126,3 +126,30 @@ let nondep_supertype env mid mty = in nondep_mty Co mty + +let enrich_typedecl env p decl = + match decl.type_manifest with + Some ty -> decl + | None -> + try + let orig_decl = Env.find_type p env in + if orig_decl.type_arity <> decl.type_arity + then decl + else {decl with type_manifest = + Some(Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil)))} + with Not_found -> + decl + +let rec enrich_modtype env p mty = + match mty with + Tmty_signature sg -> + Tmty_signature(List.map (enrich_item env p) sg) + | _ -> + mty + +and enrich_item env p = function + Tsig_type(id, decl) -> + Tsig_type(id, enrich_typedecl env (Pdot(p, Ident.name id, nopos)) decl) + | Tsig_module(id, mty) -> + Tsig_module(id, enrich_modtype env (Pdot(p, Ident.name id, nopos)) mty) + | item -> item diff --git a/typing/mtype.mli b/typing/mtype.mli index 77d93d566..5bc63c5f5 100644 --- a/typing/mtype.mli +++ b/typing/mtype.mli @@ -27,3 +27,5 @@ val nondep_supertype: Env.t -> Ident.t -> module_type -> module_type (* Return the smallest supertype of the given type in which the given ident does not appear. Raise [Not_found] if no such type exists. *) +val enrich_modtype: Env.t -> Path.t -> module_type -> module_type +val enrich_typedecl: Env.t -> Path.t -> type_declaration -> type_declaration diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 417f53dd2..0aa7945c6 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -108,22 +108,23 @@ and compats ps qs = match ps,qs with exception Empty (* Empty pattern *) -let get_type_descr ty tenv = - let ty = Ctype.repr (Ctype.expand_head tenv ty) in - match ty.desc with - | Tconstr (path,_,_) -> Env.find_type path tenv - | _ -> fatal_error "Parmatch.get_type_descr" - let get_type_path ty tenv = let ty = Ctype.repr (Ctype.expand_head tenv ty) in match ty.desc with | Tconstr (path,_,_) -> path | _ -> fatal_error "Parmatch.get_type_path" -let get_constr tag ty tenv = +let get_type_descr ty tenv = + match (Ctype.repr ty).desc with + | Tconstr (path,_,_) -> Env.find_type path tenv + | _ -> fatal_error "Parmatch.get_type_descr" + +let rec get_constr tag ty tenv = match get_type_descr ty tenv with | {type_kind=Type_variant constr_list} -> Datarepr.find_constr_by_tag tag constr_list + | {type_manifest = Some _} -> + get_constr tag (Ctype.expand_head_once tenv ty) tenv | _ -> fatal_error "Parmatch.get_constr" let find_label lbl lbls = @@ -132,9 +133,11 @@ let find_label lbl lbls = name with Failure "nth" -> "*Unkown label*" -let get_record_labels ty tenv = +let rec get_record_labels ty tenv = match get_type_descr ty tenv with | {type_kind = Type_record(lbls, rep)} -> lbls + | {type_manifest = Some _} -> + get_record_labels (Ctype.expand_head_once tenv ty) tenv | _ -> fatal_error "Parmatch.get_record_labels" diff --git a/typing/predef.ml b/typing/predef.ml index bd141224e..9b5b675b7 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -76,9 +76,11 @@ and ident_division_by_zero = Ident.create "Division_by_zero" and ident_stack_overflow = Ident.create "Stack_overflow" and ident_sys_blocked_io = Ident.create "Sys_blocked_io" and ident_assert_failure = Ident.create "Assert_failure" +and ident_undefined_recursive_module = Ident.create "Undefined_recursive_module" let path_match_failure = Pident ident_match_failure and path_assert_failure = Pident ident_assert_failure +and path_undefined_recursive_module = Pident ident_undefined_recursive_module let build_initial_env add_type add_exception empty_env = let decl_abstr = @@ -155,6 +157,8 @@ let build_initial_env add_type add_exception empty_env = add_exception ident_division_by_zero [] ( add_exception ident_assert_failure [newgenty (Ttuple[type_string; type_int; type_int])] ( + add_exception ident_undefined_recursive_module + [newgenty (Ttuple[type_string; type_int; type_int])] ( add_type ident_int64 decl_abstr ( add_type ident_int32 decl_abstr ( add_type ident_nativeint decl_abstr ( @@ -170,7 +174,7 @@ let build_initial_env add_type add_exception empty_env = add_type ident_string decl_abstr ( add_type ident_char decl_abstr ( add_type ident_int decl_abstr ( - empty_env)))))))))))))))))))))))))) + empty_env))))))))))))))))))))))))))) let builtin_values = List.map (fun id -> Ident.make_global id; (Ident.name id, id)) @@ -178,4 +182,4 @@ let builtin_values = ident_invalid_argument; ident_failure; ident_not_found; ident_sys_error; ident_end_of_file; ident_division_by_zero; ident_sys_blocked_io; - ident_assert_failure ] + ident_assert_failure; ident_undefined_recursive_module ] diff --git a/typing/predef.mli b/typing/predef.mli index 7e1ddf322..66b1e782b 100644 --- a/typing/predef.mli +++ b/typing/predef.mli @@ -49,6 +49,7 @@ val path_lazy_t: Path.t val path_match_failure: Path.t val path_assert_failure : Path.t +val path_undefined_recursive_module : Path.t (* To build the initial environment. Since there is a nasty mutual recursion between predef and env, we break it by parameterizing diff --git a/typing/typeclass.ml b/typing/typeclass.ml index bf4185d23..fa6d86d8f 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -15,6 +15,7 @@ open Misc open Parsetree open Asttypes +open Path open Types open Typedtree open Typecore @@ -1234,6 +1235,29 @@ let class_type_declarations env cls = (*******************************) +let approx_class env sdecl = + let (params, _) = sdecl.pci_params in + Ctype.begin_def(); + let ty_params = List.map (fun _ -> Ctype.newvar()) params in + let cl_cty = + Tcty_signature { cty_self = Ctype.newvar(); + cty_vars = Vars.empty; + cty_concr = Concr.empty } in + Ctype.end_def(); + List.iter Ctype.generalize ty_params; + generalize_class_type cl_cty; + (Ident.create sdecl.pci_name, + { clty_params = ty_params; clty_type = cl_cty; clty_path = unbound_class }, + Ident.create sdecl.pci_name, + Typedecl.abstract_type_decl (List.length params), + Ident.create ("#" ^ sdecl.pci_name), + Typedecl.abstract_type_decl (List.length params)) + +let approx_class_declarations env sdecls = + List.map (approx_class env) sdecls + +(*******************************) + (* Error report *) open Format diff --git a/typing/typeclass.mli b/typing/typeclass.mli index c1b04545b..89a6e6b4f 100644 --- a/typing/typeclass.mli +++ b/typing/typeclass.mli @@ -39,6 +39,12 @@ val class_type_declarations: Ident.t * type_declaration * Ident.t * type_declaration) list * Env.t +val approx_class_declarations: + Env.t -> Parsetree.class_description list -> + (Ident.t * cltype_declaration * + Ident.t * type_declaration * + Ident.t * type_declaration) list + type error = Unconsistent_constraint of (type_expr * type_expr) list | Method_type_mismatch of string * (type_expr * type_expr) list diff --git a/typing/typedecl.ml b/typing/typedecl.ml index e55ba035a..f7278ea4a 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -627,6 +627,29 @@ let transl_with_constraint env sdecl = generalize_decl decl; decl +(* Approximate a type declaration: just make all types abstract *) + +let abstract_type_decl arity = + let rec make_params n = + if n <= 0 then [] else Ctype.newvar() :: make_params (n-1) in + Ctype.begin_def(); + let decl = + { type_params = make_params arity; + type_arity = arity; + type_kind = Type_abstract; + type_manifest = None; + type_variance = replicate_list (true, true, true) arity } in + Ctype.end_def(); + generalize_decl decl; + decl + +let approx_type_decl env name_sdecl_list = + List.map + (fun (name, sdecl) -> + (Ident.create name, + abstract_type_decl (List.length sdecl.ptype_params))) + name_sdecl_list + (**** Error report ****) open Format diff --git a/typing/typedecl.mli b/typing/typedecl.mli index 9a07ebe5e..b109c4854 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -32,6 +32,11 @@ val transl_value_decl: val transl_with_constraint: Env.t -> Parsetree.type_declaration -> type_declaration +val abstract_type_decl: int -> type_declaration +val approx_type_decl: + Env.t -> (string * Parsetree.type_declaration) list -> + (Ident.t * type_declaration) list + (* for typeclass.ml *) val compute_variance_decls: Env.t -> diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 64e021dce..754fe8280 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -135,6 +135,7 @@ and structure_item = | Tstr_exception of Ident.t * exception_declaration | Tstr_exn_rebind of Ident.t * Path.t | Tstr_module of Ident.t * module_expr + | Tstr_recmodule of (Ident.t * module_expr) list | Tstr_modtype of Ident.t * module_type | Tstr_open of Path.t | Tstr_class of (Ident.t * int * string list * class_expr) list diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 15237ab30..acf99a80d 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -136,6 +136,7 @@ and structure_item = | Tstr_exception of Ident.t * exception_declaration | Tstr_exn_rebind of Ident.t * Path.t | Tstr_module of Ident.t * module_expr + | Tstr_recmodule of (Ident.t * module_expr) list | Tstr_modtype of Ident.t * module_type | Tstr_open of Path.t | Tstr_class of (Ident.t * int * string list * class_expr) list diff --git a/typing/typemod.ml b/typing/typemod.ml index d0fc5b2e8..aac1852c3 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -92,6 +92,93 @@ let merge_constraint initial_env loc sg lid constr = with Includemod.Error explanation -> raise(Error(loc, With_mismatch(lid, explanation))) +(* Auxiliary for translating recursively-defined module types. + Return a module type that approximates the shape of the given module + type AST. Retain only module, type, and module type + components of signatures. For types, retain only their arity, + making them abstract otherwise. *) + +let approx_modtype transl_mty init_env smty = + + let rec approx_mty env smty = + match smty.pmty_desc with + Pmty_ident lid -> + begin try + let (path, info) = Env.lookup_modtype lid env in + Tmty_ident path + with Not_found -> + raise(Error(smty.pmty_loc, Unbound_modtype lid)) + end + | Pmty_signature ssg -> + Tmty_signature(approx_sig env ssg) + | Pmty_functor(param, sarg, sres) -> + let arg = approx_mty env sarg in + let (id, newenv) = Env.enter_module param arg env in + let res = approx_mty newenv sres in + Tmty_functor(id, arg, res) + | Pmty_with(sbody, constraints) -> + approx_mty env sbody + + and approx_sig env ssg = + match ssg with + [] -> [] + | item :: srem -> + match item.psig_desc with + | Psig_type sdecls -> + let decls = Typedecl.approx_type_decl env sdecls in + let rem = approx_sig env srem in + map_end (fun (id, info) -> Tsig_type(id, info)) decls rem + | Psig_module(name, smty) -> + let mty = approx_mty env smty in + let (id, newenv) = Env.enter_module name mty env in + Tsig_module(id, mty) :: approx_sig newenv srem + | Psig_recmodule sdecls -> + let decls = + List.map + (fun (name, smty) -> + (Ident.create name, approx_mty env smty)) + sdecls in + let newenv = + List.fold_left (fun env (id, mty) -> Env.add_module id mty env) + env decls in + map_end (fun (id, mty) -> Tsig_module(id, mty)) decls + (approx_sig newenv srem) + | Psig_modtype(name, sinfo) -> + let info = approx_mty_info env sinfo in + let (id, newenv) = Env.enter_modtype name info env in + Tsig_modtype(id, info) :: approx_sig newenv srem + | Psig_open lid -> + let (path, mty) = type_module_path env item.psig_loc lid in + let sg = extract_sig_open env item.psig_loc mty in + let newenv = Env.open_signature path sg env in + approx_sig newenv srem + | Psig_include smty -> + let mty = transl_mty init_env smty in + let sg = Subst.signature Subst.identity + (extract_sig env smty.pmty_loc mty) in + let newenv = Env.add_signature sg env in + sg @ approx_sig newenv srem + | Psig_class sdecls | Psig_class_type sdecls -> + let decls = Typeclass.approx_class_declarations env sdecls in + let rem = approx_sig env srem in + List.flatten + (List.map + (fun (i1, d1, i2, d2, i3, d3) -> + [Tsig_cltype(i1, d1); Tsig_type(i2, d2); Tsig_type(i3, d3)]) + decls) + @ rem + | _ -> + approx_sig env srem + + and approx_mty_info env sinfo = + match sinfo with + Pmodtype_abstract -> + Tmodtype_abstract + | Pmodtype_manifest smty -> + Tmodtype_manifest(approx_mty env smty) + + in approx_mty init_env smty + (* Auxiliaries for checking uniqueness of names in signatures and structures *) module StringSet = Set.Make(struct type t = string let compare = compare end) @@ -171,6 +258,15 @@ and transl_signature env sg = let (id, newenv) = Env.enter_module name mty env in let rem = transl_sig newenv srem in Tsig_module(id, mty) :: rem + | Psig_recmodule sdecls -> + List.iter + (fun (name, smty) -> + check "module" item.psig_loc module_names name) + sdecls; + let (decls, newenv) = + transl_recmodule_modtypes item.psig_loc env sdecls in + let rem = transl_sig newenv srem in + map_end (fun (id, mty) -> Tsig_module(id, mty)) decls rem | Psig_modtype(name, sinfo) -> check "module type" item.psig_loc modtype_names name; let info = transl_modtype_info env sinfo in @@ -228,6 +324,25 @@ and transl_modtype_info env sinfo = | Pmodtype_manifest smty -> Tmodtype_manifest(transl_modtype env smty) +and transl_recmodule_modtypes loc env sdecls = + let make_env curr = + List.fold_left + (fun env (id, mty) -> Env.add_module id mty env) + env curr in + let transition env_c curr = + List.map2 + (fun (_, smty) (id, mty) -> (id, transl_modtype env_c smty)) + sdecls curr in + let init = + List.map + (fun (name, smty) -> + (Ident.create name, approx_modtype transl_modtype env smty)) + sdecls in + let first = transition (make_env init) init in + let final_env = make_env first in + let final_decl = transition final_env init in + (final_decl, final_env) + (* Try to convert a module expression to a module path. *) exception Not_a_path @@ -280,9 +395,33 @@ let rec bound_value_identifiers = function | Tsig_class(id, decl) :: rem -> id :: bound_value_identifiers rem | _ :: rem -> bound_value_identifiers rem +(* Helpers for typing recursive modules *) + +let anchor_submodule name anchor = + match anchor with None -> None | Some p -> Some(Pdot(p, name, nopos)) +let anchor_recmodule id anchor = + Some (Pident id) + +let enrich_type_decls anchor decls oldenv newenv = + match anchor with + None -> newenv + | Some p -> + List.fold_left + (fun e (id, info) -> + let info' = + Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id, nopos)) info + in + Env.add_type id info' e) + oldenv decls + +let enrich_module_type anchor name mty env = + match anchor with + None -> mty + | Some p -> Mtype.enrich_modtype env (Pdot(p, name, nopos)) mty + (* Type a module value expression *) -let rec type_module env smod = +let rec type_module anchor env smod = match smod.pmod_desc with Pmod_ident lid -> let (path, mty) = type_module_path env smod.pmod_loc lid in @@ -291,7 +430,7 @@ let rec type_module env smod = mod_env = env; mod_loc = smod.pmod_loc } | Pmod_structure sstr -> - let (str, sg, finalenv) = type_structure env sstr in + let (str, sg, finalenv) = type_structure anchor env sstr in rm { mod_desc = Tmod_structure str; mod_type = Tmty_signature sg; mod_env = env; @@ -299,14 +438,14 @@ let rec type_module env smod = | Pmod_functor(name, smty, sbody) -> let mty = transl_modtype env smty in let (id, newenv) = Env.enter_module name mty env in - let body = type_module newenv sbody in + let body = type_module None newenv sbody in rm { mod_desc = Tmod_functor(id, mty, body); mod_type = Tmty_functor(id, mty, body.mod_type); mod_env = env; mod_loc = smod.pmod_loc } | Pmod_apply(sfunct, sarg) -> - let funct = type_module env sfunct in - let arg = type_module env sarg in + let funct = type_module None env sfunct in + let arg = type_module None env sarg in begin match Mtype.scrape env funct.mod_type with Tmty_functor(param, mty_param, mty_res) as mty_functor -> let coercion = @@ -334,7 +473,7 @@ let rec type_module env smod = raise(Error(sfunct.pmod_loc, Cannot_apply funct.mod_type)) end | Pmod_constraint(sarg, smty) -> - let arg = type_module env sarg in + let arg = type_module anchor env sarg in let mty = transl_modtype env smty in let coercion = try @@ -346,7 +485,7 @@ let rec type_module env smod = mod_env = env; mod_loc = smod.pmod_loc } -and type_structure env sstr = +and type_structure anchor env sstr = let type_names = ref StringSet.empty and module_names = ref StringSet.empty and modtype_names = ref StringSet.empty in @@ -381,7 +520,9 @@ and type_structure env sstr = (fun (name, decl) -> check "type" loc type_names name) sdecls; let (decls, newenv) = Typedecl.transl_type_decl env sdecls in - let (str_rem, sig_rem, final_env) = type_struct newenv srem in + let newenv' = + enrich_type_decls anchor decls env newenv in + let (str_rem, sig_rem, final_env) = type_struct newenv' srem in (Tstr_type decls :: str_rem, map_end (fun (id, info) -> Tsig_type(id, info)) decls sig_rem, final_env) @@ -401,12 +542,42 @@ and type_structure env sstr = final_env) | {pstr_desc = Pstr_module(name, smodl); pstr_loc = loc} :: srem -> check "module" loc module_names name; - let modl = type_module env smodl in - let (id, newenv) = Env.enter_module name modl.mod_type env in + let modl = type_module (anchor_submodule name anchor) env smodl in + let mty = enrich_module_type anchor name modl.mod_type env in + let (id, newenv) = Env.enter_module name mty env in let (str_rem, sig_rem, final_env) = type_struct newenv srem in (Tstr_module(id, modl) :: str_rem, Tsig_module(id, modl.mod_type) :: sig_rem, final_env) + | {pstr_desc = Pstr_recmodule sbind; pstr_loc = loc} :: srem -> + List.iter + (fun (name, _, _) -> check "module" loc module_names name) + sbind; + let (decls, newenv) = + transl_recmodule_modtypes loc env + (List.map (fun (name, smty, smodl) -> (name, smty)) sbind) in + let type_recmodule_binding (id, mty) (name, smty, smodl) = + let modl = + type_module (anchor_recmodule id anchor) newenv smodl in + let coercion = + try + Includemod.modtypes newenv + (Mtype.strengthen env modl.mod_type (Pident id)) + mty + with Includemod.Error msg -> + raise(Error(smodl.pmod_loc, Not_included msg)) in + let modl' = + { mod_desc = Tmod_constraint(modl, mty, coercion); + mod_type = mty; + mod_env = newenv; + mod_loc = smodl.pmod_loc } in + (id, modl') in + let bind = List.map2 type_recmodule_binding decls sbind in + let (str_rem, sig_rem, final_env) = type_struct newenv srem in + (Tstr_recmodule bind :: str_rem, + map_end (fun (id, modl) -> Tsig_module(id, modl.mod_type)) + bind sig_rem, + final_env) | {pstr_desc = Pstr_modtype(name, smty); pstr_loc = loc} :: srem -> check "module type" loc modtype_names name; let mty = transl_modtype env smty in @@ -462,7 +633,7 @@ and type_structure env sstr = classes [sig_rem]), final_env) | {pstr_desc = Pstr_include smodl; pstr_loc = loc} :: srem -> - let modl = type_module env smodl in + let modl = type_module None env smodl in (* Rename all identifiers bound by this signature to avoid clashes *) let sg = Subst.signature Subst.identity (extract_sig_open env smodl.pmod_loc modl.mod_type) in @@ -475,6 +646,9 @@ and type_structure env sstr = final_env) in type_struct env sstr +let type_module = type_module None +let type_structure = type_structure None + (* Fill in the forward declaration *) let _ = Typecore.type_module := type_module |