diff options
| -rw-r--r-- | typing/env.ml | 1 | ||||
| -rw-r--r-- | typing/includecore.ml | 28 | ||||
| -rw-r--r-- | typing/includecore.mli | 2 | ||||
| -rw-r--r-- | typing/typedecl.ml | 41 | ||||
| -rw-r--r-- | typing/typedecl.mli | 2 | ||||
| -rw-r--r-- | typing/typemod.ml | 10 |
6 files changed, 64 insertions, 20 deletions
diff --git a/typing/env.ml b/typing/env.ml index 92b0c0f0d..3d4893240 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -1053,6 +1053,7 @@ let labels_of_type ty_path decl = | Record_exception (Pident id) -> begin match ty_path with | Path.Pdot (path, _, pos) -> + Format.printf "XXX@."; Record_exception (Path.Pdot (path, Ident.name id, pos)) | Path.Pident _ -> rep diff --git a/typing/includecore.ml b/typing/includecore.ml index 0757c73e7..1514a85cd 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -120,7 +120,7 @@ type type_mismatch = | Field_arity of Ident.t | Field_names of int * Ident.t * Ident.t | Field_missing of bool * Ident.t - | Record_representation of bool + | Record_representation of record_representation * record_representation let report_type_mismatch0 first second decl ppf err = let pr fmt = Format.fprintf ppf fmt in @@ -143,10 +143,16 @@ let report_type_mismatch0 first second decl ppf err = | Field_missing (b, s) -> pr "The field %s is only present in %s %s" (Ident.name s) (if b then second else first) decl - | Record_representation b -> - pr "Their internal representations differ:@ %s %s %s" - (if b then second else first) decl - "uses unboxed float representation" + | Record_representation (r1, r2) -> + let repr = function + | Record_regular 0 -> "regular" + | Record_regular i -> Printf.sprintf"inline record (tag %i)" i + | Record_float -> "unboxed float" + | Record_exception p -> Printf.sprintf "exception %s" (Path.name p) + in + pr "Their internal representations differ:@ %s vs %s" + (repr r1) + (repr r2) let report_type_mismatch first second decl ppf = List.iter @@ -196,6 +202,14 @@ let rec compare_records env decl1 decl2 n labels1 labels2 = then compare_records env decl1 decl2 (n+1) rem1 rem2 else [Field_type lab1] +let record_representations r1 r2 = + match r1, r2 with + | Record_regular i, Record_regular j -> i = j + | Record_float, Record_float -> true + | Record_exception _, Record_exception _ -> true + (* allow a different path to support exception rebinding *) + | _ -> false + let type_declarations ?(equality = false) env name decl1 id decl2 = if decl1.type_arity <> decl2.type_arity then [Arity] else if not (private_flags decl1 decl2) then [Privacy] else @@ -217,8 +231,8 @@ let type_declarations ?(equality = false) env name decl1 id decl2 = compare_variants env decl1 decl2 1 cstrs1 cstrs2 | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> let err = compare_records env decl1 decl2 1 labels1 labels2 in - if err <> [] || rep1 = rep2 then err else - [Record_representation (rep2 = Record_float)] + if err <> [] || record_representations rep1 rep2 then err else + [Record_representation (rep1, rep2)] | (_, _) -> [Kind] in if err <> [] then err else diff --git a/typing/includecore.mli b/typing/includecore.mli index 083624194..75e6c1957 100644 --- a/typing/includecore.mli +++ b/typing/includecore.mli @@ -29,7 +29,7 @@ type type_mismatch = | Field_arity of Ident.t | Field_names of int * Ident.t * Ident.t | Field_missing of bool * Ident.t - | Record_representation of bool + | Record_representation of record_representation * record_representation val value_descriptions: Env.t -> value_description -> value_description -> module_coercion diff --git a/typing/typedecl.ml b/typing/typedecl.ml index c264864e7..0a99a3c70 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -278,7 +278,7 @@ let transl_declaration ?exnid env sdecl id = match sdecl.ptype_attributes with | [{txt="#tag#"}, PStr [{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant(Const_int tag)}, _)}]] -> begin match exnid with - | Some id -> print_endline "XXX"; Record_exception (Path.Pident id) + | Some id -> Record_exception (Path.Pident id) | None -> Record_regular tag end | _ -> @@ -1189,20 +1189,43 @@ let transl_exception env excdecl = let transl_type_decl = transl_type_decl ?exnid:None (* Translate an exception rebinding *) -let transl_exn_rebind env loc lid = +let transl_exn_rebind env loc name lid = let cdescr = try Env.lookup_constructor lid env with Not_found -> raise(Error(loc, Unbound_exception lid)) in Env.mark_constructor Env.Positive env (Longident.last lid) cdescr; - match cdescr.cstr_tag with - Cstr_exception (path, _) -> - (path, {exn_args = cdescr.cstr_args; - exn_attributes = []; - exn_inlined = cdescr.cstr_inlined; - Types.exn_loc = loc}) - | _ -> raise(Error(loc, Not_an_exception lid)) + let path = + match cdescr.cstr_tag with + | Cstr_exception (path, _) -> path + | _ -> raise(Error(loc, Not_an_exception lid)) + in + let tdecls, exn_args = + if cdescr.cstr_inlined then + match cdescr.cstr_args with + | [{desc=Tconstr(p, [], _)} as ty] -> + let tdecl = + try Env.find_type p env + with Not_found -> assert false + in + let tdecl = {tdecl with type_manifest = Some ty} in + let (id, env) = + Env.enter_type ("exn." ^ name) tdecl env + in + ([id, tdecl], env), [ Ctype.newconstr (Path.Pident id) [] ] + | _ -> assert false + else + ([], env), cdescr.cstr_args + in + let d = { + Types.exn_args; + exn_attributes = []; + exn_inlined = cdescr.cstr_inlined; + exn_loc = loc + } + in + (tdecls, path, d) (* Translate a value declaration *) let transl_value_decl env loc valdecl = diff --git a/typing/typedecl.mli b/typing/typedecl.mli index 89989cefb..ee68aa2e3 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -24,7 +24,7 @@ val transl_exception: Parsetree.constructor_declaration -> (Typedtree.type_declaration list * Env.t) * Typedtree.constructor_declaration * exception_declaration * Env.t val transl_exn_rebind: - Env.t -> Location.t -> Longident.t -> Path.t * exception_declaration + Env.t -> Location.t -> string -> Longident.t -> ((Ident.t * Types.type_declaration) list * Env.t) * Path.t * exception_declaration val transl_value_decl: Env.t -> Location.t -> diff --git a/typing/typemod.ml b/typing/typemod.ml index 593b49e1e..ddea66977 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -474,6 +474,10 @@ let mksig desc env loc = let prepend_sig_types decls rem = map_rec'' (fun rs td -> Sig_type(td.typ_id, td.typ_type, rs)) decls rem +let prepend_sig_types' decls rem = + map_rec (fun rs (id, td) -> Sig_type(id, td, rs)) decls rem + + let rec transl_modtype env smty = let loc = smty.pmty_loc in match smty.pmty_desc with @@ -1167,10 +1171,12 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = prepend_sig_types tdecls [Sig_exception(arg.cd_id, decl)], newenv | Pstr_exn_rebind(name, longid, attrs) -> - let (path, arg) = Typedecl.transl_exn_rebind env loc longid.txt in + let ((tdecls, env), path, arg) = + Typedecl.transl_exn_rebind env loc name.txt longid.txt + in let (id, newenv) = Env.enter_exception name.txt arg env in Tstr_exn_rebind(id, name, path, longid, attrs), - [Sig_exception(id, arg)], + prepend_sig_types' tdecls [Sig_exception(id, arg)], newenv | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; pmb_loc; |